Added file write benchmarks

benchmarks/haskell/Benchmarks.hs

@@ -19,6 +19,7 @@ import qualified Benchmarks.DecodeUtf8 as DecodeUtf8
 import qualified Benchmarks.EncodeUtf8 as EncodeUtf8
 import qualified Benchmarks.Equality as Equality
 import qualified Benchmarks.FileRead as FileRead
+import qualified Benchmarks.FileWrite as FileWrite
 import qualified Benchmarks.FoldLines as FoldLines
 import qualified Benchmarks.Micro as Micro
 import qualified Benchmarks.Multilang as Multilang
@@ -59,6 +60,9 @@ main = do
     let tf = ("benchmarks/text-test-data" </>)
     -- Cannot use envWithCleanup, because there is no instance NFData Handle
     (sinkFn, sink) <- mkSink
+    (fileWriteBenchmarks, fileWriteCleanup) <- FileWrite.mkFileWriteBenchmarks $ do
+      (fp, h) <- mkSink
+      return (h, rmSink fp)
     defaultMain
         [ Builder.benchmark
         , Concat.benchmark
@@ -77,6 +81,7 @@ main = do
             ]
         , env (Equality.initEnv (tf "japanese.txt")) Equality.benchmark
         , FileRead.benchmark (tf "russian.txt")
+        , fileWriteBenchmarks
         , FoldLines.benchmark (tf "russian.txt")
         , Multilang.benchmark
         , bgroup "Pure"
@@ -102,3 +107,4 @@ main = do
             ]
         ]
     rmSink sinkFn
+    fileWriteCleanup

benchmarks/haskell/Benchmarks/FileWrite.hs

@@ -0,0 +1,74 @@
+-- | Benchmarks simple file writing
+--
+-- Tested in this benchmark:
+--
+-- * Writing a file to the disk
+--
+
+{-# LANGUAGE BangPatterns #-}
+
+module Benchmarks.FileWrite
+    ( mkFileWriteBenchmarks
+    ) where
+
+import Control.DeepSeq (NFData, deepseq)
+import Data.Bifunctor (first)
+import Data.Semigroup ((<>))
+import Data.String (fromString)
+import Data.Text (StrictText)
+import Data.Text.Lazy (LazyText)
+import System.IO (Handle, Newline(CRLF,LF), NewlineMode(NewlineMode), BufferMode(NoBuffering,LineBuffering,BlockBuffering), hSetBuffering, hSetNewlineMode)
+import Test.Tasty.Bench (Benchmark, bgroup, bench, nfAppIO)
+import qualified Data.Text.IO as T
+import qualified Data.Text.IO.Utf8 as Utf8
+import qualified Data.Text.Lazy as LT
+import qualified Data.Text.Lazy.IO as LT
+
+mkFileWriteBenchmarks :: IO (Handle, IO ()) -> IO (Benchmark, IO ())
+mkFileWriteBenchmarks mkSinkNRemove = do
+  let writeDate = LT.cycle $ fromString [minBound..maxBound]
+      lengths = [0..5] <> [10,20..100] <> [1000,10000,100000]
+      testGroup :: NFData text => String -> (Handle -> text -> IO ()) -> ((StrictText,LazyText) -> text) -> Newline -> IO (Benchmark, IO ())
+      testGroup groupName hPutStr select nl = do
+        let nlm = NewlineMode nl nl
+        (!noBufH, noBufRm) <- mkSinkNRemove
+        hSetBuffering noBufH NoBuffering
+        hSetNewlineMode noBufH nlm
+        (!lineBufH, lineBufRm) <- mkSinkNRemove
+        hSetBuffering lineBufH LineBuffering
+        hSetNewlineMode lineBufH nlm
+        (!blockBufH, blockBufRm) <- mkSinkNRemove
+        hSetBuffering blockBufH $ BlockBuffering Nothing
+        hSetNewlineMode blockBufH nlm
+
+        pure
+          ( bgroup (groupName <> " " <> show nl) $ lengths <&> \n -> let
+              st = LT.toStrict lt
+              lt = LT.take n writeDate
+              t = select (st, lt)
+              in bgroup ("length " <> show n) $ deepseq t
+                [ bench "NoBuffering"    $ nfAppIO (hPutStr noBufH)    t
+                , bench "LineBuffering"  $ nfAppIO (hPutStr lineBufH)  t
+                , bench "BlockBuffering" $ nfAppIO (hPutStr blockBufH) t
+                ]
+          , do
+              noBufRm
+              lineBufRm
+              blockBufRm
+          )
+  first (bgroup "FileWrite")
+    . foldr (\(b,r) (bs,rs) -> (b:bs,r>>rs)) ([], return ())
+    <$> sequence
+    [ testGroup "Strict hPutStr" T.hPutStr    strict LF
+    , testGroup "Lazy   hPutStr" LT.hPutStr   lazy   LF
+    , testGroup "Strict hPutStr" T.hPutStr    strict CRLF
+    , testGroup "Lazy   hPutStr" LT.hPutStr   lazy   CRLF
+    , testGroup "Utf-8  hPutStr" Utf8.hPutStr strict LF
+    ]
+
+  where
+  strict = fst
+  lazy = snd
+
+(<&>) :: Functor f => f a -> (a -> b) -> f b
+(<&>) = flip fmap

text.cabal

@@ -332,6 +332,7 @@ benchmark text-benchmarks
     Benchmarks.EncodeUtf8
     Benchmarks.Equality
     Benchmarks.FileRead
+    Benchmarks.FileWrite
     Benchmarks.FoldLines
     Benchmarks.Micro
     Benchmarks.Multilang