git.iko.soy/streamly
on beabbcc help sign in
streamly/benchmark/Streamly/Benchmark/Data/Parser/ParserK.hs
197 lines 6.1 kB history raw
1-- |
2-- Module : Streamly.Benchmark.Data.ParserK
3-- Copyright : (c) 2020 Composewell Technologies
4--
5-- License : BSD-3-Clause
6-- Maintainer : streamly@composewell.com
8{-# LANGUAGE CPP #-}
9{-# LANGUAGE FlexibleContexts #-}
10{-# OPTIONS_GHC -fspec-constr-recursive=4 #-}
12module Main
13 (
14 main
15 ) where
17import Control.DeepSeq (NFData(..))
18import Control.Monad.Catch (MonadCatch)
19import Data.Foldable (asum)
20import System.Random (randomRIO)
21import Prelude hiding (any, all, take, sequence, sequenceA, takeWhile)
23import qualified Control.Applicative as AP
24import qualified Data.Foldable as F
25import qualified Data.Traversable as TR
26import qualified Streamly.Prelude as S
27import qualified Streamly.Internal.Data.Fold as FL
28import qualified Streamly.Internal.Data.Parser.ParserK.Types as PR
29import qualified Streamly.Internal.Data.Parser.ParserD as PRD
30import qualified Streamly.Internal.Data.Stream.IsStream as IP
32import Gauge
33import Streamly.Prelude (SerialT, MonadAsync, IsStream)
34import Streamly.Benchmark.Common
36-------------------------------------------------------------------------------
37-- Utilities
38-------------------------------------------------------------------------------
40-- XXX these can be moved to the common module
42{-# INLINE sourceUnfoldrM #-}
43sourceUnfoldrM :: (IsStream t, MonadAsync m) => Int -> Int -> t m Int
44sourceUnfoldrM value n = S.unfoldrM step n
45 where
46 step cnt =
47 if cnt > n + value
48 then return Nothing
49 else return (Just (cnt, cnt + 1))
51-- | Takes a fold method, and uses it with a default source.
52{-# INLINE benchIOSink #-}
53benchIOSink
54 :: (IsStream t, NFData b)
55 => Int -> String -> (t IO Int -> IO b) -> Benchmark
56benchIOSink value name f =
57 bench name $ nfIO $ randomRIO (1,1) >>= f . sourceUnfoldrM value
59-------------------------------------------------------------------------------
60-- Parsers
61-------------------------------------------------------------------------------
63#ifdef FROM_PARSERK
64#define PARSE_OP (IP.parseD . PR.fromParserK)
65#else
66#define PARSE_OP IP.parseK
67#endif
69{-# INLINE satisfy #-}
70satisfy :: MonadCatch m => (a -> Bool) -> PR.Parser m a a
71satisfy = PR.toParserK . PRD.satisfy
73{-# INLINE any #-}
74any :: MonadCatch m => (a -> Bool) -> PR.Parser m a Bool
75any = PR.toParserK . PRD.any
77{-# INLINE anyK #-}
78anyK :: (MonadCatch m, Ord a) => a -> SerialT m a -> m Bool
79anyK value = PARSE_OP (any (> value))
81{-# INLINE all #-}
82all :: MonadCatch m => (a -> Bool) -> PR.Parser m a Bool
83all = PR.toParserK . PRD.all
85{-# INLINE allK #-}
86allK :: (MonadCatch m, Ord a) => a -> SerialT m a -> m Bool
87allK value = PARSE_OP (all (<= value))
89{-# INLINE take #-}
90take :: MonadCatch m => Int -> PR.Parser m a ()
91take value = PR.toParserK $ PRD.take value FL.drain
93{-# INLINE takeK #-}
94takeK :: MonadCatch m => Int -> SerialT m a -> m ()
95takeK value = PARSE_OP (take value)
97{-# INLINE takeWhile #-}
98takeWhile :: MonadCatch m => (a -> Bool) -> PR.Parser m a ()
99takeWhile p = PR.toParserK $ PRD.takeWhile p FL.drain
101{-# INLINE takeWhileK #-}
102takeWhileK :: MonadCatch m => Int -> SerialT m Int -> m ()
103takeWhileK value = PARSE_OP (takeWhile (<= value))
105{-# INLINE splitApp #-}
106splitApp :: MonadCatch m
107 => Int -> SerialT m Int -> m (Bool, Bool)
108splitApp value =
109 PARSE_OP ((,) <$> any (>= (value `div` 2)) <*> any (> value))
111{-# INLINE sequenceA #-}
112sequenceA :: MonadCatch m => Int -> SerialT m Int -> m Int
113sequenceA value xs = do
114 let parser = satisfy (> 0)
115 list = Prelude.replicate value parser
116 x <- PARSE_OP (TR.sequenceA list) xs
117 return $ Prelude.length x
119{-# INLINE sequenceA_ #-}
120sequenceA_ :: MonadCatch m => Int -> SerialT m Int -> m ()
121sequenceA_ value xs = do
122 let parser = satisfy (> 0)
123 list = Prelude.replicate value parser
124 PARSE_OP (F.sequenceA_ list) xs
126{-# INLINE sequence #-}
127sequence :: MonadCatch m => Int -> SerialT m Int -> m Int
128sequence value xs = do
129 let parser = satisfy (> 0)
130 list = Prelude.replicate value parser
131 x <- PARSE_OP (TR.sequence list) xs
132 return $ Prelude.length x
134{-# INLINE manyAlt #-}
135manyAlt :: MonadCatch m => SerialT m Int -> m Int
136manyAlt xs = do
137 x <- PARSE_OP (AP.many (satisfy (> 0))) xs
138 return $ Prelude.length x
140{-# INLINE someAlt #-}
141someAlt :: MonadCatch m => SerialT m Int -> m Int
142someAlt xs = do
143 x <- PARSE_OP (AP.some (satisfy (> 0))) xs
144 return $ Prelude.length x
146{-# INLINE choice #-}
147choice :: MonadCatch m => Int -> SerialT m Int -> m Int
148choice value =
149 PARSE_OP (asum (replicate value (satisfy (< 0)))
150 AP.<|> satisfy (> 0))
152-------------------------------------------------------------------------------
153-- Benchmarks
154-------------------------------------------------------------------------------
156moduleName :: String
157moduleName = "Data.Parser.ParserK"
159o_1_space_serial :: Int -> [Benchmark]
160o_1_space_serial value =
161 [ benchIOSink value "any" $ anyK value
162 , benchIOSink value "all" $ allK value
163 , benchIOSink value "take" $ takeK value
164 , benchIOSink value "takeWhile" $ takeWhileK value
165 , benchIOSink value "splitApp" $ splitApp value
166 ]
168-- O(n) heap beacuse of accumulation of the list in strict IO monad?
169o_n_heap_serial :: Int -> [Benchmark]
170o_n_heap_serial value =
171 [ benchIOSink value "sequenceA" $ sequenceA value
172 , benchIOSink value "sequenceA_" $ sequenceA_ value
173 , benchIOSink value "sequence" $ sequence value
174 , benchIOSink value "manyAlt" manyAlt
175 , benchIOSink value "someAlt" someAlt
176 , benchIOSink value "choice" $ choice value
177 ]
179-------------------------------------------------------------------------------
180-- Driver
181-------------------------------------------------------------------------------
183main :: IO ()
184main = do
185 (value, cfg, benches) <- parseCLIOpts defaultStreamSize
186 value `seq` runMode (mode cfg) cfg benches (allBenchmarks value)
188 where
190 allBenchmarks value =
191 [ bgroup (o_1_space_prefix moduleName) $ concat
192 [ o_1_space_serial value
193 ]
194 , bgroup (o_n_heap_prefix moduleName) $ concat
195 [ o_n_heap_serial value
196 ]
197 ]