git.iko.soy/streamly
on 03218ad help sign in
streamly/benchmark/Chart.hs
194 lines 5.9 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 , benchType :: Maybe BenchType
29 , fields :: [String]
30 } deriving Show
32defaultOptions :: Options
33defaultOptions = Options False Nothing ["time"]
35setGenGraphs :: Monad m => Bool -> StateT (a, Options) m ()
36setGenGraphs val = do
37 (args, opts) <- get
38 put (args, opts { genGraphs = val })
40setBenchType :: Monad m => BenchType -> StateT (a, Options) m ()
41setBenchType val = do
42 (args, opts) <- get
43 put (args, opts { benchType = Just val })
45setFields :: Monad m => [String] -> StateT (a, Options) m ()
46setFields val = do
47 (args, opts) <- get
48 put (args, opts { fields = val })
50-- Like the shell "shift" to shift the command line arguments
51shift :: StateT ([String], Options) (MaybeT IO) (Maybe String)
52shift = do
53 s <- get
54 case s of
55 ([], _) -> return Nothing
56 (x : xs, opts) -> put (xs, opts) >> return (Just x)
58parseBench :: StateT ([String], Options) (MaybeT IO) ()
59parseBench = do
60 x <- shift
61 case x of
62 Just str | "_cmp" `isSuffixOf` str -> setBenchType (Compare str)
63 Just str -> setBenchType (Standard str)
64 Nothing -> do
65 liftIO $ putStrLn "please provide a benchmark type "
66 mzero
68parseFields :: StateT ([String], Options) (MaybeT IO) ()
69parseFields = do
70 x <- shift
71 case x of
72 Just str -> setFields (words str)
73 Nothing -> do
74 liftIO $ putStrLn
75 "please provide a list of fields after --fields"
76 mzero
78-- totally imperative style option parsing
79parseOptions :: IO (Maybe Options)
80parseOptions = do
81 args <- getArgs
82 runMaybeT $ flip evalStateT (args, defaultOptions) $ do
83 parseLoop
84 fmap snd get
86 where
88 parseOpt opt =
89 case opt of
90 "--graphs" -> setGenGraphs True
91 "--benchmark" -> parseBench
92 "--fields" -> parseFields
93 str -> do
94 liftIO $ putStrLn $ "Unrecognized option " <> str
95 mzero
97 parseLoop = do
98 next <- shift
99 case next of
100 Just opt -> parseOpt opt >> parseLoop
101 Nothing -> return ()
103ignoringErr :: IO () -> IO ()
104ignoringErr a = catch a (\(ErrorCall err :: ErrorCall) ->
105 putStrLn $ "Failed with error:\n" <> err <> "\nSkipping.")
107------------------------------------------------------------------------------
108-- Generic
109------------------------------------------------------------------------------
111makeGraphs :: String -> Config -> String -> IO ()
112makeGraphs name cfg@Config{..} inputFile =
113 ignoringErr $ graph inputFile name cfg
115------------------------------------------------------------------------------
116-- Arrays
117------------------------------------------------------------------------------
119showComparisons :: Options -> Config -> FilePath -> FilePath -> IO ()
120showComparisons Options{..} cfg inp out =
121 let cfg1 = cfg { classifyBenchmark = classifyComparison }
122 in if genGraphs
123 then ignoringErr $ graph inp "comparison"
124 cfg1 { outputDir = Just out
125 , presentation = Groups Absolute
126 }
127 else ignoringErr $ report inp Nothing cfg1
129 where
131 dropComponent = dropWhile (== '/') . dropWhile (/= '/')
133 classifyComparison b = Just
134 ( takeWhile (/= '/') b
135 , dropComponent b
136 )
138------------------------------------------------------------------------------
139-- text reports
140------------------------------------------------------------------------------
142selectBench
143 :: (SortColumn -> Maybe GroupStyle -> Either String [(String, Double)])
144 -> [String]
145selectBench f =
146 reverse
147 $ fmap fst
148 $ either
149 (const $ either error (sortOn snd) $ f (ColumnIndex 0) (Just PercentDiff))
150 (sortOn snd)
151 $ f (ColumnIndex 1) (Just PercentDiff)
153benchShow ::
154 Options
155 -> Config
156 -> (Config -> String -> IO ())
157 -> String
158 -> FilePath
159 -> IO ()
160benchShow Options{..} cfg func inp out =
161 if genGraphs
162 then func cfg {outputDir = Just out} inp
163 else ignoringErr $ report inp Nothing cfg
165main :: IO ()
166main = do
167 res <- parseOptions
168 case res of
169 Nothing -> do
170 putStrLn "cannot parse options"
171 return ()
172 Just opts@Options{fields = fs, benchType = btype} ->
173 let cfg = defaultConfig
174 { presentation = Groups PercentDiff
175 , selectBenchmarks = selectBench
176 , selectFields = filter
177 ( flip elem fs
178 . fmap toLower
179 )
180 }
181 in case btype of
182 Just (Compare str) ->
183 showComparisons opts cfg
184 { title = Just str }
185 ("charts/" ++ str ++ "/results.csv")
186 ("charts/" ++ str)
187 Just (Standard str) ->
188 benchShow opts cfg
189 { title = Just str }
190 (makeGraphs str)
191 ("charts/" ++ str ++ "/results.csv")
192 ("charts/" ++ str)
193 Nothing ->
194 error "Please specify a benchmark using --benchmark."