progression-0.1: Progression/Config.hs

-- Progression.
-- Copyright (c) 2010, Neil Brown.
-- All rights reserved.
-- 
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions are
-- met:
--
--  * Redistributions of source code must retain the above copyright
--    notice, this list of conditions and the following disclaimer.
--  * Redistributions in binary form must reproduce the above copyright
--    notice, this list of conditions and the following disclaimer in the
--    documentation and/or other materials provided with the distribution.
--  * The name of Neil Brown may not be used to endorse or promote products derived from
--    this software without specific prior written permission.
--
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
-- THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
-- PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR
-- CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

-- | A module exposing the configuration for progression.
--
-- 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

import Control.Monad ((>=>))
import Data.List (intercalate)
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)

-- | 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 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)
                                   }

-- | The mode; just running and recording a benchmark, just graphing existing results,
-- or running a benchmark and produce a graph (the default).
data Mode = JustRun | RunAndGraph | JustGraph
  deriving Eq

-- | The mode (RunAndGraph, by default), the run settings and the graph settings.
data Config = Config {cfgMode :: Maybe Mode, cfgRun :: RunSettings, cfgGraph :: GraphSettings }

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 where
  mempty = GraphSettings mempty mempty
  mappend (GraphSettings c f) (GraphSettings c' f')
    = GraphSettings (c++c') (f ||* f')

(||*) :: Maybe a -> Maybe a -> Maybe a
x ||* Nothing = x
_ ||* y = y

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 "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)
              "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 = [p]} }
    name n = add $ mempty {cfgRun = mempty { runStoreAs = Just n} }
    compareTo c = add $ mempty {cfgGraph = mempty {graphCompareTo = [c]} }
    plot c = add $ mempty {cfgGraph = mempty {graphFilename = Just c} }
--    plotSize c = undefined -- TODO add $ mempty {cfgGraph = mempty {graphSize = Just c} }

    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 ++ "\""

    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).
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)