@@ -0,0 +1,187 @@
1+{-# LANGUAGE TupleSections #-}
2+{-# LANGUAGE RecordWildCards #-}
3+{-# LANGUAGE ScopedTypeVariables #-}
4+
5+module Main where
6+
7+import Control.Exception (handle, catch, SomeException, ErrorCall(..))
8+import Control.Monad.Trans.State
9+import Control.Monad.Trans.Maybe
10+import Data.List
11+import Data.List.Split
12+import Data.Ord (comparing)
13+import System.Environment (getArgs)
14+import Control.Monad.IO.Class (liftIO)
15+import Control.Monad (mzero)
16+
17+import BenchGraph
18+
19+------------------------------------------------------------------------------
20+-- Command line parsing
21+------------------------------------------------------------------------------
22+
23+data BenchType = Linear | LinearAsync | Nested | Base
24+
25+data Options = Options
26+ { genGraphs :: Bool
27+ , benchType :: BenchType
28+ }
29+
30+defaultOptions = Options False Linear
31+
32+setGenGraphs val = do
33+ (args, opts) <- get
34+ put (args, opts { genGraphs = val })
35+
36+setBenchType val = do
37+ (args, opts) <- get
38+ put (args, opts { benchType = val })
39+
40+-- Like the shell "shift" to shift the command line arguments
41+shift :: StateT ([String], Options) (MaybeT IO) (Maybe String)
42+shift = do
43+ s <- get
44+ case s of
45+ ([], _) -> return Nothing
46+ (x : xs, opts) -> put (xs, opts) >> return (Just x)
47+
48+parseBench :: StateT ([String], Options) (MaybeT IO) ()
49+parseBench = do
50+ x <- shift
51+ case x of
52+ Just "linear" -> setBenchType Linear
53+ Just "linear-async" -> setBenchType LinearAsync
54+ Just "nested" -> setBenchType Nested
55+ Just "base" -> setBenchType Base
56+ Just str -> do
57+ liftIO $ putStrLn $ "unrecognized benchmark type " ++ str
58+ mzero
59+ Nothing -> do
60+ liftIO $ putStrLn $ "please provide a benchmark type "
61+ mzero
62+
63+-- totally imperative style option parsing
64+parseOptions :: IO (Maybe Options)
65+parseOptions = do
66+ args <- getArgs
67+ runMaybeT $ flip evalStateT (args, defaultOptions) $ do
68+ x <- shift
69+ case x of
70+ Just "--graphs" -> setGenGraphs True
71+ Just "--benchmark" -> parseBench
72+ Just str -> do
73+ liftIO $ putStrLn $ "Unrecognized option " ++ str
74+ mzero
75+ Nothing -> return ()
76+ fmap snd get
77+
78+ignoringErr a = catch a (\(ErrorCall err :: ErrorCall) ->
79+ putStrLn $ "Failed with error:\n" ++ err ++ "\nSkipping.")
80+
81+------------------------------------------------------------------------------
82+-- Linear composition charts
83+------------------------------------------------------------------------------
84+
85+makeLinearGraphs :: Config -> String -> IO ()
86+makeLinearGraphs cfg inputFile = do
87+ ignoringErr $ graph inputFile "operations" $ cfg
88+ { title = Just "Streamly operations"
89+ , classifyBenchmark = \b ->
90+ if (not $ "serially/" `isPrefixOf` b)
91+ || "/generation" `isInfixOf` b
92+ || "/compose" `isInfixOf` b
93+ || "/concat" `isSuffixOf` b
94+ then Nothing
95+ else Just ("Streamly", last $ splitOn "/" b)
96+ }
97+
98+ ignoringErr $ graph inputFile "generation" $ cfg
99+ { title = Just "Stream generation"
100+ , classifyBenchmark = \b ->
101+ if "serially/generation" `isPrefixOf` b
102+ then Just ("Streamly", last $ splitOn "/" b)
103+ else Nothing
104+ }
105+
106+ ignoringErr $ graph inputFile "composition" $ cfg
107+ { title = Just "Streamly composition performance"
108+ , classifyBenchmark = fmap ("Streamly",) . stripPrefix "serially/compose/"
109+ }
110+
111+ ignoringErr $ graph inputFile "composition-scaling"
112+ $ cfg
113+ { title = Just "Streamly composition scaling"
114+ , classifyBenchmark = fmap ("Streamly",) . stripPrefix "serially/compose-"
115+ }
116+
117+------------------------------------------------------------------------------
118+-- Nested composition charts
119+------------------------------------------------------------------------------
120+
121+makeNestedGraphs :: Config -> String -> IO ()
122+makeNestedGraphs cfg inputFile = do
123+ ignoringErr $ graph inputFile "nested-serial-diff" $ cfg
124+ { title = Just "Nested serial"
125+ , classifyBenchmark = \b ->
126+ let ls = splitOn "/" b
127+ in case head ls of
128+ "serially" -> Just (head ls, last ls)
129+ _ -> Nothing
130+ }
131+
132+------------------------------------------------------------------------------
133+-- Charts for parallel streams
134+------------------------------------------------------------------------------
135+
136+makeLinearAsyncGraphs :: Config -> String -> IO ()
137+makeLinearAsyncGraphs cfg inputFile = do
138+ putStrLn "Not implemented"
139+ return ()
140+
141+------------------------------------------------------------------------------
142+-- Charts for base streams
143+------------------------------------------------------------------------------
144+
145+makeBaseGraphs :: Config -> String -> IO ()
146+makeBaseGraphs cfg inputFile = do
147+ putStrLn "Not implemented"
148+ return ()
149+
150+------------------------------------------------------------------------------
151+-- text reports
152+------------------------------------------------------------------------------
153+
154+benchShow Options{..} cfg func inp out =
155+ if genGraphs
156+ then func cfg {outputDir = Just out} inp
157+ else
158+ ignoringErr $ report inp Nothing $ cfg
159+ { selectBenchmarks =
160+ \f ->
161+ reverse $ map fst $
162+ sortBy (comparing snd) $ f $ ColumnIndex 1
163+ }
164+
165+main :: IO ()
166+main = do
167+ let cfg = defaultConfig { presentation = Groups PercentDiff }
168+ res <- parseOptions
169+
170+ case res of
171+ Nothing -> do
172+ putStrLn "cannot parse options"
173+ return ()
174+ Just opts@Options{..} -> do
175+ case benchType of
176+ Linear -> benchShow opts cfg makeLinearGraphs
177+ "charts/linear/results.csv"
178+ "charts/linear"
179+ LinearAsync -> benchShow opts cfg makeLinearAsyncGraphs
180+ "charts/linear-async/results.csv"
181+ "charts/linear-async"
182+ Nested -> benchShow opts cfg makeNestedGraphs
183+ "charts/nested/results.csv"
184+ "charts/nested"
185+ Base -> benchShow opts cfg makeBaseGraphs
186+ "charts/base/results.csv"
187+ "charts/base"