{-# LANGUAGE ScopedTypeVariables, TypeFamilies, ParallelListComp #-}
module Main where

import Control.Monad
import qualified Control.Monad.Trans.State.Strict as St
import qualified Control.Monad.Trans.RWS.Strict as RWS
import Control.Arrow
import Data.List
import Data.Ord
import Data.Maybe
import qualified Data.Map as M
import qualified Data.Set as Set
import qualified Data.ByteString.Char8 as S
import qualified Data.ByteString.Lazy.Char8 as B
import Data.ByteString.Lex.Lazy.Double

import Data.Char

import Text.Regex.TDFA
import Text.Regex.TDFA.ByteString

import System.Environment
import System.Exit
import System.Console.GetOpt

import Data.Time hiding (parseTime)
import Data.Time.Parse

import Data.Accessor

import Graphics.Rendering.Chart
import Graphics.Rendering.Chart.Gtk
import Graphics.Rendering.Chart.Grid
import Graphics.Rendering.Chart.Plot
import Graphics.Rendering.Chart.Event

import Data.Colour
import Data.Colour.Names

import Debug.Trace

data Status = Status {statusColor :: String, statusLabel :: String} deriving (Eq, Show, Ord)

instance PlotValue Status where
  toValue = const 0
  fromValue = const (Status "" "")
  autoAxis = const unitStatusAxis

unitStatusAxis :: AxisData Status
unitStatusAxis = AxisData {
    axis_viewport_ = \(x0,x1) _ -> (x0+x1)/2,
    axis_tropweiv_ = \_       _ -> Status "" "",
    axis_ticks_    = [(Status "" "", 0)],
    axis_labels_   = [[(Status "" "", "")]],
    axis_grid_     = []
}

data Edge = Rise | Fall | Pulse Status | SetTo Status deriving (Eq,Show)

data InEvent = InEdge  {evt_track :: S.ByteString, evt_edge :: Edge}
             | InValue {evt_track :: S.ByteString, evt_value :: Double}
             | InAtom  {evt_track :: S.ByteString, evt_atom :: S.ByteString}
             deriving (Show)

data OutFormat = PNG | PDF | PS | SVG
               | Window

class HasDelta t where
  type Delta t :: *
  add :: Delta t -> t -> t
  sub :: t -> t -> Delta t
  -- the 't' is a dummy argument here, just to aid type checking
  -- (since given just a Delta t, the compiler won't be able to
  -- figure out which 't' we're speaking of)
  toSeconds :: Delta t -> t -> Double
  fromSeconds :: Double -> t -> Delta t
  showDelta :: t -> t -> String

instance HasDelta Double where
  type Delta Double = Double
  add d t = t + d
  sub t2 t1 = t2 - t1
  toSeconds d _ = d
  fromSeconds d _ = d
  showDelta a b = show (a - b)

instance HasDelta LocalTime where
  type Delta LocalTime = NominalDiffTime
  add d t = utcToLocalTime utc (addUTCTime d (localTimeToUTC utc t))
  sub t2 t1 = diffUTCTime (localTimeToUTC utc t2) (localTimeToUTC utc t1)
  toSeconds d _ = fromIntegral (truncate (1000000*d)) / 1000000
  fromSeconds d _ = fromRational (toRational d)
  showDelta t1 t2
    | ts0 < 0.001 = "0"
    | tm < 1 = showsPrec 3 s "s"
    | th < 1 = show m ++ "m" ++ (if s<1 then "" else (show (floor s) ++ "s"))
    | d  < 1 = show h ++ "h" ++ (if m<1 then "" else (show m ++ "m"))
    | True   = show d ++ "d" ++ (if h<1 then "" else (show h ++ "h"))
    where ts0 = toSeconds (t1 `sub` t2) t1
          ts = if ts0 < 60 then ts0 else fromIntegral (round ts0)
          tm = floor (ts / 60) :: Int
          th = tm `div` 60 :: Int
          s = ts - 60 * fromIntegral tm :: Double
          m = tm - 60 * th :: Int
          h = th - 24 * d :: Int
          d = h `div` 24 :: Int

instance Read NominalDiffTime where
  readsPrec n s = [(fromSeconds i (undefined::LocalTime), s') | (i,s') <- readsPrec n s]

data SumSubtrackStyle = SumStacked | SumOverlayed

data ChartKind t = KindEvent
               | KindDuration  { subKind :: ChartKind t }
               | KindWithin    { mapName :: S.ByteString -> S.ByteString, subKind :: ChartKind t }
               | KindACount    { binSize :: Delta t }
               | KindAPercent  { binSize :: Delta t, baseCount :: Double }
               | KindAFreq     { binSize :: Delta t }
               | KindQuantile  { binSize :: Delta t, quantiles :: [Double] }
               | KindBinFreq   { binSize :: Delta t, delims    :: [Double] }
               | KindBinHist   { binSize :: Delta t, delims    :: [Double] }
               | KindFreq      { binSize :: Delta t, style :: PlotBarsStyle }
               | KindHistogram { binSize :: Delta t, style :: PlotBarsStyle }
               | KindLines
               | KindDots
               | KindCumSum    { subtrackStyle :: SumSubtrackStyle }
               | KindSum       { binSize :: Delta t, subtrackStyle :: SumSubtrackStyle }
               | KindNone
               | KindUnspecified -- Causes an error message 

data ZoomMode = ZoomInput | ZoomOutput

data ConcreteConf t =
  ConcreteConf {
    inFile        :: !FilePath,
    parseTime     :: !(B.ByteString -> Maybe (t, B.ByteString)),
    chartKindF    :: !(S.ByteString -> [ChartKind t]),

    fromTime      :: !(Maybe t),
    toTime        :: !(Maybe t),
    zoomMode      :: !ZoomMode,
    transformLabel :: !(t -> String -> String),

    outFile       :: !FilePath,
    outFormat     :: !OutFormat,
    outResolution :: !(Int,Int)
  }

type Conf = ConcreteConf LocalTime

data KindChoiceOperator = Cut | Accumulate

readConf :: [String] -> Conf
readConf args = case (words $ single "time format" "-tf" ("date %Y-%m-%d %H:%M:%OS")) of
    "date":f -> readConf' (strptime (B.pack $ unwords f))
    _        -> error "Unrecognized time format (-tf)"
  where
    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, zoomMode=zoomMode}
      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 PNG id $ lookup (single "output format" "-of" (name2format outFile)) $
            [("png",PNG), ("pdf",PDF), ("ps",PS), ("svg",SVG)
            , ("x",Window)
            ]
          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, parseKind (words kind)) | [regex,kind] <- getArg "-k" 2 args] ++
            [(Accumulate, matches regex, parseKind (words kind)) | [regex,kind] <- getArg "+k" 2 args]
          where
            plusKinds  = [parseKind (words kind) | [regex, kind] <- getArg "+k" 2 args]
            minusKinds = [parseKind (words kind) | [regex, kind] <- getArg "-k" 2 args]
            kindByRegex rks s = (defaultKindsPlus ++
                                [k | (Accumulate, p, k) <- rks, p s] ++
                                [case [k | (Cut, p, k) <- rks, p s] of { [] -> defaultKindMinus; 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    = fst `fmap` (parseTime . B.pack $ single "base time"                "-baseTime" "")

        zoomMode = case single "zoom mode (input/output)" "-zoomMode" "input" of
          "input"  -> ZoomInput
          "output" -> ZoomOutput

        transformLabel t s = case baseTime of
          Nothing -> s
          Just bt -> showDelta t bt

        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 ["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=BarsClustered}
        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=BarsClustered}
        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
        parseKind ("dots":_)       = error "dots requires no arguments"
        parseKind ["cumsum"      ] = KindCumSum    {subtrackStyle=SumStacked}
        parseKind ["cumsum",  s  ] = KindCumSum    {subtrackStyle=parseSubtrackStyle s}
        parseKind ("cumsum":_)     = error $ "cumsum requires zero or one argument (subtrack style), e.g.: " ++ 
                                             "-dk cumsum or -dk 'cumsum 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":ws)  = KindDuration  {subKind=parseKind ws}
        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 = parseKind $ words $ single "default kind" "-dk" "unspecified"
        defaultKindsPlus = map (parseKind . 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]

readSource :: (Show t) => (B.ByteString -> Maybe (t,B.ByteString)) -> FilePath -> IO [(t, InEvent)]
readSource readTime f = (map parseLine . filter (not . B.null) . blines) `fmap` (if f=="-" then B.getContents else B.readFile f)
  where
    blines   = map pruneLF . B.split '\n'
    pruneLF b | not (B.null b) && (B.last b == '\r') = B.init b
              | otherwise                            = b
    strict   = S.concat . B.toChunks
    parseLine s = (\x -> case x of { Just e -> e; Nothing -> error $ "Unparseable input line: " ++ B.unpack s }) $ do
      (t, s') <- readTime s
      (_, s'') <- B.uncons s'
      (c,rest) <- B.uncons s''
      case c of
        '>' -> return (t, InEdge (strict rest) Rise )
        '<' -> return (t, InEdge (strict rest) Fall )
        '!' -> do
          let (track, val') = B.break (==' ') rest
          if B.null val'
            then return (t, InEdge (strict track) (Pulse (Status "" "")))
            else do
              (_,val) <- B.uncons val'
              return (t, InEdge (strict track) $ Pulse (Status "" (B.unpack val)))
        '@' -> do
          let (track, val') = B.break (==' ') rest
          (_,val) <- B.uncons val'
          return (t, InEdge (strict track) $ SetTo (Status {statusColor = B.unpack $ val, statusLabel = ""}))
        '=' -> do
          let (track, val') = B.break (==' ') rest
          (_,val) <- B.uncons val'
          if B.null val
            then Nothing
            else do
              case B.head val of
                '`' -> do
                  return (t, InAtom (strict track) (strict $ B.tail val))
                _   -> do
                  (v,_  ) <- readDouble val
                  return (t, InValue (strict track) v)
        _   -> Nothing

makeChart :: (S.ByteString -> [ChartKind LocalTime]) -> 
             [(LocalTime, InEvent)] ->
             Maybe LocalTime -> Maybe LocalTime ->
             ZoomMode -> 
             (LocalTime -> String -> String) -> 
             Renderable ()
makeChart chartKindF []      minT maxT zoomMode transformLabel = emptyRenderable
makeChart chartKindF events0 minT maxT zoomMode transformLabel = renderLayout1sStacked plots
  where
    events :: [(LocalTime, InEvent)]
    events@((t0,_):_) = sortBy (comparing (\(t,_)-> t)) events0

    track2events :: M.Map S.ByteString [(LocalTime, InEvent)]
    track2events = reverse `fmap` foldl' insert M.empty [(evt_track e, x) | x@(t, e) <- events]
      where insert m (s, r) = M.alter (Just . maybe [r] (r:)) s m

    plots          = [ plotTrack k kind es | (k, es) <- M.toList track2events,
                                             kind <- chartKindF k,
                                             case kind of {KindNone -> False ; KindWithin _ _ -> False ; _ -> True} ] ++
                     withinPlots

    withinPlots  = [ plotWithKind name k es | (name, (k,es)) <- M.toList withinTracks ]
      where
        withinTracks = M.fromListWith (\(ka,as) (kb,bs) -> (ka,mergeOn fst as bs)) components
        components = [ (mn k, (sk, es))
                     | (k, es) <- M.toList track2events,
                       kind <- chartKindF k,
                       Just (sk,mn) <- [case kind of {KindWithin mn sk -> Just (sk,mn) ; _ -> Nothing}]]
        mergeOn f [] ys = ys
        mergeOn f xs [] = xs
        mergeOn f (x:xs) (y:ys)
          | f x <= f y = x : mergeOn f xs (y:ys)
          | otherwise  = y : mergeOn f (x:xs) ys

    minInTime  = case (zoomMode, minT) of (ZoomInput,  Just t) -> t ; _ -> head times
    maxInTime  = case (zoomMode, maxT) of (ZoomInput,  Just t) -> t ; _ -> last times

    minOutTime = case (zoomMode, minT) of (ZoomOutput, Just t) -> t ; _ -> head times
    maxOutTime = case (zoomMode, maxT) of (ZoomOutput, Just t) -> t ; _ -> last times

    times             :: [LocalTime]
    times             = sort $ [t | tes <- M.elems track2events, (t,_)<- tes]

    commonTimeAxis    :: AxisData LocalTime
    commonTimeAxis    = transformLabels $ autoAxis axisTimes
      where
        axisTimes = case zoomMode of
          ZoomInput  -> [minInTime] ++ times ++ [maxInTime]
          ZoomOutput -> [minOutTime] ++ filter (\x -> x >= minOutTime && x <= maxOutTime) times ++ [maxOutTime]
        transformLabels axis = axis { axis_labels_ = map (map (\(t, s) -> (t, transformLabel t s))) (axis_labels_ axis) }

    plotTrack :: S.ByteString -> ChartKind LocalTime -> [(LocalTime, InEvent)] -> AnyLayout1 LocalTime
    plotTrack name kind es = plotWithKind name kind es

    plotWithKind :: S.ByteString -> ChartKind LocalTime -> [(LocalTime, InEvent)] -> AnyLayout1 LocalTime
    plotWithKind name k es = case k of
      KindACount    bs    -> withAnyOrdinate $ plotTrackACount    name es bs
      KindAPercent  bs b  -> withAnyOrdinate $ plotTrackAPercent  name es bs b
      KindAFreq     bs    -> withAnyOrdinate $ plotTrackAFreq     name es bs
      KindFreq      bs k  -> withAnyOrdinate $ plotTrackFreq      name es bs k
      KindHistogram bs k  -> withAnyOrdinate $ plotTrackHist      name es bs k
      KindEvent           -> withAnyOrdinate $ plotTrackEvent     name es
      KindQuantile  bs qs -> withAnyOrdinate $ plotTrackQuantile  name es qs bs
      KindBinFreq   bs vs -> withAnyOrdinate $ plotTrackBinFreqs  name es vs bs
      KindBinHist   bs vs -> withAnyOrdinate $ plotTrackBinHist   name es vs bs
      KindLines           -> withAnyOrdinate $ plotTrackLines     name es
      KindDots            -> withAnyOrdinate $ plotTrackDots      name es
      KindSum       bs ss -> withAnyOrdinate $ plotTrackSum       name es bs ss
      KindCumSum    ss    -> withAnyOrdinate $ plotTrackCumSum    name es ss
      KindDuration  sk    -> plotWithKind       name sk (edges2durations (edges es) minInTime maxInTime name)
      KindWithin    _ _   -> error $ "KindDuration should not be plotted: track " ++ show name
      KindNone            -> error $ "KindNone should not be plotted: track " ++ show name
      KindUnspecified     -> error $ "Kind not specified for track " ++ show name ++ " (have you misspelled -dk or any of -k arguments?)"

    edges  :: [(LocalTime,InEvent)] -> [(LocalTime,S.ByteString,Edge)]
    values :: [(LocalTime,InEvent)] -> [(LocalTime,S.ByteString,Double)]
    atoms  :: [(LocalTime,InEvent)] -> [(LocalTime,S.ByteString,S.ByteString)]
    edges  es = [(t,s,e) | (t,InEdge  s e) <- es]
    values es = [(t,s,v) | (t,InValue s v) <- es]
    atoms  es = [(t,s,a) | (t,InAtom  s a) <- es]

    ourPlotBars :: (BarsPlotValue a) => PlotBars LocalTime a
    ourPlotBars = plot_bars_spacing ^= BarsFixGap 0 0 $
                  plot_bars_style   ^= BarsStacked    $
                  plot_bars_alignment ^= BarsLeft     $
                  defaultPlotBars

    plotTrackActivity :: S.ByteString -> [(LocalTime,InEvent)] -> NominalDiffTime -> ([(S.ByteString, Double)] -> Double -> Double) -> Layout1 LocalTime Double
    plotTrackActivity name es bs transform = layoutWithTitle [plotBars plot] name
      where plot = plot_bars_values      ^= barsData $
                   plot_bars_item_styles ^= itemStyles $
                   plot_bars_titles      ^= map show subTracks $
                   ourPlotBars
            itemStyles = [(solidFillStyle (opaque c), Nothing) | c <- colors]
            bins = edges2bins bs minInTime maxInTime (edges es)
            subTracks = Set.toList $ Set.fromList [s | (_,sns) <- bins, (s,n) <- sns]
            barsData = [(t, map (transform sns . fromMaybe 0 . (`lookup` sns)) subTracks) 
                       | ((t,_),sns) <- edges2bins bs minInTime maxInTime (edges es), (s,n) <- sns]

    plotTrackACount :: S.ByteString -> [(LocalTime,InEvent)] -> NominalDiffTime -> Layout1 LocalTime Double
    plotTrackACount name es bs = plotTrackActivity name es bs (\_ -> id)

    plotTrackAFreq :: S.ByteString -> [(LocalTime,InEvent)] -> NominalDiffTime -> Layout1 LocalTime Double
    plotTrackAFreq name es bs = plotTrackActivity name es bs $ \sns -> 
        let total = (\x -> if x==0 then 1 else x) $ sum [n | (s,n) <- sns] in (/total)

    plotTrackAPercent :: S.ByteString -> [(LocalTime,InEvent)] -> NominalDiffTime -> Double -> Layout1 LocalTime Double
    plotTrackAPercent name es bs b = plotTrackActivity name es bs (\_ x -> 100*x/b)

    plotTrackFreq  :: S.ByteString -> [(LocalTime,InEvent)] -> NominalDiffTime -> PlotBarsStyle -> Layout1 LocalTime Double
    plotTrackFreq  = plotTrackAtoms atoms2freqs

    plotTrackHist  :: S.ByteString -> [(LocalTime,InEvent)] -> NominalDiffTime -> PlotBarsStyle -> Layout1 LocalTime Int
    plotTrackHist  = plotTrackAtoms atoms2hist

    plotTrackAtoms :: (Num v, BarsPlotValue v) =>
                      ([S.ByteString] -> [S.ByteString] -> [v]) ->
                      S.ByteString -> [(LocalTime,InEvent)] -> NominalDiffTime -> PlotBarsStyle -> Layout1 LocalTime v
    plotTrackAtoms f name es bs k = layoutWithTitle [plotBars plot] name
      where plot = plot_bars_style       ^= k           $
                   plot_bars_values      ^= vals        $
                   plot_bars_item_styles ^= itemStyles  $
                   plot_bars_titles      ^= "":map show vs $
                   ourPlotBars
            itemStyles = none:[(solidFillStyle (opaque c), Nothing) | c <- colors]
            vals = byTimeBins ((0:).f vs) bs t0 as
            -- TODO Multiple tracks
            as   = [(t,a) | (t,_,a) <- atoms es]
            vs   = M.keys $ M.fromList $ [(a,()) | (_,a) <- as]

    -- TODO Multiple tracks
    plotTrackEvent :: S.ByteString -> [(LocalTime,InEvent)] -> Layout1 LocalTime Status
    plotTrackEvent     name es       = layoutWithTitle [toPlot plot] name
      where plot = plot_event_data           ^= dropTrack (edges2events (edges es) minInTime maxInTime) $
                   plot_event_long_fillstyle ^= toFillStyle             $
                   plot_event_label          ^= toLabel                 $
                   defaultPlotEvent
            dropTrack = map snd
            toFillStyle s = solidFillStyle . opaque $ fromMaybe lightgray (readColourName (statusColor s))
            toLabel     s = statusLabel s

    plotTrackQuantile :: S.ByteString -> [(LocalTime,InEvent)] -> [Double] -> NominalDiffTime -> Layout1 LocalTime Double
    plotTrackQuantile  name es qs bs = layoutWithTitle [plotBars plot] name
      where plot = plot_bars_values  ^= toBars (byTimeBins (getQuantiles qs) bs t0 vs) $
                   plot_bars_item_styles ^= quantileStyles $
                   plot_bars_titles  ^= quantileTitles $
                   ourPlotBars
            -- TODO Multiple tracks
            vs = [(t,v) | (t,_,v) <- values es]
            quantileStyles = none:(zip (map (solidFillStyle . opaque) colors) [Nothing | i <- [0..n+1]])
            quantileTitles = [""]++[show p1++".."++show p2++"%" | (p1,p2) <- lag percents ]
              where
                percents = map (floor . (*100.0)) $ [0.0] ++ qs ++ [1.0]
            n = length qs

    lag :: [a] -> [(a,a)]
    lag xs = xs `zip` tail xs

    colors = cycle [green,blue,red,brown,yellow,orange,grey,purple,violet,lightblue]

    binTitles vs = [low]++[show v1++".."++show v2 | (v1,v2) <- lag vs]++[high]
      where
        low = "<"++show (head vs)
        high = ">"++show (last vs)

    binColor n i = opaque (colors !! i)

    plotTrackBinFreqs  name es vs bs = plotTrackBars vals (binTitles vs) name (binColor n)
      where
        vals = byTimeBins ((0:).values2binFreqs  vs) bs t0 tvs
        n    = length vs
        -- TODO Multiple tracks
        tvs  = [(t,v) | (t,_,v) <- values es]
    plotTrackBinHist   name es vs bs = plotTrackBars vals (binTitles vs) name (binColor n)
      where
        vals = byTimeBins ((0:).values2binHist vs) bs t0 tvs
        tvs  = [(t,v) | (t,_,v) <- values es]
        n    = length vs

    plotTrackBars :: (BarsPlotValue a) => [(LocalTime,[a])] -> [String] -> S.ByteString -> (Int -> AlphaColour Double) -> Layout1 LocalTime a
    plotTrackBars values titles name clr = layoutWithTitle [plotBars plot] name
      where plot = plot_bars_values      ^= values    $
                   plot_bars_item_styles ^= binStyles $
                   plot_bars_titles      ^= "":titles $
                   ourPlotBars
            binStyles = none:[(solidFillStyle (clr i), Nothing)
                             | (i,_) <- [0..]`zip`titles]

    none = (solidFillStyle transparent, Nothing)
    toBars tvs = [(t,diffs vs) | (t,vs) <- tvs]
    diffs xs = zipWith (-) xs (0:xs)

    groupByTrack xs = M.toList $ sort `fmap` M.fromListWith (++) [(s, [(t,v)]) | (t,s,v) <- xs]

    plotLines :: S.ByteString -> [(S.ByteString, [(LocalTime,Double)])] -> Layout1 LocalTime Double
    plotLines name vss = layoutWithTitle (map toPlot plots) name
      where plots = [plot_lines_values ^= [vs] $ 
                     plot_lines_title  ^= S.unpack subtrack $ 
                     plot_lines_style  .> line_color ^= color $ 
                     defaultPlotLines 
                     | (subtrack, vs) <- vss
                     | color <- map opaque colors]

    plotTrackLines :: S.ByteString -> [(LocalTime,InEvent)] -> Layout1 LocalTime Double
    plotTrackLines name es = plotLines name (groupByTrack (values es))

    plotTrackDots :: S.ByteString -> [(LocalTime,InEvent)] -> Layout1 LocalTime Double
    plotTrackDots  name es = layoutWithTitle (map toPlot plots) name
      where plots = [plot_points_values ^= vs $
                     plot_points_style  ^= hollowCircles 4 1 color $
                     plot_points_title  ^= S.unpack subtrack $
                     defaultPlotPoints
                     | (subtrack, vs) <- groupByTrack (values es)
                     | color <- map opaque colors]

    plotTrackCumSum :: S.ByteString -> [(LocalTime,InEvent)] -> SumSubtrackStyle -> Layout1 LocalTime Double
    plotTrackCumSum name es SumOverlayed = plotLines name rows
      where rows = [(track, scanl (\(t1,s) (t2,v) -> (t2,s+v)) (minInTime, 0) vs) | (track, vs) <- groupByTrack (values es)]
    plotTrackCumSum name es SumStacked = plotLines name rows
      where vals = values es
            allTracks = Set.toList $ Set.fromList [track | (t, track, v) <- vals]

            rows :: [(S.ByteString, [(LocalTime, Double)])]
            rows = groupByTrack [(t, track, v) | (t, tvs) <- rowsT, (track,v) <- tvs]

            rowsT :: [(LocalTime, [(S.ByteString, Double)])]
            rowsT = (minInTime, zip allTracks (repeat 0)) : St.evalState (mapM addDataPoint vals) M.empty
            
            addDataPoint (t, track, v) = do
              St.modify (M.insertWith (+) track v)
              st <- St.get
              let trackSums = map (\x -> M.findWithDefault 0 x st) allTracks
              return (t, allTracks `zip` (scanl1 (+) trackSums))


    plotTrackSum :: S.ByteString -> [(LocalTime,InEvent)] -> NominalDiffTime -> SumSubtrackStyle -> Layout1 LocalTime Double
    plotTrackSum name es bs ss = plotLines name rows
      where groups    = groupByTrack (values es)
            allTracks = M.keys $ M.fromList groups
            
            rowsT :: [(LocalTime, M.Map S.ByteString Double)]
            rowsT = byTimeBins (M.fromListWith (+)) bs t0 $ sort [(t, (track, v)) | (track, vs) <- groups, (t, v) <- vs]
            
            rowsT' = case ss of
              SumOverlayed -> map (\(t,ss) -> (t, M.toList ss)) rowsT
              SumStacked   -> map (\(t,ss) -> (t, stack ss))    rowsT

            stack :: M.Map S.ByteString Double -> [(S.ByteString, Double)]
            stack ss = zip allTracks (scanl1 (+) (map (\x -> M.findWithDefault 0 x ss) allTracks))
            
            rows :: [(S.ByteString, [(LocalTime, Double)])]
            rows  = M.toList $ sort `fmap` M.fromListWith (++) [(track, [(t,sum)]) | (t, m) <- rowsT', (track, sum) <- m]

    layoutWithTitle :: (PlotValue a) => [Plot LocalTime a] -> S.ByteString -> Layout1 LocalTime a
    layoutWithTitle plots name =
        layout1_title ^= "" $
        layout1_plots ^= map Left plots $
        layout1_bottom_axis .> laxis_generate ^= (\_ -> commonTimeAxis) $
        layout1_top_axis    .> laxis_generate ^= (\_ -> commonTimeAxis) $
        layout1_left_axis   .> laxis_title ^= S.unpack name $
        layout1_margin ^= 0 $
        layout1_grid_last ^= True $
        defaultLayout1

edges2durations :: forall t. (Ord t, HasDelta t) => [(t,S.ByteString,Edge)] -> t -> t -> S.ByteString -> [(t,InEvent)]
edges2durations tes minTime maxTime commonTrack = 
    [(t2, InValue commonTrack $ toSeconds (t2 `sub` t1) (undefined::t)) 
    | (track, LongEvent (t1,True) (t2,True) _) <- edges2events tes minTime maxTime]

edges2events :: (Ord t) => [(t,S.ByteString,Edge)] -> t -> t -> [(S.ByteString,Event t Status)]
edges2events tes minTime maxTime = snd $ RWS.execRWS (mapM_ step tes >> flush) () M.empty 
  where
    getTrack s = M.findWithDefault (minTime, 0, emptyStatus) s `fmap` RWS.get 
    putTrack s t = RWS.get >>= RWS.put . M.insert s t
    trackCase s whenZero withNonzero = do
      (t0, numActive, st) <- getTrack s
      case numActive of
        0 -> whenZero
        n -> withNonzero t0 numActive st
    killTrack s = RWS.get >>= RWS.put . M.delete s

    emptyStatus = Status "" ""

    step (t,s,Pulse st) = RWS.tell [(s, PulseEvent t st)]
    step (t,s,SetTo st) = trackCase s (putTrack s (t, 1, st))
                                      (\t0 n st0 -> RWS.tell [(s, LongEvent (t0,True) (t,True) st0)] >> 
                                                    putTrack s (t, n, st))
    step (t,s,Rise)     = trackCase s (putTrack s (t, 1, emptyStatus)) 
                                      (\t0 n st -> putTrack s (t, n+1, st))
    step (t,s,Fall)     = do
      (t0, numActive, st) <- getTrack s
      case numActive of
        1 -> RWS.tell [(s, LongEvent (t0,True) (t,True) st)] >> killTrack s
        n -> putTrack s (t0, max 0 (n-1), st)

    flush = RWS.get >>= mapM_ (\(s, (t0,_,st)) -> RWS.tell [(s, LongEvent (t0,True) (maxTime,False) st)]) . M.toList

edges2bins :: forall t. (Ord t,HasDelta t,Show t) => Delta t -> t -> t -> [(t,S.ByteString,Edge)] -> [((t,t), [(S.ByteString,Double)])]
edges2bins binSize minTime maxTime es = snd $ RWS.execRWS (mapM_ step es >> flush) () (M.empty, iterate (add binSize) minTime)
  where
    getBin       = RWS.gets $ \(m, t1:t2:ts) -> (t1, t2)
    nextBin      = RWS.get >>= \(m, t1:t2:ts) -> RWS.put (m, t2:ts)
    getState s t = RWS.gets $ \(m, _) -> (M.findWithDefault (0,t,0,0) s m)
    putState s v = RWS.get >>= \(m, ts) -> RWS.put (M.insert s v m, ts)
    modState s t f = getState s t >>= putState s . f
    getStates    = RWS.gets (\(m,_) -> M.toList m)

    flushBin = do
      bin@(t1,t2) <- getBin
      states <- getStates
      let binSizeSec = toSeconds (t2 `sub` t1) t1
      RWS.tell [(bin, [(s, (fromIntegral npulse + area + toSeconds (t2 `sub` start) t2*nopen)/binSizeSec) | (s,(area,start,nopen,npulse)) <- states])]
      forM_ states $ \(s, (area,start,nopen,_)) -> putState s (0,t2,nopen,0)
      nextBin

    step ev@(t, s, e) = do
      (t1, t2) <- getBin
      if t < t1
        then error "Times are not in ascending order"
        else if (t >= t2)
               then flushBin >> step ev
               else step'' ev
    step'' ev@(t,s,e) = do (t1,t2) <- getBin; when (t < t1 || t >= t2) (error "Outside bin"); step' ev
    step' (t, s, SetTo _) = modState s t id
    step' (t, s, Pulse _) = modState s t $ \(area, start, nopen, npulse) -> (area,                                   t, nopen,   npulse+1)
    step' (t, s, Rise)    = modState s t $ \(area, start, nopen, npulse) -> (area+toSeconds (t `sub` start) t*nopen, t, nopen+1, npulse)
    step' (t, s, Fall)    = modState s t $ \(area, start, nopen, npulse) -> (area+toSeconds (t `sub` start) t*nopen, t, nopen-1, npulse)
    flush                 = getBin >>= \(t1,t2) -> when (t2 <= maxTime) (flushBin >> flush)

values2timeBins :: (Ord t) => [t] -> [(t,a)] -> [[a]]
values2timeBins (t1:t2:ts) []          = []
values2timeBins (t1:t2:ts) tvs@((t,_):_)
  | t<t1 = error "Times are not in ascending order"
  | True = let (bin,rest) = span ((<t2).fst) tvs
           in (map snd bin : values2timeBins (t2:ts) rest)

byTimeBins :: (Ord t, HasDelta t, Ord a) => ([a] -> b) -> Delta t -> t -> [(t,a)] -> [(t, b)]
byTimeBins f binSize t0 tvs = times `zip` map f (values2timeBins times tvs)
  where times = iterate (add binSize) t0

getQuantiles :: (Ord a) => [Double] -> [a] -> [a]
getQuantiles qs = \xs -> quantiles' (sort xs)
  where
    qs' = sort qs
    quantiles' [] = []
    quantiles' xs = index (0:ns++[n-1]) 0 xs
      where
        n  = length xs
        ns = map (floor . (*(fromIntegral n-1))) qs'

        index _         _ []     = []
        index []        _ _      = []
        index [i]       j (x:xs)
          | i<j  = []
          | i==j  = [x]
          | True = index [i] (j+1) xs
        index (i:i':is) j (x:xs)
          | i<j  = index (i':is)   j     (x:xs)
          | i>j  = index (i:i':is) (j+1) xs
          | i==i' = x:index (i':is) j     (x:xs)
          | True = x:index (i':is) (j+1) xs

values2binFreqs :: (Ord a) => [a] -> [a] -> [Double]
values2binFreqs bins xs = map toFreq $ values2binHist bins xs
  where
    n = length xs
    toFreq = if n==0 then const 0 else (\k -> fromIntegral k/fromIntegral n)
values2binHist bins xs = values2binHist' bins $ sort xs
  where
    values2binHist' []     xs = [length xs]
    values2binHist' (a:as) xs = length xs0 : values2binHist' as xs'
      where (xs0,xs') = span (<a) xs

atoms2hist :: (Ord a) => [a] -> [a] -> [Int]
atoms2hist as xs = map (maybe 0 id . (`M.lookup` m)) as
  where
    m          = foldl' insert M.empty xs
    insert m a = M.alter (Just . maybe 1 inc) a m
    inc    n   = n `seq` (n+1)

atoms2freqs :: (Ord a) => [a] -> [a] -> [Double]
atoms2freqs as xs = map toFreq (atoms2hist as xs)
  where
    n = length xs
    toFreq = if n==0 then const 0 else (\k -> fromIntegral k/fromIntegral n)

zoom :: (Ord t) => [(t, InEvent)] -> Maybe t -> Maybe t -> [(t, InEvent)]
zoom events fromTime toTime = filter p events
  where
    p (t, _) = (maybe True (\ft -> t >= ft) fromTime) &&
               (maybe True (\tt -> t <  tt) toTime)

showHelp = mapM_ putStrLn [ "",
  "tplot - a tool for drawing timing diagrams.",
  "        See http://www.haskell.org/haskellwiki/Timeplot",
  "Usage: tplot [-o OFILE] [-of {png|pdf|ps|svg|x}] [-or 640x480]",
  "             -if IFILE [-tf TF] ",
  "             [{+|-}k Pat1 Kind1 {+|-}k Pat2 Kind2 ...] [{+|-}dk KindN]",
  "             [-fromTime TIME] [-toTime TIME] [-baseTime TIME]",
  "  -o  OFILE  - output file (required if -of is not x)",
  "  -of        - output format (x means draw result in a window, default:",
  "               extension of -o)",
  "  -or        - output resolution (default 640x480)",
  "  -if IFILE  - input file; '-' means 'read from stdin'",
  "  -tf TF     - time format: -tf 'date PATTERN' means that times are dates in the format",
  "               specified by PATTERN - see http://linux.die.net/man/3/strptime, ",
  "               for example, -tf 'date [%Y-%m-%d %H:%M:%S]' parses dates like ",
  "               '[2009-10-20 16:52:43]'.",
  "               We also support %OS for fractional seconds (i.e. %OS will",
  "               parse 12.4039 or 12,4039) and %^[+-][N]s for ten-powers ",
  "               of seconds since epoch, for example %^-3s is ms since epoch.",
  "               Default: 'date %Y-%m-%d %H:%M:%OS'",
  "  {+|-}dk    - set default diagram kind",
  "  {+|-}k P K - set diagram kind for tracks matching regex P (in the format",
  "               of regex-tdfa, which is at least POSIX-compliant and",
  "               supports some GNU extensions) to K",
  "               EXPLANATION:",
  "               -k clauses are matched till first success, +k are all",
  "               matched: a track is drawn acc. to all matching +k, to +dk",
  "               AND ALSO to the first matching -k, or -dk if none of -k",
  "               match",
  "  -fromTime  - filter records whose time is >= this time",
  "               (formatted according to -tf)",
  "  -toTime    - filter records whose time is <  this time",
  "               (formatted according to -tf)",
  "  -baseTime  - display time difference with this value instead of absolute time",
  "               (formatted according to -tf)",
  "  -zoomMode M- whether -fromTime and -toTime filter the input or the output:",
  "               zooming input (dropping events outside interval) may be faster,",
  "               but zooming output will be more accurate for history-dependent",
  "               graphs like activity graphs. M is 'input' or 'output'.",
  "",
  "Input format: lines of the following form:",
  "1234 >A - at time 1234, activity A has begun",
  "1234 <A - at time 1234, activity A has ended",
  "1234 !B - at time 1234, pulse event B has occured",
  "1234 !B TEXT - at time 1234, pulse event B has occured with label TEXT",
  "1234 @B COLOR - at time 1234, the status of B became such that it is",
  "                appropriate to draw it with color COLOR :)",
  "1234 =C VAL - at time 1234, parameter C had numeric value VAL (for example,",
  "              HTTP response time)",
  "1234 =D `EVENT - at time 1234, event EVENT occured in process D (for",
  "                 example, HTTP response code)",
  "It is assumed that many events of the same kind may occur at once.",
  "Diagram kinds:",
  "  'none' - do not plot this track",
  "  'event' is for event diagrams: activities are drawn like --[===]--- ,",
  "     pulse events like --|-- with a label over '|'",
  "  'duration XXXX' - plot any kind of diagram over the *durations* of events",
  "     on a track (delimited by > ... <), for example 'duration quantile",
  "     300 0.25,0.5,0.75' will plot these quantiles of durations of the",
  "     events. This is useful where your log looks like 'Started processing'",
  "     ... 'Finished processing': you can plot processing durations without",
  "     computing them yourself. Very useful inside 'within'!",
  "  'within[C] XXXX' - draw plot XXXX over events grouped by their track's name ",
  "     before separator C. For example, if you have processes",
  "     named 'MACHINE-PID' (i.e. UNIT027-8532) say 'begin something' / ",
  "     'end something' and you're interested in the properties of per-machine",
  "     durations, use within[-] duration dots; or if you've got jobs starting",
  "     and finishing tasks on different machines, and you want to plot a diagram",
  "     showing the number of utilized machines and how this number is composed of",
  "     utilization by different jobs, make your trace say '>job-JOBID'...'<job-JOBID'",
  "     and use -k job 'within[-] count 1'.",
  "     Explanation: if you specify -k REGEX 'within[.] SOMETHING', timeplot will",
  "     take all tracks matching REGEX, split each track around the first '.', giving",
  "     a 'supertrack' and 'subtrack' (e.g. customer.John -> customer, John), ",
  "     group the events by supertrack and for each supertrack draw a graphical track",
  "     using the plot type SOMETHING. It's up to SOMETHING to do something with these",
  "     events, e.g. 'lines' will simply draw several line plots, one per subtrack.",
  "  'acount N' is for activity counts: a histogram is drawn with granularity",
  "     of N time units, where the bin corresponding to [t..t+N) has value",
  "     'what was the average number of active events or impulses in that",
  "     interval'. When used inside 'within', the histogram is a stacked one,",
  "     with one vertical bar per subtrack in each bin.",
  "  'apercent N B' is for activity percentages of a basis: like 'acount N',",
  "     but instead of X you get 100*X/B",
  "  'afreq N' is for activity frequencies: it's like acount, but relative",
  "     rather than absolute - it only makes sense inside 'within', because",
  "     otherwise it would just always show a filled one-coloured bar in every bin.",
  "  'freq N [TYPE]' is for event frequency histograms: a histogram of type",
  "     TYPE (stacked or clustered, default clustered) is drawn for each time",
  "     bin of size N, about the *frequency* of various ` events",
  "  'hist N [TYPE]' is for event count histograms: a histogram of type TYPE",
  "     (stacked or clustered, default clustered) is drawn for each time bin",
  "     of size N, about the *counts* of various ` events",
  "  'quantile N q1,q2,..' (example: quantile 100 0.25,0.5,0.75) - a bar chart",
  "     of corresponding quantiles in time bins of size N",
  "  'binf N v1,v2,..' (example: binf 100 1,2,5,10) - a histogram of frequency",
  "     of values falling into bins min..v1, v1..v2, .., v2..max in time bins",
  "     of size N",
  "  'binh N v1,v2,..' (example: binf 100 1,2,5,10) - a histogram of counts of",
  "     values falling into bins min..v1, v1..v2, .., v2..max in time bins of",
  "     size N",
  "  'lines'  - a simple line plot of numeric values. When used in 'within', ",
  "     gives one plot per subtrack.",
  "  'dots'   - a simple dot plot of numeric values. When used in 'within', ",
  "     gives one plot per subtrack.",
  "  'cumsum [TYPE]' - a simple line plot of the sum of the numeric values.",
  "     When used in 'within', produce 1 subplot per subtrack. TYPE can be: ",
  "     'overlayed' -> just lay the subplots over one another.",
  "     'stacked'   -> add them up at each point to see how subtracks contribute",
  "     to the total cumulative sum (default; only makes sense inside 'within')",
  "  'sum N [TYPE]' - a simple line plot of the sum of the numeric values in time",
  "     bins of size N. N is measured in units or in seconds.",
  "     When used in 'within', produce 1 subplot per subtrack. TYPE used in same ",
  "     way as in cumsum."
  ]


main = do
  args <- getArgs
  mainWithArgs args
mainWithArgs args = do
  when (null args || args == ["--help"]) $ showHelp >> exitSuccess
  let !conf = readConf args
  let render = case (outFormat conf) of {
      PNG    -> \c w h f -> const () `fmap` renderableToPNGFile c w h f;
      PDF    -> renderableToPDFFile ;
      PS     -> renderableToPSFile  ;
      SVG    -> renderableToSVGFile ;
      Window -> \c w h f -> renderableToWindow c w h
    }
  case conf of
    ConcreteConf {
        parseTime=parseTime, inFile=inFile, chartKindF=chartKindF,
        outFile=outFile, outResolution=outResolution,
        fromTime=fromTime, toTime=toTime, transformLabel=transformLabel, zoomMode=zoomMode} -> do
      source <- readSource parseTime inFile
      let source' = case zoomMode of {
          ZoomInput  -> zoom source fromTime toTime ;
          ZoomOutput -> source
        }
      let chart = makeChart chartKindF source' fromTime toTime zoomMode transformLabel
      let (w,h) = outResolution
      render chart w h outFile