content: {-# LANGUAGE CPP, FlexibleContexts#-}
  module Tools.TimePlot.Conf (
      ConcreteConf(..),
      Conf,
      readConf
  ) where
  
  import Text.Regex.TDFA
  import Text.Regex.TDFA.ByteString
  import Data.Time hiding (parseTime)
  import Data.Time.Parse
  import Data.List
  import Graphics.Rendering.Chart
  import qualified Data.ByteString.Char8 as S
  import Data.ByteString.Lex.Fractional
  
  import Unsafe.Coerce
  
  import Tools.TimePlot.Types
  
  data ConcreteConf t =
    ConcreteConf {
      inFile        :: !FilePath,
      parseTime     :: !(S.ByteString -> Maybe (t, S.ByteString)),
      -- Input track -> (chart kind, suffix to append to track name for N:1 out:in mapping)
      chartKindF    :: !(S.ByteString -> [(ChartKind t, S.ByteString)]),
  
      fromTime      :: !(Maybe t),
      toTime        :: !(Maybe t),
      transformLabel :: !(t -> String -> String),
  
      outFile       :: !FilePath,
      outFormat     :: !OutFormat,
      outResolution :: !(Int,Int)
    }
  
  type Conf = ConcreteConf LocalTime
  
  data KindChoiceOperator = Cut | Accumulate
  
  readConf :: [String] -> Conf
  readConf args = readConf' parseTime 
    where
      pattern = case (words $ single "time format" "-tf" ("%Y-%m-%d %H:%M:%OS")) of
          "date":f -> S.pack (unwords f)
          f        -> S.pack (unwords f)
      Just (ourBaseTime,_) = strptime "%Y-%m-%d %H:%M:%OS" "1900-01-01 00:00:00" 
      {-# NOINLINE ourStrptime #-}
      ourStrptime :: S.ByteString -> Maybe (LocalTime, S.ByteString)
      ourStrptime = if pattern == S.pack "elapsed" 
                      then \s -> do
                        (d, s') <- readSigned readDecimal s
                        return (fromSeconds d ourBaseTime `add` ourBaseTime, s')
                      else strptime pattern
      parseTime s = ourStrptime s
  
      int2double = fromIntegral :: Int -> Double
      single desc name def = case (getArg name 1 args) of
        [[r]] -> r
        []    -> def
        _     -> error $ "Single argument expected for: "++desc++" ("++name++")"
  
      readConf' :: (S.ByteString -> Maybe (LocalTime, S.ByteString)) -> ConcreteConf LocalTime
      readConf' parseTime = ConcreteConf {inFile=inFile, outFile=outFile, outFormat=outFormat, outResolution=outRes,
                        chartKindF=chartKindF, parseTime=parseTime, fromTime=fromTime, toTime=toTime,
                        transformLabel=transformLabel}
        where
          inFile      = single "input file"  "-if" (error "No input file (-if) specified")
          outFile     = single "output file" "-o"  (error "No output file (-o) specified")
          outFormat   = maybe OutPNG id $ lookup (single "output format" "-of" (name2format outFile)) $
              [("png",OutPNG), ("pdf",OutPDF), ("ps",OutPS), ("svg",OutSVG)]
            where
              name2format = reverse . takeWhile (/='.') . reverse
          outRes      = parseRes $ single "output resolution" "-or" "640x480"
            where
              parseRes s = case break (=='x') s of (h,_:v) -> (read h,read v)
          forceList :: [a] -> ()
          forceList = foldr seq ()
          chartKindF  = forceList [forceList plusKinds, forceList minusKinds, forceList defaultKindsPlus, defaultKindMinus `seq` ()] `seq` kindByRegex $
              [(Cut,        matches regex, parseKind0 (words kind)) | [regex,kind] <- getArg "-k" 2 args] ++
              [(Accumulate, matches regex, parseKind0 (words kind)) | [regex,kind] <- getArg "+k" 2 args]
            where
              plusKinds  = [parseKind0 (words kind) | [regex, kind] <- getArg "+k" 2 args]
              minusKinds = [parseKind0 (words kind) | [regex, kind] <- getArg "-k" 2 args]
              kindByRegex rks s = if null specifiedKinds then [defaultKindMinus] else specifiedKinds
                where
                  specifiedKinds = defaultKindsPlus ++
                                   [k | (Accumulate, p, k) <- rks, p s] ++
                                   case [k | (Cut, p, k) <- rks, p s] of {k:_ -> [k]; _ -> []}
              matches regex = matchTest (makeRegexOpts defaultCompOpt (ExecOption {captureGroups = False}) regex)
  
          fromTime    = fst `fmap` (parseTime . S.pack $ single "minimum time (inclusive)" "-fromTime" "")
          toTime      = fst `fmap` (parseTime . S.pack $ single "maximum time (exclusive)" "-toTime"   "")
          baseTime    = if pattern == S.pack "elapsed"
                          then Just ourBaseTime
                          else (fst `fmap` (parseTime . S.pack $ single "base time"                "-baseTime" ""))
  
          transformLabel t s = case baseTime of
            Nothing -> s
            Just bt -> showDelta t bt
  
          parseKind0 (('+':suffix):k) = (parseKind k, S.pack "." `S.append` S.pack suffix)
          parseKind0 k                = (parseKind k, S.empty)
  
          parseKind :: [String] -> ChartKind LocalTime
          parseKind ["acount",  n  ] = KindACount    {binSize=read n}
          parseKind ("acount":_)     = error "acount requires a single numeric argument, bin size, e.g.: -dk 'acount 1'"
          parseKind ["count",  n  ]  = KindCount    {binSize=read n}
          parseKind ("count":_)      = error "count requires a single numeric argument, bin size, e.g.: -dk 'count 1'"
          parseKind ["apercent",n,b] = KindAPercent  {binSize=read n,baseCount=read b}
          parseKind ("apercent":_)   = error "apercent requires two numeric arguments: bin size and base value, e.g.: -dk 'apercent 1 480'"
          parseKind ["afreq",   n  ] = KindAFreq     {binSize=read n}
          parseKind ("afreq":_)      = error "afreq requires a single numeric argument, bin size, e.g.: -dk 'afreq 1'"
          parseKind ["freq",    n  ] = KindFreq      {binSize=read n,style=BarsStacked}
          parseKind ["freq",    n,s] = KindFreq      {binSize=read n,style=parseStyle s}
          parseKind ("freq":_)       = error $ "freq requires a single numeric argument, bin size, e.g.: -dk 'freq 1', " ++ 
                                               "or two arguments, e.g.: -dk 'freq 1 clustered'"
          parseKind ["hist",    n  ] = KindHistogram {binSize=read n,style=BarsStacked}
          parseKind ["hist",    n,s] = KindHistogram {binSize=read n,style=parseStyle s}
          parseKind ("hist":_)       = error $ "hist requires a single numeric argument, bin size, e.g.: -dk 'hist 1', " ++ 
                                               "or two arguments, e.g.: -dk 'hist 1 clustered'"
          parseKind ["event"       ] = KindEvent
          parseKind ("event":_)      = error "event requires no arguments"
          parseKind ["quantile",b,q] = KindQuantile  {binSize=read b, quantiles=read ("["++q++"]")}
          parseKind ("quantile":_)   = error $ "quantile requres two arguments: bin size and comma-separated " ++ 
                                               "(without spaces!) quantiles, e.g.: -dk 'quantile 1 0.5,0.75,0.9'"
          parseKind ["binf",    b,q] = KindBinFreq   {binSize=read b, delims   =read ("["++q++"]")}
          parseKind ("binf":_)       = error $ "binf requres two arguments: bin size and comma-separated " ++ 
                                               "(without spaces!) threshold values, e.g.: -dk 'binf 1 10,50,100,200,500'"
          parseKind ["binh",    b,q] = KindBinHist   {binSize=read b, delims   =read ("["++q++"]")}
          parseKind ("binh":_)       = error $ "binh requres two arguments: bin size and comma-separated " ++ 
                                               "(without spaces!) threshold values, e.g.: -dk 'binh 1 10,50,100,200,500'"
          parseKind ["lines"       ] = KindLines
          parseKind ("lines":_)      = error "lines requires no arguments"
          parseKind ["dots"        ] = KindDots { alpha = 1 }
          parseKind ["dots",    a  ] = KindDots { alpha = read a }
          parseKind ("dots":_)       = error "dots requires 0 or 1 arguments (the argument is alpha value: 0 = transparent, 1 = opaque, default 1)"
          parseKind ["cumsum",  b  ] = KindCumSum    {binSize=read b, subtrackStyle=SumStacked}
          parseKind ["cumsum",  b,s] = KindCumSum    {binSize=read b, subtrackStyle=parseSubtrackStyle s}
          parseKind ("cumsum":_)     = error $ "cumsum requires 1 or 2 arguments (bin size and subtrack style), e.g.: " ++ 
                                               "-dk 'cumsum 10' or -dk 'cumsum 10 stacked'"
          parseKind ["sum",     b  ] = KindSum       {binSize=read b, subtrackStyle=SumStacked}
          parseKind ["sum",     b,s] = KindSum       {binSize=read b, subtrackStyle=parseSubtrackStyle s}
          parseKind ("sum":_)        = error $ "sum requires one or two arguments: bin size and optionally " ++ 
                                               "subtrack style, e.g.: -dk 'sum 1' or -dk 'sum 1 stacked'"
          parseKind ("duration":"drop":ws)  = KindDuration  {subKind=parseKind ws, dropSubtrack=True}
          parseKind ("duration":ws)  = KindDuration  {subKind=parseKind ws, dropSubtrack=False}
          parseKind (('w':'i':'t':'h':'i':'n':'[':sep:"]"):ws)
                                     = KindWithin    {subKind=parseKind ws, mapName = fst . S.break (==sep)}
          parseKind ["none"        ] = KindNone
          parseKind ("none":_)       = error "none requires no arguments"
          parseKind ["unspecified" ] = KindUnspecified
          parseKind ("unspecified":_)= error "unspecified requires no arguments"
          parseKind ws               = error ("Unknown diagram kind " ++ unwords ws)
  
          defaultKindMinus = parseKind0 $ words $ single "default kind" "-dk" "unspecified"
          defaultKindsPlus = map (parseKind0 . words . head) $ getArg "+dk" 1 args
  
          parseStyle "stacked"   = BarsStacked
          parseStyle "clustered" = BarsClustered
  
          parseSubtrackStyle "stacked"   = SumStacked
          parseSubtrackStyle "overlayed" = SumOverlayed
  
  
  -- getArg "-a" 2 ["-b", "1", "-a", "2", "q", "r", "-c", "3", "-a", "x"] =
  -- [["2", "q"], ["x"]]
  getArg :: String -> Int -> [String] -> [[String]]
  getArg name arity args = [take arity as | (t:as) <- tails args, t==name]
  
  