{-# LANGUAGE ScopedTypeVariables, TypeFamilies, FlexibleContexts, GADTs, CPP, 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 import System.Exit import System.Console.GetOpt import Data.Time hiding (parseTime) import Data.Time.Parse import Data.Accessor import Graphics.Rendering.Chart #if HAVE_GTK import Graphics.Rendering.Chart.Gtk #endif 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 #if HAVE_GTK | Window #endif 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] class (Ord t, HasDelta t, PlotValue t, Show t, Show (Delta t), Read (Delta t)) => TimeAxis t instance TimeAxis Double instance TimeAxis LocalTime 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 } | 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 data ConcreteConf t = ConcreteConf { inFile :: FilePath, parseTime :: B.ByteString -> Maybe (t, B.ByteString), chartKindF :: S.ByteString -> [ChartKind t], fromTime :: Maybe t, toTime :: Maybe t, transformLabel :: t -> String -> String, outFile :: FilePath, outFormat :: OutFormat, outResolution :: (Int,Int) } data Conf = forall t . (TimeAxis t) => Conf {concrete :: ConcreteConf t} data KindChoiceOperator = Cut | Accumulate readConf :: [String] -> Conf readConf args = case (words $ single "time format" "-tf" ("date %Y-%m-%d %H:%M:%OS")) of ["num"] -> Conf $ readConf' readDouble "date":f -> Conf $ 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' :: forall t. (TimeAxis t) => (B.ByteString -> Maybe (t, B.ByteString)) -> ConcreteConf t 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 (or have you specified '-of x' and built without --flags=gtk ?)") outFormat = maybe PNG id $ lookup (single "output format" "-of" (name2format outFile)) $ [("png",PNG), ("pdf",PDF), ("ps",PS), ("svg",SVG) #if HAVE_GTK , ("x",Window) #endif ] 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) chartKindF = 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 ifNull xs y = case xs of { [] -> [y] ; _ -> xs } 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" "") transformLabel t s = case baseTime of Nothing -> s Just bt -> showDelta t bt parseKind ["acount", n ] = KindACount {binSize=read n} parseKind ["afreq", n ] = KindAFreq {binSize=read n} parseKind ["freq", n ] = KindFreq {binSize=read n,style=BarsClustered} parseKind ["freq", n,s] = KindFreq {binSize=read n,style=parseStyle s} parseKind ["hist", n ] = KindHistogram {binSize=read n,style=BarsClustered} parseKind ["hist", n,s] = KindHistogram {binSize=read n,style=parseStyle s} parseKind ["event" ] = KindEvent parseKind ["quantile",b,q] = KindQuantile {binSize=read b, quantiles=read ("["++q++"]")} parseKind ["binf", b,q] = KindBinFreq {binSize=read b, delims =read ("["++q++"]")} parseKind ["binh", b,q] = KindBinHist {binSize=read b, delims =read ("["++q++"]")} parseKind ["lines" ] = KindLines parseKind ["dots" ] = KindDots parseKind ["cumsum" ] = KindCumSum {subtrackStyle=SumStacked} parseKind ["cumsum", s ] = KindCumSum {subtrackStyle=parseSubtrackStyle s} parseKind ["sum", b ] = KindSum {binSize=read b, subtrackStyle=SumStacked} parseKind ["sum", b,s] = KindSum {binSize=read b, subtrackStyle=parseSubtrackStyle s} 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 ws = error ("Unknown diagram kind " ++ unwords ws) defaultKindMinus = parseKind $ words $ single "default kind" "-dk" "none" 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 = (justs . map parseLine . blines) `fmap` (if f=="-" then B.getContents else B.readFile f) where justs xs = [x | Just x <- xs] 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 = 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 :: forall t . TimeAxis t => (S.ByteString -> [ChartKind t]) -> [(t, InEvent)] -> Maybe t -> Maybe t -> (t -> String -> String) -> Renderable () makeChart chartKindF [] minT maxT transformLabel = emptyRenderable makeChart chartKindF events0 minT maxT transformLabel = renderLayout1sStacked plots where events :: [(t, InEvent)] events@((t0,_):_) = sortBy (comparing (\(t,_)-> t)) events0 track2events :: M.Map S.ByteString [(t, 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 minTime = case minT of Just t -> t ; Nothing -> head times maxTime = case maxT of Just t -> t ; Nothing -> last times times :: [t] times = sort $ [t | tes <- M.elems track2events, (t,_)<- tes] commonTimeAxis :: AxisData t commonTimeAxis = transformLabels $ autoAxis ([minTime] ++ times ++ [maxTime]) where transformLabels axis = axis { axis_labels_ = map (map (\(t, s) -> (t, transformLabel t s))) (axis_labels_ axis) } plotTrack :: S.ByteString -> ChartKind t -> [(t, InEvent)] -> AnyLayout1 t plotTrack name kind es = plotWithKind name kind es plotWithKind :: S.ByteString -> ChartKind t -> [(t, InEvent)] -> AnyLayout1 t plotWithKind name k es = case k of KindACount bs -> withAnyOrdinate $ plotTrackACount name es bs 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) minTime maxTime) KindWithin _ _ -> error "KindDuration should not be plotted" KindNone -> error "KindNone should not be plotted" edges :: [(t,InEvent)] -> [(t,S.ByteString,Edge)] values :: [(t,InEvent)] -> [(t,S.ByteString,Double)] atoms :: [(t,InEvent)] -> [(t,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 t a ourPlotBars = plot_bars_spacing ^= BarsFixGap 0 0 $ plot_bars_style ^= BarsStacked $ plot_bars_alignment ^= BarsLeft $ defaultPlotBars plotTrackACount :: S.ByteString -> [(t,InEvent)] -> Delta t -> Layout1 t Double plotTrackACount name es bs = 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 minTime maxTime (edges es) subTracks = Set.toList $ Set.fromList [s | (_,sns) <- bins, (s,n) <- sns] barsData = [(t, map (fromMaybe 0 . (`lookup` sns)) subTracks) | ((t,_),sns) <- edges2bins bs minTime maxTime (edges es), (s,n) <- sns] plotTrackAFreq :: S.ByteString -> [(t,InEvent)] -> Delta t -> Layout1 t Double plotTrackAFreq name es bs = 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 minTime maxTime (edges es) subTracks = Set.toList $ Set.fromList [s | (_,sns) <- bins, (s,n) <- sns] barsData = [(t, map ((/total) . fromMaybe 0 . (`lookup` sns)) subTracks) | ((t,_),sns) <- edges2bins bs minTime maxTime (edges es), let total = (\x -> if x==0 then 1 else x) $ sum [n | (s,n) <- sns], (s,n) <- sns] plotTrackFreq :: S.ByteString -> [(t,InEvent)] -> Delta t -> PlotBarsStyle -> Layout1 t Double plotTrackFreq = plotTrackAtoms atoms2freqs plotTrackHist :: S.ByteString -> [(t,InEvent)] -> Delta t -> PlotBarsStyle -> Layout1 t Int plotTrackHist = plotTrackAtoms atoms2hist plotTrackAtoms :: (Num v, BarsPlotValue v) => ([S.ByteString] -> [S.ByteString] -> [v]) -> S.ByteString -> [(t,InEvent)] -> Delta t -> PlotBarsStyle -> Layout1 t 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 -> [(t,InEvent)] -> Layout1 t Status plotTrackEvent name es = layoutWithTitle [toPlot plot] name where plot = plot_event_data ^= dropTrack (edges2events (edges es) minTime maxTime) $ 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 -> [(t,InEvent)] -> [Double] -> Delta t -> Layout1 t 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) [Just $ solidLine 1 (opaque black) | 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) => [(t,[a])] -> [String] -> S.ByteString -> (Int -> AlphaColour Double) -> Layout1 t 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), Just $ solidLine 1 (opaque black)) | (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, [(t,Double)])] -> Layout1 t 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 -> [(t,InEvent)] -> Layout1 t Double plotTrackLines name es = plotLines name (groupByTrack (values es)) plotTrackDots :: S.ByteString -> [(t,InEvent)] -> Layout1 t 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 -> [(t,InEvent)] -> SumSubtrackStyle -> Layout1 t Double plotTrackCumSum name es SumOverlayed = plotLines name rows where rows = [(track, scanl (\(t1,s) (t2,v) -> (t2,s+v)) (minTime, 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, [(t, Double)])] rows = groupByTrack [(t, track, v) | (t, tvs) <- rowsT, (track,v) <- tvs] rowsT :: [(t, [(S.ByteString, Double)])] rowsT = (minTime, 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 -> [(t,InEvent)] -> Delta t -> SumSubtrackStyle -> Layout1 t Double plotTrackSum name es bs ss = plotLines name rows where groups = groupByTrack (values es) allTracks = M.keys $ M.fromList groups rowsT :: [(t, 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, [(t, Double)])] rows = M.toList $ sort `fmap` M.fromListWith (++) [(track, [(t,sum)]) | (t, m) <- rowsT', (track, sum) <- m] layoutWithTitle :: (PlotValue a) => [Plot t a] -> S.ByteString -> Layout1 t 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 -> [(t,InEvent)] edges2durations tes minTime maxTime = [(t2, InValue track $ toSeconds (t2 `sub` t1) (undefined::t)) | (track,LongEvent t1 t2 _) <- 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 (undefined, 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 t 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 t st)] >> killTrack s n -> putTrack s (t0, max 0 (n-1), st) flush = RWS.get >>= mapM_ (\(s, (t0,_,st)) -> RWS.tell [(s, LongEvent t0 maxTime 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/binSizeSec + 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 id 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 ([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) | ij = 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] -> [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 :: (TimeAxis 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); x is only available if you installed", " timeplot with --flags=gtk", " -or - output resolution (default 640x480)", " -if IFILE - input file; '-' means 'read from stdin'", " -tf TF - time format: 'num' means that times are floating-point", " numbers (for instance, seconds elapsed since an event);", " 'date PATTERN' means that times are dates in the format", " specified by PATTERN - see", " http://linux.die.net/man/3/strptime, for example,", " [%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)", "", "Input format: lines of the following form:", "1234 >A - at time 1234, activity A has begun", "1234 ... <), 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'...' 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.", " '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 case (readConf args) of Conf conf -> do let render = case (outFormat conf) of { PNG -> \c w h f -> const () `fmap` renderableToPNGFile c w h f; PDF -> renderableToPDFFile ; PS -> renderableToPSFile ; SVG -> renderableToSVGFile ; #if HAVE_GTK Window -> \c w h f -> renderableToWindow c w h #endif } case conf of ConcreteConf { parseTime=parseTime, inFile=inFile, chartKindF=chartKindF, outFile=outFile, outResolution=outResolution, fromTime=fromTime, toTime=toTime, transformLabel=transformLabel} -> do source <- readSource parseTime inFile let source' = zoom source fromTime toTime let chart = makeChart chartKindF source' fromTime toTime transformLabel let (w,h) = outResolution render chart w h outFile