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

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

    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)