git.iko.soy/streamly
on a0386cb help sign in
streamly/benchmark/Chart.hs
206 lines 6.3 kB history raw
1{-# LANGUAGE RecordWildCards #-}
2{-# LANGUAGE ScopedTypeVariables #-}
4module Main where
6import Control.Exception (catch, ErrorCall(..))
7import Control.Monad.Trans.State
8import Control.Monad.Trans.Maybe
9import Data.Char (toLower)
10import Data.List
11import System.Environment (getArgs)
12import Control.Monad.IO.Class (liftIO)
13import Control.Monad (mzero)
15import BenchShow
17------------------------------------------------------------------------------
18-- Command line parsing
19------------------------------------------------------------------------------
21data BenchType
22 = Compare String
23 | Standard String
24 deriving Show
26data Options = Options
27 { genGraphs :: Bool
28 , sortByName :: Bool
29 , benchType :: Maybe BenchType
30 , fields :: [String]
31 } deriving Show
33defaultOptions :: Options
34defaultOptions = Options False False Nothing ["time"]
36setGenGraphs :: Monad m => Bool -> StateT (a, Options) m ()
37setGenGraphs val = do
38 (args, opts) <- get
39 put (args, opts { genGraphs = val })
41setSortByName :: Monad m => Bool -> StateT (a, Options) m ()
42setSortByName val = do
43 (args, opts) <- get
44 put (args, opts { sortByName = val })
46setBenchType :: Monad m => BenchType -> StateT (a, Options) m ()
47setBenchType val = do
48 (args, opts) <- get
49 put (args, opts { benchType = Just val })
51setFields :: Monad m => [String] -> StateT (a, Options) m ()
52setFields val = do
53 (args, opts) <- get
54 put (args, opts { fields = val })
56-- Like the shell "shift" to shift the command line arguments
57shift :: StateT ([String], Options) (MaybeT IO) (Maybe String)
58shift = do
59 s <- get
60 case s of
61 ([], _) -> return Nothing
62 (x : xs, opts) -> put (xs, opts) >> return (Just x)
64parseBench :: StateT ([String], Options) (MaybeT IO) ()
65parseBench = do
66 x <- shift
67 case x of
68 Just str | "_cmp" `isSuffixOf` str -> setBenchType (Compare str)
69 Just str -> setBenchType (Standard str)
70 Nothing -> do
71 liftIO $ putStrLn "please provide a benchmark type "
72 mzero
74parseFields :: StateT ([String], Options) (MaybeT IO) ()
75parseFields = do
76 x <- shift
77 case x of
78 Just str -> setFields (words str)
79 Nothing -> do
80 liftIO $ putStrLn
81 "please provide a list of fields after --fields"
82 mzero
84-- totally imperative style option parsing
85parseOptions :: IO (Maybe Options)
86parseOptions = do
87 args <- getArgs
88 runMaybeT $ flip evalStateT (args, defaultOptions) $ do
89 parseLoop
90 fmap snd get
92 where
94 parseOpt opt =
95 case opt of
96 "--graphs" -> setGenGraphs True
97 "--sort-by-name" -> setSortByName True
98 "--benchmark" -> parseBench
99 "--fields" -> parseFields
100 str -> do
101 liftIO $ putStrLn $ "Unrecognized option " <> str
102 mzero
104 parseLoop = do
105 next <- shift
106 case next of
107 Just opt -> parseOpt opt >> parseLoop
108 Nothing -> return ()
110ignoringErr :: IO () -> IO ()
111ignoringErr a = catch a (\(ErrorCall err :: ErrorCall) ->
112 putStrLn $ "Failed with error:\n" <> err <> "\nSkipping.")
114------------------------------------------------------------------------------
115-- Generic
116------------------------------------------------------------------------------
118makeGraphs :: String -> Config -> String -> IO ()
119makeGraphs name cfg@Config{..} inputFile =
120 ignoringErr $ graph inputFile name cfg
122------------------------------------------------------------------------------
123-- Arrays
124------------------------------------------------------------------------------
126showComparisons :: Options -> Config -> FilePath -> FilePath -> IO ()
127showComparisons Options{..} cfg inp out =
128 let cfg1 = cfg { classifyBenchmark = classifyComparison }
129 in if genGraphs
130 then ignoringErr $ graph inp "comparison"
131 cfg1 { outputDir = Just out
132 , presentation = Groups Absolute
133 }
134 else ignoringErr $ report inp Nothing cfg1
136 where
138 dropComponent = dropWhile (== '/') . dropWhile (/= '/')
140 classifyComparison b = Just
141 ( takeWhile (/= '/') b
142 , dropComponent b
143 )
145------------------------------------------------------------------------------
146-- text reports
147------------------------------------------------------------------------------
149selectBench
150 :: Bool
151 -> (SortColumn -> Maybe GroupStyle -> Either String [(String, Double)])
152 -> [String]
153selectBench sortName f =
154 reverse
155 $ fmap fst
156 $ either
157 (const $ either error sortFunc $ f (ColumnIndex 0) (Just PercentDiff))
158 sortFunc
159 $ f (ColumnIndex 1) (Just PercentDiff)
161 where
163 sortFunc = if sortName then sortOn fst else sortOn snd
165benchShow ::
166 Options
167 -> Config
168 -> (Config -> String -> IO ())
169 -> String
170 -> FilePath
171 -> IO ()
172benchShow Options{..} cfg func inp out =
173 if genGraphs
174 then func cfg {outputDir = Just out} inp
175 else ignoringErr $ report inp Nothing cfg
177main :: IO ()
178main = do
179 res <- parseOptions
180 case res of
181 Nothing -> do
182 putStrLn "cannot parse options"
183 return ()
184 Just opts@Options{fields = fs, benchType = btype} ->
185 let cfg = defaultConfig
186 { presentation = Groups PercentDiff
187 , selectBenchmarks = selectBench (sortByName opts)
188 , selectFields = filter
189 ( flip elem fs
190 . fmap toLower
191 )
192 }
193 in case btype of
194 Just (Compare str) ->
195 showComparisons opts cfg
196 { title = Just str }
197 ("charts/" ++ str ++ "/results.csv")
198 ("charts/" ++ str)
199 Just (Standard str) ->
200 benchShow opts cfg
201 { title = Just str }
202 (makeGraphs str)
203 ("charts/" ++ str ++ "/results.csv")
204 ("charts/" ++ str)
205 Nothing ->
206 error "Please specify a benchmark using --benchmark."