diff --git a/benchmarks/haskell/Benchmarks/FileWrite.hs b/benchmarks/haskell/Benchmarks/FileWrite.hs index bc7cd960..79db1bd3 100644 --- a/benchmarks/haskell/Benchmarks/FileWrite.hs +++ b/benchmarks/haskell/Benchmarks/FileWrite.hs @@ -14,17 +14,22 @@ module Benchmarks.FileWrite import System.IO import Data.String (fromString) import qualified Data.Text.Lazy as LT -import Test.Tasty.Bench (Benchmark, bgroup, bench, nfIO) +import Test.Tasty.Bench (Benchmark, bgroup, bench, nfAppIO) import qualified Data.Text.IO as T import qualified Data.Text.Lazy.IO as LT -import Control.DeepSeq (deepseq) +import Control.DeepSeq (NFData, deepseq) import Data.Functor ((<&>)) +import Data.Text (StrictText) +import Data.Text.Lazy (LazyText) +import qualified Data.Text.IO.Utf8 as Utf8 +import Data.Bifunctor (first) 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] - newlineSelect nl = do + 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 @@ -37,31 +42,29 @@ mkFileWriteBenchmarks mkSinkNRemove = do hSetNewlineMode blockBufH nlm return - ( bgroup ("Newline " <> show nl) $ lengths <&> \n -> let + ( bgroup (groupName <> " " <> show nl) $ lengths <&> \n -> let st = LT.toStrict lt lt = LT.take n writeDate - in bgroup ("length " <> show n) - [ deepseq st $ bgroup "StrictText" - [ bench "NoBuffering" $ nfIO $ T.hPutStr noBufH st - , bench "LineBuffering" $ nfIO $ T.hPutStr lineBufH st - , bench "BlockBuffering" $ nfIO $ T.hPutStr blockBufH st - ] - , deepseq lt $ bgroup "LazyText" - [ bench "NoBuffering" $ nfIO $ LT.hPutStr noBufH lt - , bench "LineBuffering" $ nfIO $ LT.hPutStr lineBufH lt - , bench "BlockBuffering" $ nfIO $ LT.hPutStr blockBufH lt - ] - ] + 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 + ] - (lfB, lfR) <- newlineSelect LF - (crlfB, crlfR) <- newlineSelect CRLF - return - ( bgroup "FileWrite" [lfB, crlfB] - , lfR >> crlfR - ) - +strict = fst +lazy = snd