diff --git a/Tools/StatePlot.hs b/Tools/StatePlot.hs --- a/Tools/StatePlot.hs +++ b/Tools/StatePlot.hs @@ -22,6 +22,7 @@ import Data.Colour import Data.Colour.Names + data Event = Event {time :: LocalTime, track :: String, edge :: Edge} deriving (Show) data Edge = Begin { color :: String } | End deriving (Show) @@ -45,35 +46,48 @@ diffToMillis t2 t1 = fromIntegral (truncate (1000000*d)) / 1000 where d = diffUTCTime (localTimeToUTC utc t2) (localTimeToUTC utc t1) -renderEvents :: Double -> Double -> Double -> [Event] -> (Event -> Event -> Ordering) -> Renderable () -renderEvents bandHeight ticksIntervalMs expireTimeMs es cmpTracks = Renderable {minsize = return (0,0), render = render'} +data TrackState = Phantom String | Active LocalTime String | Inactive deriving (Show) + +data RenderConfiguration = RenderConf { + barHeight :: Double, + tickIntervalMs :: Double, + expireTimeMs :: Double, + cmpTracks :: Event -> Event -> Ordering, + phantomColor :: Maybe String + } + +renderEvents :: RenderConfiguration -> [Event] -> Renderable () +renderEvents conf es = Renderable {minsize = return (0,0), render = render'} where events = sortBy (comparing time) es minTime = time $ head events maxTime = time $ last events time2ms t = diffToMillis t minTime rangeMs = time2ms maxTime - ticks = takeWhile ( cmpTracks (head as) (head bs)) . groupBy ((==) `on` track) . sortBy (comparing track) $ events + ticks = takeWhile ( cmpTracks conf (head as) (head bs)) . groupBy ((==) `on` track) . sortBy (comparing track) $ events - maybeM :: (Monad m) => (a -> m b) -> Maybe a -> m () - maybeM f Nothing = return () - maybeM f (Just x) = f x >> return () + initial = case phantomColor conf of { Nothing -> Inactive; Just c -> Phantom c } - bars track = execWriter . (`evalStateT` Nothing) . mapM_ step $ track++[Event maxTime undefined End] + bars track = execWriter . (`evalStateT` initial) . mapM_ step $ track++[Event maxTime undefined End] where step (Event t _ edge) = do - get >>= maybeM (\(t0,c0) -> tell $ if (time2ms t - time2ms t0 < expireTimeMs) - then [Bar (time2ms t0) (time2ms t) c0] - else [ExpiredBar (time2ms t0) (time2ms t0 + expireTimeMs) c0]) - put (case edge of { Begin c -> Just (t,c); End -> Nothing }) + s <- get + let barFrom t0 c0 = tell $ if (time2ms t - time2ms t0 < expireTimeMs conf) + then [Bar (time2ms t0) (time2ms t) c0] + else [ExpiredBar (time2ms t0) (time2ms t0 + expireTimeMs conf) c0] + case (s,edge) of + (Active t0 c0, _ ) -> barFrom t0 c0 + (Phantom c0, End) -> barFrom minTime c0 + _ -> return () + put (case edge of { Begin c -> Active t c; End -> Inactive}) render' (w,h) = do let ms2x ms = 10 + ms / rangeMs * (w - 10) let time2x t = ms2x (time2ms t) let numTracks = length tracks let yStep = (h-10) / fromIntegral (numTracks+1) - let track2y i = fromIntegral (i+1) * yStep - bandHeight/2 + let track2y i = fromIntegral (i+1) * yStep - (barHeight conf)/2 let drawTick ms = do { setLineStyle $ solidLine 1 (opaque black) ; moveTo $ Point (ms2x ms) (h-10) @@ -83,7 +97,7 @@ let drawBar i (Bar ms1 ms2 color) = do { setLineStyle $ solidLine 1 transparent ; setFillStyle $ solidFillStyle $ opaque $ fromMaybe (error $ "unknown color: " ++ color) (readColourName color) - ; fillPath (rectPath $ Rect (Point (ms2x ms1) (track2y i)) (Point (ms2x ms2) (track2y i + bandHeight))) + ; fillPath (rectPath $ Rect (Point (ms2x ms1) (track2y i)) (Point (ms2x ms2) (track2y i + (barHeight conf)/2))) } drawBar i (ExpiredBar ms1 ms2 color) = do { setLineStyle $ dashedLine 1 [3,3] (opaque $ fromMaybe (error $ "unknown color: " ++ color) (readColourName color)) @@ -93,7 +107,6 @@ ; strokePath [Point (ms2x ms2 + 5) (track2y i - 5), Point (ms2x ms2 - 5) (track2y i + 5)] } let drawTrack (i, es) = mapM_ (drawBar i) (bars es) - setFillStyle $ solidFillStyle (opaque white) fillPath $ rectPath $ Rect (Point 0 0) (Point w h) setLineStyle $ solidLine 1 (opaque black) @@ -124,6 +137,9 @@ " -expire - expire activities after given time period (in millis) - for instance,", " to account that if an activity doesn't tell you it's finished for too long,", " then it probably was killed.", + " -phantom COL - 'phantom color' - if a track starts from a '<' event, it is assumed that", + " the corresponding '>' event (not present in the log) was of color COL.", + " Useful if you're drawing pieces of large logs.", "", "Input is read from stdin. Example input (speaks for itself):", "2010-10-21 16:45:09,431 >foo green", @@ -144,8 +160,8 @@ ["--help"] -> showHelp >> exitSuccess _ -> return () let (w,h) = (read $ getArg "w" "640" args, read $ getArg "h" "480" args) - let bandHeight = read $ getArg "bh" "5" args - let ticksIntervalMs = read $ getArg "tickInterval" "10" args + let barHeight = read $ getArg "bh" "5" args + let tickIntervalMs = read $ getArg "tickInterval" "10" args let timeFormat = getArg "tf" "%Y-%m-%d %H:%M:%OS" args let parseTime s = fromMaybe (error $ "Invalid time: " ++ show s) . strptime (B.pack timeFormat) $ s let outPNG = getArg "o" "" args @@ -153,7 +169,8 @@ let events = parse parseTime `map` B.lines input let cmpTracks = case getArg "sort" "time" args of { "time" -> comparing time ; "name" -> comparing track } let expireTimeMs = read $ getArg "expire" "Infinity" args - let pic = renderEvents bandHeight ticksIntervalMs expireTimeMs events cmpTracks + let phantomColor = case getArg "phantom" "" args of { "" -> Nothing; c -> Just c } + let pic = renderEvents (RenderConf barHeight tickIntervalMs expireTimeMs cmpTracks phantomColor) events case outPNG of "" -> renderableToWindow pic w h f -> const () `fmap` renderableToPNGFile pic w h outPNG diff --git a/splot.cabal b/splot.cabal --- a/splot.cabal +++ b/splot.cabal @@ -1,5 +1,5 @@ Name: splot -Version: 0.1.5 +Version: 0.1.6 License: BSD3 License-file: LICENSE Copyright: Eugene Kirpichov, 2010