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, 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)
import System.Environment (getProgName)
import System.Exit (ExitCode(..), exitWith)
import System.IO (hPutStrLn, stderr)
import Progression.Prompt (splitOnCommas)
data BoundedMean = BoundedMean { meanLB :: Double, mean :: Double, meanUB :: Double }
data RunSettings = RunSettings { runPrefixes :: [String], runStoreAs :: Maybe String }
newtype Definite a = Definite { definite :: a }
newtype GroupName = GroupName { groupName :: String }
newtype SubGroupName = SubGroupName { subGroupName :: String }
data GraphData = GraphData {groupLabels :: [GroupName], subGroupLabels :: [SubGroupName], graphData :: GroupName -> SubGroupName -> BoundedMean}
data GraphType = GraphTypeLines | GraphTypeBars
type GraphDataMapping = String -> Map.Map String (Map.Map String BoundedMean) -> GraphData
data GraphSettings m = GraphSettings { graphCompareTo :: m [String]
, graphFilename :: m String
, graphSize :: m (Int, Int)
, graphLogY :: m Bool
, graphType :: m GraphType
, graphGroup :: m GraphDataMapping
}
data Mode = JustRun | RunAndGraph | JustGraph
deriving Eq
data Config = Config {cfgMode :: Maybe Mode, cfgRun :: RunSettings, cfgGraph :: GraphSettings Maybe }
instance Monoid Config where
mempty = Config Nothing mempty mempty
mappend (Config m r g) (Config m' r' g') = Config (m||*m') (mappend r r') (mappend g g')
instance Monoid RunSettings where
mempty = RunSettings mempty mempty
mappend (RunSettings p s) (RunSettings p' s') = RunSettings (p++p') (s||*s')
instance Monoid (GraphSettings Maybe) where
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')
override :: GraphSettings Definite -> GraphSettings Maybe -> GraphSettings Definite
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
(||*) :: Maybe a -> Maybe a -> Maybe a
x ||* Nothing = x
_ ||* y = y
toTop :: Eq a => a -> [a] -> [a]
toTop x = uncurry (++) . partition (== x)
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))
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))
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
fail = Error
return = Result
ShowHelp >>= _ = ShowHelp
(Error e) >>= _ = Error e
(Result x) >>= f = f x
options :: [OptDescr (Config -> OptM Config)]
options = [Option "p" ["prefixes"] (ReqArg prefix "PREFIX")
"Run the specified comma-separated list of prefixes (can be given multiple times)"
,Option "n" ["name"] (ReqArg name "NAME")
"Store the results with the specified name"
,Option "c" ["compare"] (ReqArg compareTo "COMPARISON")
"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-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"
]
where
add :: (Monoid monoid, Monad monad) => monoid -> monoid -> monad monoid
add x c = return $ c `mappend` x
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 = Just (splitOnCommas c)} }
plot c = add $ mempty {cfgGraph = mempty {graphFilename = 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}
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 ++ "\""
help = const ShowHelp
processArgs :: Config -> [String] -> IO Config
processArgs defaultConfig ourArgs
= let (cfgFuncs, nonOpt, otherErr) = getOpt Permute options ourArgs
cfgResult = foldl (>=>) return cfgFuncs $ defaultConfig
in case (cfgResult, not $ null $ nonOpt, not $ null $ otherErr) of
(Error err, _, _) -> exitErr $ err ++ intercalate "," otherErr
(_, _, True) -> exitErr $ intercalate "," otherErr
(_, True, _) -> exitErr $ "Unrecognised options: " ++ intercalate "," nonOpt
(ShowHelp, _, _) -> do progName <- getProgName
putStrLn $ usageInfo (progName ++ " [PROGRESSION-ARGS [-- CRITERION-ARGS]]") options
exitWith ExitSuccess
(Result cfg, False, False) -> return cfg
where
exitErr e = hPutStrLn stderr e >> exitWith (ExitFailure 1)