Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
branch: master
Fetching contributors…

Cannot retrieve contributors at this time

172 lines (150 sloc) 10.077 kb
{-# LANGUAGE CPP #-}
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 qualified Data.ByteString.Lazy.Char8 as B
import Data.ByteString.Lex.Lazy.Double
import Unsafe.Coerce
import Tools.TimePlot.Types
data ConcreteConf t =
ConcreteConf {
inFile :: !FilePath,
parseTime :: !(B.ByteString -> Maybe (t, B.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 -> B.pack (unwords f)
f -> B.pack (unwords f)
Just (ourBaseTime,_) = strptime "%Y-%m-%d %H:%M:%OS" "1900-01-01 00:00:00"
{-# NOINLINE ourStrptime #-}
ourStrptime :: B.ByteString -> Maybe (LocalTime, B.ByteString)
ourStrptime = if pattern == B.pack "elapsed"
then \s -> do
(d, s') <- readDouble 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' :: (B.ByteString -> Maybe (LocalTime, B.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 . B.pack $ single "minimum time (inclusive)" "-fromTime" "")
toTime = fst `fmap` (parseTime . B.pack $ single "maximum time (exclusive)" "-toTime" "")
baseTime = if pattern == B.pack "elapsed"
then Just ourBaseTime
else (fst `fmap` (parseTime . B.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]
Jump to Line
Something went wrong with that request. Please try again.