progression 0.1 → 0.2
raw patch · 5 files changed
+88/−43 lines, 5 files
Files
- Progression/Config.hs +40/−16
- Progression/Main.hs +7/−4
- Progression/Plot.hs +33/−20
- Progression/Prompt.hs +5/−2
- progression.cabal +3/−1
Progression/Config.hs view
@@ -31,28 +31,37 @@ -- 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(..), processArgs)- where+module Progression.Config (RunSettings(..), GraphSettings(..), Mode(..), Config(..),+ Definite(..), override, processArgs) where import Control.Monad ((>=>))+import Data.Char (isDigit) import Data.List (intercalate)+import Data.Maybe (fromMaybe) import Data.Monoid (Monoid(..)) import System.Console.GetOpt (OptDescr(..), ArgDescr(..), ArgOrder(..), getOpt, usageInfo) import System.Environment (getProgName) import System.Exit (ExitCode(..), exitWith) import System.IO (hPutStrLn, stderr) +import Progression.Prompt (splitOnCommas)+ -- | 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 } +-- | The identity functor+newtype Definite a = Definite { definite :: a }+ -- | 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).-data GraphSettings = GraphSettings { graphCompareTo :: [String]- , graphFilename :: Maybe String- --, graphSize :: Maybe (Int, Int)- }+data GraphSettings m = GraphSettings { graphCompareTo :: m [String]+ , graphFilename :: m String+ , graphSize :: m (Int, Int)+ , graphLogY :: m Bool+ , graphOrder :: m ([String] -> [String])+ } -- | The mode; just running and recording a benchmark, just graphing existing results, -- or running a benchmark and produce a graph (the default).@@ -60,7 +69,7 @@ deriving Eq -- | The mode (RunAndGraph, by default), the run settings and the graph settings.-data Config = Config {cfgMode :: Maybe Mode, cfgRun :: RunSettings, cfgGraph :: GraphSettings }+data Config = Config {cfgMode :: Maybe Mode, cfgRun :: RunSettings, cfgGraph :: GraphSettings Maybe } instance Monoid Config where mempty = Config Nothing mempty mempty@@ -70,11 +79,18 @@ mempty = RunSettings mempty mempty mappend (RunSettings p s) (RunSettings p' s') = RunSettings (p++p') (s||*s') -instance Monoid GraphSettings where- mempty = GraphSettings mempty mempty- mappend (GraphSettings c f) (GraphSettings c' f')- = GraphSettings (c++c') (f ||* f')+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') +-- 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')+ where+ a % b = Definite $ fromMaybe (definite a) b+ (||*) :: Maybe a -> Maybe a -> Maybe a x ||* Nothing = x _ ||* y = y@@ -98,8 +114,10 @@ "Compare the given comma-separated list of previous recordings (can be given multiple times). Automatically includes the current recording, if any" ,Option [] ["plot"] (ReqArg plot "FILENAME") "Store the plot as the given filename. The extension, if any, is used to set the gnuplot terminal type"--- ,Option [] ["plot-size"] (ReqArg plotSize "XxY")--- "Plot with the given size (e.g. 640x480)"+ ,Option [] ["plot-size"] (ReqArg plotSize "XxY")+ "Plot with the given size (e.g. 640x480)"+ ,Option [] ["plot-log-y"] (NoArg logY)+ "Plot with a logarithmic Y-axis" ,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 "h" ["help"] (NoArg help)@@ -108,11 +126,17 @@ where add :: (Monoid monoid, Monad monad) => monoid -> monoid -> monad monoid add x c = return $ c `mappend` x- prefix p = add $ mempty {cfgRun = mempty {runPrefixes = [p]} }+ prefix p = add $ mempty {cfgRun = mempty {runPrefixes = splitOnCommas p} } name n = add $ mempty {cfgRun = mempty { runStoreAs = Just n} }- compareTo c = add $ mempty {cfgGraph = mempty {graphCompareTo = [c]} }+ compareTo c = add $ mempty {cfgGraph = mempty {graphCompareTo = Just (splitOnCommas c)} } plot c = add $ mempty {cfgGraph = mempty {graphFilename = Just c} }--- plotSize c = undefined -- TODO add $ mempty {cfgGraph = mempty {graphSize = Just c} }+ plotSize c = do let (x, xrest) = span isDigit c+ case xrest of+ ('x': y) | not (null x) && not (null y) && all isDigit y ->+ let sz = (read x, read y)+ in add $ mempty {cfgGraph = mempty {graphSize = Just sz} }+ _ -> const $ Error $ "Malformed size: \"" ++ c ++ "\""+ logY = add $ mempty {cfgGraph = mempty {graphLogY = Just True}} mode "graph" = add $ mempty {cfgMode = Just JustGraph} mode "run" = add $ mempty {cfgMode = Just JustRun}
Progression/Main.hs view
@@ -36,6 +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.Monoid (Last(..), mempty) import qualified Data.Set as Set@@ -90,10 +91,12 @@ (return ()) [bench] g <- if not graphing then return Nothing else do- cmp <- optL (graphCompareTo . cfgGraph)- (promptManyComma "Compare to " compareChoices)- return $ Just $ plotMulti (fromMaybe "plot.png" $ graphFilename $ cfgGraph cfg)- (maybe cmp (:cmp) name)+ cmp <- opt (graphCompareTo . cfgGraph)+ (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 mrun r mrun g where
Progression/Plot.hs view
@@ -30,39 +30,43 @@ module Progression.Plot (plotMulti) where import Control.Applicative (Applicative(..), (<$>))-import Control.Monad (ap, forM, liftM)+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(..)) import System.FilePath (dropExtension, takeExtension, (<.>)) import System.IO (hPutStrLn, stderr) +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 :: FilePath -> (Integer, FilePath) -> [String] -> IO ()-plotFile destFile (numBench, csvFile) names = check =<< rawSystem "gnuplot" ("-e" :+plotFile :: GraphSettings Definite -> ([String], FilePath) -> IO ()+plotFile settings (benchNames, csvFile) = check =<< rawSystem "gnuplot" ("-e" : [concat- ["set terminal " ++ terminalType ++ " size 1024,768;"- ,"set output '", destFile, "';"+ ["set terminal " ++ terminalType ++ " size " ++ sizeX ++ "," ++ sizeY ++ ";"+ ,"set output '", get graphFilename, "';" ,"set xtics rotate;" ,"set xrange [-" ++ show (makeOffset 1) ++ ":"- ++ show (fromInteger (numBench - 1) + makeOffset (toInteger $ length names)) ++ "];"- ,"set bmargin 20;"+ ++ 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..] names]+ | (i, n) <- zip [0..] (get graphCompareTo)] ] ]) where- terminalType = case takeExtension destFile of+ terminalType = case takeExtension $ get graphFilename of "" -> "png" (_:ext) -> ext @@ -72,14 +76,20 @@ makeOffset :: Integer -> Double makeOffset i = (fromInteger i :: Double) / 8 + (sizeX, sizeY) = show *** show $ get graphSize++ get f = definite (f settings)+ -- | Plots to the given destination file (using its extension as the terminal type), -- the given list of labels.-plotMulti :: FilePath -> [String] -> IO ()-plotMulti destFile names- = do count <- joinMulti csvFile (map makeFileName names)- plotFile destFile (count, csvFile) names+plotMulti :: GraphSettings Definite -> IO ()+plotMulti settings+ = do benchmarks <- joinMulti (get graphOrder) csvFile (map makeFileName $ get graphCompareTo)+ when (not $ null benchmarks) $+ plotFile settings (benchmarks, csvFile) where- csvFile = dropExtension destFile <.> "csv"+ csvFile = dropExtension (get graphFilename) <.> "csv"+ get f = definite (f settings) -- I know this is really Either String; long story data FailM a = Fail String | Fine a@@ -101,17 +111,17 @@ -- 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 :: FilePath -> [FilePath] -> IO Integer-joinMulti _ [] = return 0-joinMulti dest allFiles+joinMulti :: ([String] -> [String]) -> FilePath -> [FilePath] -> IO [String]+joinMulti _ _ [] = return []+joinMulti sortFunc dest allFiles = do allData <- sequence [parseTable csvFormat <$> readFile path | path <- allFiles] case mapM tableToMap allData of- Fail err -> hPutStrLn stderr err >> return 0+ 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 (toInteger $ Map.size m)+ return (Map.keys m) where headTail :: [a] -> FailM (a, [a]) headTail [] = Fail "Empty file"@@ -138,9 +148,12 @@ (r ! meanLBIndex) <*> (r ! meanIndex) <*> (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 . Map.toList+ mapToTable = map itemToRow . mapToList where itemToRow :: (String, [BoundedMean]) -> [String] itemToRow (n, ms) = n : concatMap meanToStr ms
Progression/Prompt.hs view
@@ -27,7 +27,7 @@ -- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- | A module containing helper functions for the interactive prompts.-module Progression.Prompt (promptOne, promptManyComma) where+module Progression.Prompt (promptOne, promptManyComma, splitOnCommas) where import Control.Applicative ((<$>)) import Data.List (isPrefixOf, unfoldr)@@ -55,7 +55,10 @@ -- each be trimmed of leading and trailing spaces, and the whole list will have -- empty items removed. promptManyComma :: String -> [String] -> IO [String]-promptManyComma = ((<$>) (filter (not . null) . map trim . unfoldr splitFirstComma) .) . promptOne+promptManyComma = ((<$>) (filter (not . null) . map trim . splitOnCommas) .) . promptOne++splitOnCommas :: String -> [String]+splitOnCommas = unfoldr splitFirstComma where splitFirstComma :: String -> Maybe (String, String) splitFirstComma [] = Nothing
progression.cabal view
@@ -1,5 +1,5 @@ name: progression-version: 0.1+version: 0.2 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@@ -30,5 +30,7 @@ Progression.Plot other-modules: Progression.Prompt++extensions: FlexibleInstances ghc-options: -Wall