progression 0.2 → 0.3
raw patch · 4 files changed
+169/−65 lines, 4 files
Files
- Progression/Config.hs +108/−10
- Progression/Main.hs +3/−4
- Progression/Plot.hs +55/−49
- progression.cabal +3/−2
Progression/Config.hs view
@@ -31,12 +31,15 @@ -- Each item is either a Maybe type or a list. The values Nothing or the empty -- list indicate a lack of preference and will be over-ridden by the other setting -- in an mappend; settings can be joined together using their monoid instances.-module Progression.Config (RunSettings(..), GraphSettings(..), Mode(..), Config(..),- Definite(..), override, processArgs) where+module Progression.Config (BoundedMean(..), RunSettings(..), GraphSettings(..), GroupName(..),+ SubGroupName(..), GraphData(..), GraphDataMapping, GraphType(..), Mode(..), Config(..),+ Definite(..), groupBench, groupVersion, normalise, override, processArgs) where +import Control.Arrow ((&&&)) import Control.Monad ((>=>)) import Data.Char (isDigit)-import Data.List (intercalate)+import Data.List (intercalate, partition)+import qualified Data.Map as Map (Map, elems, differenceWith, intersection, keys, lookup, map, null) import Data.Maybe (fromMaybe) import Data.Monoid (Monoid(..)) import System.Console.GetOpt (OptDescr(..), ArgDescr(..), ArgOrder(..), getOpt, usageInfo)@@ -46,6 +49,9 @@ import Progression.Prompt (splitOnCommas) +-- | A type that holds the value for a mean with bounds.+data BoundedMean = BoundedMean { meanLB :: Double, mean :: Double, meanUB :: Double }+ -- | The settings for running benchmarks; which prefixes to run (empty list means -- no preference, i.e. all -- not none) and where to put the result. data RunSettings = RunSettings { runPrefixes :: [String], runStoreAs :: Maybe String }@@ -53,6 +59,42 @@ -- | The identity functor newtype Definite a = Definite { definite :: a } +-- | The name of a particular group on the x-axis; depending on your choice, this+-- could be a benchmark name or a version name.+newtype GroupName = GroupName { groupName :: String }++-- | The name of a particular element of a group (for line graphs this is the name+-- of the line; for bar charts this is a particular recurring bar colour).+newtype SubGroupName = SubGroupName { subGroupName :: String }++-- | Some data that is ready to graph. There are the group labels (groups on the+-- x-axis) which will be plotted in the order given in the list, sub-group labels+-- (either bar colours or lines), and a function that gets the data for a given+-- group label and sub-group label.+--+-- It is expected that 'graphData' will only ever be called with combinations of+-- the labels in the attached lists, but that it should return a sensible (i.e.+-- non-bottom) value in all these cases.+data GraphData = GraphData {groupLabels :: [GroupName], subGroupLabels :: [SubGroupName], graphData :: GroupName -> SubGroupName -> BoundedMean}++-- | The type of a graph; lines or bars+data GraphType = GraphTypeLines | GraphTypeBars++-- | A function for mapping raw data (i.e. read from CSV files) into data arranged+-- for plotting.+--+-- The first parameter is the name of the version most recently recorded, or+-- (if just graphing is taking place) the name of the first version listed by the+-- user.+--+-- The second parameter is a map from version name (e.g. fused-memo) to: a map from benchmark name+-- (e.g. calculate-primes) to the recorded mean.+--+-- The return is the arranged 'GraphData'.+--+-- The default is a composition of 'groupBench' and 'normalise'.+type GraphDataMapping = String -> Map.Map String (Map.Map String BoundedMean) -> GraphData+ -- | The settings for plotting graphs; which labels (besides the one created by -- the current run, if applicable) to feature in the graph, and where to store -- the file (plot.png, by default).@@ -60,7 +102,8 @@ , graphFilename :: m String , graphSize :: m (Int, Int) , graphLogY :: m Bool- , graphOrder :: m ([String] -> [String])+ , graphType :: m GraphType+ , graphGroup :: m GraphDataMapping } -- | The mode; just running and recording a benchmark, just graphing existing results,@@ -80,14 +123,14 @@ mappend (RunSettings p s) (RunSettings p' s') = RunSettings (p++p') (s||*s') instance Monoid (GraphSettings Maybe) where- mempty = GraphSettings mempty Nothing Nothing Nothing Nothing- mappend (GraphSettings c f sz l srt) (GraphSettings c' f' sz' l' srt')- = GraphSettings (c `mappend` c') (f ||* f') (sz ||* sz') (l ||* l') (srt ||* srt')+ mempty = GraphSettings mempty Nothing Nothing Nothing Nothing Nothing+ mappend (GraphSettings c f sz l t srt) (GraphSettings c' f' sz' l' t' srt')+ = GraphSettings (c `mappend` c') (f ||* f') (sz ||* sz') (l ||* l') (t ||* t') (srt ||* srt') -- Over-rides the LHS with the RHS (if non-Nothing) override :: GraphSettings Definite -> GraphSettings Maybe -> GraphSettings Definite-override (GraphSettings c f sz l srt) (GraphSettings c' f' sz' l' srt')- = GraphSettings (c % c') (f % f') (sz % sz') (l % l') (srt % srt')+override (GraphSettings c f sz l t srt) (GraphSettings c' f' sz' l' t' srt')+ = GraphSettings (c % c') (f % f') (sz % sz') (l % l') (t % t') (srt % srt') where a % b = Definite $ fromMaybe (definite a) b @@ -95,6 +138,43 @@ x ||* Nothing = x _ ||* y = y +-- Brings the specified element to the front of the list+toTop :: Eq a => a -> [a] -> [a]+toTop x = uncurry (++) . partition (== x)++-- | A function that turns versions into major groups, benchmarks into sub-groups,+-- and brings the name of the latest version to the head of the group list.+groupVersion :: GraphDataMapping+groupVersion n m+ | Map.null m = GraphData [] [] (const $ const $ BoundedMean 0 0 0)+ | otherwise = GraphData (map GroupName $ toTop n $ Map.keys m) (map SubGroupName $ Map.keys $ foldl1 Map.intersection $ Map.elems m)+ (\(GroupName x) (SubGroupName y) -> fromMaybe (error "defaultGroup: Unknown version") $+ Map.lookup y (fromMaybe (error "defaultGroup: Unknown benchmark") $ Map.lookup x m))++-- | A function that turns benchmarks into major groups, versions into sub-groups,+-- and brings the name of the latest version to the head of the sub-group list.+groupBench :: GraphDataMapping+groupBench n m+ | Map.null m = GraphData [] [] (const $ const $ BoundedMean 0 0 0)+ | otherwise = GraphData (map GroupName $ Map.keys $ foldl1 Map.intersection $ Map.elems m) (map SubGroupName $ toTop n $ Map.keys m) + (\(GroupName x) (SubGroupName y) -> fromMaybe (error "defaultGroup: Unknown version") $+ Map.lookup x (fromMaybe (error "defaultGroup: Unknown benchmark") $ Map.lookup y m))+++-- | A function that normalises the given data (second parameter) by dividing by the time taken by+-- the given version (first parameter). Benchmarks where the divisor is zero or+-- missing have their times left untouched.+--+-- This is intended to be applied before 'groupBench' or 'groupVersion'.+normalise :: String -> Map.Map String (Map.Map String BoundedMean) -> Map.Map String (Map.Map String BoundedMean)+normalise baseName vals = Map.map (flip (Map.differenceWith normaliseTo) standard) vals+ where+ standard = fromMaybe (error "normalise: base not found") $ Map.lookup baseName vals++ normaliseTo (BoundedMean lb m ub) (BoundedMean _ n _)+ | n == 0 = Just $ BoundedMean lb m ub+ | otherwise = Just $ BoundedMean (lb / n) (m / n) (ub / n)+ data OptM a = ShowHelp | Error String | Result a instance Monad OptM where@@ -118,8 +198,12 @@ "Plot with the given size (e.g. 640x480)" ,Option [] ["plot-log-y"] (NoArg logY) "Plot with a logarithmic Y-axis"+ ,Option "t" ["plot-type"] (ReqArg plotType "TYPE")+ "Draw the plot using \"bars\" (default) or \"lines\"" ,Option "m" ["mode"] (ReqArg mode "MODE") "Specify \"graph\" to just draw a graph, \"run\" to just run the benchmark, or \"normal\" (the default) to do both"+ ,Option "g" ["group"] (ReqArg groupUsing "GROUP")+ "Groups the benchmarks; \"normal-bench\" (the default) for grouping by benchmark and normalising, \"bench\", \"normal-version\", \"version\" for grouping by version" ,Option "h" ["help"] (NoArg help) "Display this help message" ]@@ -143,12 +227,26 @@ mode "normal" = add $ mempty {cfgMode = Just RunAndGraph} mode m = const $ Error $ "Invalid mode setting: \"" ++ m ++ "\"" + groupUsing "normal-bench" = add $ mempty {cfgGraph = mempty {graphGroup = Just $ groupBench `after` normalise } }+ groupUsing "bench" = add $ mempty {cfgGraph = mempty {graphGroup = Just $ groupBench } }+ groupUsing "normal-version" = add $ mempty {cfgGraph = mempty {graphGroup = Just $ groupVersion `after` normalise } }+ groupUsing "version" = add $ mempty {cfgGraph = mempty {graphGroup = Just $ groupVersion } }+ groupUsing g = const $ Error $ "Invalid group setting: \"" ++ g ++ "\""++ f `after` g = uncurry (.) . (f &&& g)++ plotType "bars" = add $ mempty {cfgGraph = mempty {graphType = Just GraphTypeBars} }+ plotType "lines" = add $ mempty {cfgGraph = mempty {graphType = Just GraphTypeLines} }+ plotType t = const $ Error $ "Invalid plot type setting: \"" ++ t ++ "\""++ --TODO refactor the above three functions into lookup-lists+ help = const ShowHelp -- | Processes the given arguments (got from getArgs, typically) to adjust the -- given default configuration, returning the resulting configuration. Exits the -- whole program with an error if there is a problem, or if the user specified--- "-h" (in which case it exits after printing the options).+-- @-h@ (in which case it exits after printing the options). processArgs :: Config -> [String] -> IO Config processArgs defaultConfig ourArgs = let (cfgFuncs, nonOpt, otherErr) = getOpt Permute options ourArgs
Progression/Main.hs view
@@ -36,8 +36,7 @@ import qualified Criterion.Config as CriterionConfig (Config(..), defaultConfig) import qualified Criterion.Main as Criterion (defaultMainWith) import Criterion.Types (Benchmark(..))-import Data.List (sort)-import Data.Maybe (fromMaybe)+import Data.Maybe (fromMaybe, listToMaybe) import Data.Monoid (Last(..), mempty) import qualified Data.Set as Set import System.Environment (getArgs, withArgs)@@ -95,8 +94,8 @@ (promptManyComma "Compare to " compareChoices) let d = Definite defaultGraph = GraphSettings (d $ maybe cmp (:cmp) name)- (d "plot.png") (d (1024, 768)) (d False) (d sort)- return $ Just $ plotMulti $ defaultGraph `override` cfgGraph cfg+ (d "plot.png") (d (1024, 768)) (d False) (d GraphTypeBars) (d $ \m -> groupBench m . normalise m)+ return $ Just $ plotMulti (fromMaybe (fromMaybe (error "Compare list is empty") $ listToMaybe cmp) name) $ defaultGraph `override` cfgGraph cfg mrun r mrun g where
Progression/Plot.hs view
@@ -30,11 +30,10 @@ module Progression.Plot (plotMulti) where import Control.Applicative (Applicative(..), (<$>))-import Control.Arrow ((***))+import Control.Arrow ((***), (&&&)) import Control.Monad (ap, forM, liftM, when) import Data.List (findIndex, intercalate) import qualified Data.Map as Map-import Data.Maybe (mapMaybe) import Database.TxtSushi.FlatFile (csvFormat, formatTable, parseTable) import System.Cmd (rawSystem) import System.Exit (ExitCode(..))@@ -44,49 +43,60 @@ import Progression.Config import Progression.Files -data BoundedMean = BoundedMean { _meanLB :: String, _mean :: String, _meanUB :: String }- -- | Plots to the given destination file (using its extension as the terminal type), -- from the given CSV file, using the given list as labels.-plotFile :: GraphSettings Definite -> ([String], FilePath) -> IO ()-plotFile settings (benchNames, csvFile) = check =<< rawSystem "gnuplot" ("-e" :- [concat- ["set terminal " ++ terminalType ++ " size " ++ sizeX ++ "," ++ sizeY ++ ";"- ,"set output '", get graphFilename, "';"- ,"set xtics rotate;"- ,"set xrange [-" ++ show (makeOffset 1) ++ ":"- ++ show (fromIntegral (length benchNames - 1) + makeOffset (toInteger $ length $ get graphCompareTo)) ++ "];"- ,"set bmargin " ++ show ((maximum (map length benchNames) * 2) `div` 3) ++ ";"- ,if get graphLogY then "set logscale y;" else ""- ,"set datafile separator ',';"- ,"plot " ++ intercalate ","- [let indices = map show [i*3 + 2, i*3 + 3, i*3 + 4]- in "'" ++ csvFile ++ "' using ($0+" ++ show (makeOffset i) ++ "):" ++ intercalate ":" indices ++ ":xtic(1) with errorlines title '" ++ n ++ "'"- | (i, n) <- zip [0..] (get graphCompareTo)]- ]- ])+plotFile :: GraphSettings Definite -> (([String], [String]), FilePath) -> IO ()+plotFile settings ((rowNames, colNames), csvFile) = check =<< rawSystem "gnuplot" ("-e" : [concat cmd]) where+ cmd =+ ["set terminal " ++ terminalType ++ " size " ++ sizeX ++ "," ++ sizeY ++ ";"+ ,"set output '" ++ get graphFilename ++ "';"+ ,"set xtics rotate;"+ ,"set xrange [-" ++ show (makeOffset 1) ++ ":"+ ++ show (fromIntegral (length rowNames - 1) + makeOffset (toInteger $ length colNames)) ++ "];"+ ,"set bmargin " ++ show ((maximum (map length rowNames) * 2) `div` 3) ++ ";"+ ,if get graphLogY then "set logscale y;" else ""+ ,"set datafile separator ',';"+ ,"set style data " ++ style ++ ";" ++ otherStyle+ ,"plot " ++ intercalate ","+ [let indices = map show [i*3 + 2, i*3 + 3, i*3 + 4]+ indicesAndExtra = case get graphType of+ GraphTypeLines -> indices+ GraphTypeBars -> indices ++ ["(" ++ show (makeOffset 1) ++ ")"]+ in "'" ++ csvFile ++ "' using ($0+" ++ show (makeOffset i) ++ "):" ++ intercalate ":" indicesAndExtra ++ ":xtic(1) title '" ++ n ++ "'"+ | (i, n) <- zip [0..] colNames]+ ]+ terminalType = case takeExtension $ get graphFilename of "" -> "png" (_:ext) -> ext - check ExitSuccess = return ()+ check ExitSuccess = do hPutStrLn stderr "Executed gnuplot commands: "+ mapM_ (hPutStrLn stderr . (" " ++)) cmd check (ExitFailure _) = hPutStrLn stderr "Error executing gnuplot; have you got gnuplot installed on your system and in your path?" makeOffset :: Integer -> Double- makeOffset i = (fromInteger i :: Double) / 8+ makeOffset i = (fromInteger i :: Double) / (max 8 (fromIntegral $ length colNames + 1)) (sizeX, sizeY) = show *** show $ get graphSize get f = definite (f settings) + style = case get graphType of+ GraphTypeLines -> "errorlines"+ GraphTypeBars -> "boxerrorbars"+ otherStyle = case get graphType of+ GraphTypeLines -> ""+ GraphTypeBars -> "set style fill pattern;"+ -- | Plots to the given destination file (using its extension as the terminal type),--- the given list of labels.-plotMulti :: GraphSettings Definite -> IO ()-plotMulti settings- = do benchmarks <- joinMulti (get graphOrder) csvFile (map makeFileName $ get graphCompareTo)- when (not $ null benchmarks) $- plotFile settings (benchmarks, csvFile)+-- the given list of labels in the settings. The first parameter is the one passed+-- to the 'graphData' function (the most recent benchmark).+plotMulti :: String -> GraphSettings Definite -> IO ()+plotMulti orig settings+ = do rowColumns <- joinMulti (get graphGroup $ orig) csvFile (map (id &&& makeFileName) $ get graphCompareTo)+ when (uncurry (&&) . ((not . null) *** (not . null)) $ rowColumns) $+ plotFile settings (rowColumns, csvFile) where csvFile = dropExtension (get graphFilename) <.> "csv" get f = definite (f settings)@@ -110,18 +120,19 @@ -- | Joins all the result files in the list into the given destination file ready -- to be fed to plotFile. If the list is empty, nothing is done. ----- It returns the number of benchmarks that are in the resulting file-joinMulti :: ([String] -> [String]) -> FilePath -> [FilePath] -> IO [String]-joinMulti _ _ [] = return []-joinMulti sortFunc dest allFiles- = do allData <- sequence [parseTable csvFormat <$> readFile path | path <- allFiles]+-- It returns lists of row and column labels for the resulting file+joinMulti :: (Map.Map String (Map.Map String BoundedMean)+ -> GraphData)+ -> FilePath -> [(String, FilePath)] -> IO ([String], [String])+joinMulti _ _ [] = return ([], [])+joinMulti groupFunc dest allFiles+ = do allData <- sequence [parseTable csvFormat <$> readFile path | (_, path) <- allFiles] case mapM tableToMap allData of- Fail err -> hPutStrLn stderr err >> return []+ Fail err -> hPutStrLn stderr err >> return ([], []) -- ms must be non-empty, because "allFiles" was non-empty:- Fine ms -> let m = foldl1 (Map.intersectionWith (++)) $- map (Map.map (:[])) ms- in do writeFile dest $ formatTable csvFormat (mapToTable m)- return (Map.keys m)+ Fine ms -> let gd = groupFunc $ Map.fromList $ zip (map fst allFiles) ms+ in do writeFile dest $ formatTable csvFormat (mapToTable gd)+ return ((map groupName . groupLabels) &&& (map subGroupName . subGroupLabels) $ gd) where headTail :: [a] -> FailM (a, [a]) headTail [] = Fail "Empty file"@@ -145,18 +156,13 @@ Map.fromList <$> forM body (\r -> (,) <$> (r ! nameIndex) <*> (BoundedMean <$>- (r ! meanLBIndex) <*> (r ! meanIndex) <*> (r ! meanUBIndex))+ (read <$> r ! meanLBIndex) <*> (read <$> r ! meanIndex) <*> (read <$> r ! meanUBIndex)) ) - mapToList :: Map.Map String a -> [(String, a)]- mapToList m = mapMaybe (\k -> (,) k <$> Map.lookup k m) $ sortFunc $ Map.keys m- -- No header at the moment:- mapToTable :: Map.Map String [BoundedMean] -> [[String]]- mapToTable = map itemToRow . mapToList+ mapToTable :: GraphData -> [[String]]+ mapToTable gd = [ groupName x : concatMap (meanToStr . graphData gd x) (subGroupLabels gd)+ | x <- groupLabels gd] where- itemToRow :: (String, [BoundedMean]) -> [String]- itemToRow (n, ms) = n : concatMap meanToStr ms- meanToStr :: BoundedMean -> [String]- meanToStr (BoundedMean lb m ub) = [m, lb, ub]+ meanToStr (BoundedMean lb m ub) = map show [m, lb, ub]
progression.cabal view
@@ -1,12 +1,13 @@ name: progression-version: 0.2+version: 0.3 synopsis: Automates the recording and graphing of criterion benchmarks description: Progression is a library that builds on the criterion benchmarking library. It stores the results of running your benchmarks and graphs the performance of different versions of your program against each other. See the "Progression.Main" module, and the original blog post at- <http://chplib.wordpress.com/2010/02/04/progression-supporting-optimisation-in-haskell/> to get started.+ <http://chplib.wordpress.com/2010/02/04/progression-supporting-optimisation-in-haskell/>+ to get started, as well as the later post <http://chplib.wordpress.com/2010/03/02/progression-0-3-bar-charts-and-normalisation/>. homepage: http://chplib.wordpress.com/2010/02/04/progression-supporting-optimisation-in-haskell/ category: Development license: BSD3