splot 0.1.19 → 0.2.0
raw patch · 2 files changed
+99/−47 lines, 2 files
Files
- Tools/StatePlot.hs +98/−46
- splot.cabal +1/−1
Tools/StatePlot.hs view
@@ -3,8 +3,7 @@ import System (getArgs) import System.Exit -import Control.Monad.Writer-import Control.Monad.State+import Control.Monad.RWS as RWS import qualified Data.Map as M import Data.List import Data.Ord@@ -14,7 +13,7 @@ import Data.Time import Data.Time.Parse -import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy.Char8 as B import Graphics.Rendering.Chart import Graphics.Rendering.Chart.Renderable import Graphics.Rendering.Chart.Gtk@@ -58,49 +57,20 @@ cmpTracks :: Event -> Event -> Ordering, phantomColor :: Maybe String, fromTime :: Maybe LocalTime,- toTime :: Maybe LocalTime+ toTime :: Maybe LocalTime,+ forcedNumTracks :: Maybe Int,+ streaming :: Bool } data TickSize = LargeTick | SmallTick -renderEvents :: RenderConfiguration -> [Event] -> Renderable ()-renderEvents conf es = Renderable {minsize = return (0,0), render = render'}+renderEvents :: RenderConfiguration -> IO [Event] -> Renderable ()+renderEvents conf readEs = Renderable {minsize = return (0,0), render = render' (c $ liftIO readEs)} where - events = sortBy (comparing time) es- minInputTime = time $ head events- maxInputTime = time $ last events- minRenderTime = case fromTime conf of { Nothing -> minInputTime; Just t -> t } - maxRenderTime = case toTime conf of { Nothing -> maxInputTime; Just t -> t } - time2ms t | t < minRenderTime = time2ms minRenderTime- | t > maxRenderTime = time2ms maxRenderTime- | otherwise = diffToMillis t minRenderTime- rangeMs = time2ms maxRenderTime- ticks = takeWhile ((<rangeMs).snd) $ - map (\i -> if i`mod`largeTickFreq conf == 0 - then (LargeTick, fromIntegral i*tickIntervalMs conf) - else (SmallTick, fromIntegral i*tickIntervalMs conf)) [0..]- tracks = sortBy (\as bs -> 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 () - bars track = execWriter . (`evalStateT` Nothing) . mapM_ step . prepare $ track- where- prepare t = (capStart t) ++ t ++ (capEnd t)- capEnd t = [Event maxInputTime undefined (End "")]- capStart t = case (phantomColor conf, t) of- (_, Event _ _ (End c):_) | c /= "" -> [Event minInputTime undefined (Begin c)]- (Just c, Event _ _ (End _):_) -> [Event minInputTime undefined (Begin c)]- _ -> []-- step (Event t _ edge) = do- let overrideEnd c0 = case edge of { End c | c /= "" -> c ; _ -> c0 }- get >>= maybeM (\(t0,c0) -> tell $ if (time2ms t - time2ms t0 < expireTimeMs conf) - then [Bar (time2ms t0) (time2ms t) (overrideEnd c0)]- else [ExpiredBar (time2ms t0) (time2ms t0 + expireTimeMs conf) (overrideEnd c0)])- put (case edge of { Begin c -> Just (t,c); End _ -> Nothing })- readColour ('#':r1:r2:g1:g2:b1:b2:[]) = Just (sRGB24 r g b) where r = fromIntegral $ unhex r2 + 16*unhex r1@@ -111,10 +81,69 @@ | c >= 'A' && c <= 'Z' = 10 + fromEnum c - fromEnum 'A' readColour cs = readColourName cs - render' (w,h) = do+ makeBars time2ms minRenderTime maxRenderTime es = snd $ RWS.execRWS (mapM_ step es >> flush) () M.empty+ where+ step e@(Event t track edge) = do+ (i, ms0) <- summon e+ flip maybeM ms0 $ \(t0,c0) -> do+ let overrideEnd c0 = case edge of { End c | c /= "" -> c ; _ -> c0 }+ if (time2ms t - time2ms t0 < expireTimeMs conf)+ then RWS.tell [(i, Bar (time2ms t0) (time2ms t) (overrideEnd c0))]+ else RWS.tell [(i, ExpiredBar (time2ms t0) (time2ms t0 + expireTimeMs conf) (overrideEnd c0))]+ putTrack track (i, case edge of { Begin c -> Just (t,c); End _ -> Nothing })+ + flush = RWS.gets M.keys >>= mapM_ flushTrack+ flushTrack track = do+ (i,ms0) <- RWS.gets (M.! track)+ flip maybeM ms0 $ \(t0,c0) -> RWS.tell [(i, Bar (time2ms t0) (time2ms maxRenderTime) c0)]++ putTrack track s = modify (M.insert track s)++ summon (Event t track edge) = do+ m <- RWS.get+ when (not (M.member track m)) $ do+ let i = M.size m+ RWS.put (M.insert track (i, Nothing) m)+ case (phantomColor conf, edge) of+ (_, End c) | c /= "" -> RWS.tell [(i, Bar (time2ms minRenderTime) (time2ms t) c)]+ (Just c, End _) -> RWS.tell [(i, Bar (time2ms minRenderTime) (time2ms t) c)]+ _ -> return ()+ RWS.gets (M.! track)++ render' :: CRender [Event] -> (Double,Double) -> CRender (PickFn a)+ render' readEs (w,h) = do+ es <- readEs+ minRenderTime <- case (fromTime conf, streaming conf) of { + (Just t, _) -> return t;+ (Nothing, True) -> fmap (minimum . map time) readEs; + (Nothing, False) -> return . minimum . map time $ es -- Will evaluate the whole of 'es' and hold it in memory+ } + maxRenderTime <- case (toTime conf, streaming conf) of { + (Just t, _) -> return t;+ (Nothing, True) -> fmap (maximum . map time) readEs; + (Nothing, False) -> return . maximum . map time $ es -- Same here.+ } ++ let time2ms t | t < minRenderTime = time2ms minRenderTime+ | t > maxRenderTime = time2ms maxRenderTime+ | otherwise = diffToMillis t minRenderTime+ let rangeMs = time2ms maxRenderTime+++ let numUnique xs = M.size $ M.fromList $ zip xs (repeat ())+ numTracks <- case (forcedNumTracks conf, streaming conf) of { + (Just n, _) -> return n;+ (Nothing, True) -> fmap (numUnique . map track) readEs;+ (Nothing, False) -> return . numUnique . map track $ es+ }++ let ticks = takeWhile ((<rangeMs).snd) $ + map (\i -> if i`mod`largeTickFreq conf == 0 + then (LargeTick, fromIntegral i*tickIntervalMs conf) + else (SmallTick, fromIntegral i*tickIntervalMs conf)) [0..]+ let ms2x ms = 10 + ms / rangeMs * (w - 10) let time2x t = ms2x (time2ms t)- let numTracks = length tracks let yStep = case barHeight conf of { BarHeightFixed _ -> (h-20) / fromIntegral (numTracks+1) ; BarHeightFill -> (h-20) / fromIntegral numTracks@@ -160,7 +189,7 @@ ; strokeLineAA (Point (ms2x ms2 - 5) (track2y i - 5)) (Point (ms2x ms2 + 5) (track2y i + 5)) ; strokeLineAA (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)@@ -173,15 +202,19 @@ moveTo (Point 10 (h-3)) c $ C.showText $ "Origin at " ++ show minRenderTime ++ ", 1 small tick = " ++ show (tickIntervalMs conf) ++ "ms" mapM_ drawTick ticks- mapM_ drawTrack $ zip [0..] tracks++ let bars = makeBars time2ms minRenderTime maxRenderTime es + mapM_ (\(i,e) -> drawBar i e) bars+ return nullPickFn showHelp = mapM_ putStrLn [ "splot - a tool for visualizing the lifecycle of many concurrent multi-stage processes. See http://www.haskell.org/haskellwiki/Splot", "Usage: splot [-if INFILE] [-o PNGFILE] [-w WIDTH] [-h HEIGHT] [-bh BARHEIGHT] ", " [-tf TIMEFORMAT] [-sort SORT] [-expire EXPIRE]",- " [-fromTime TIME] [-toTime TIME]",+ " [-fromTime TIME] [-toTime TIME] [-numTracks NUMTRACKS]", " [-tickInterval TICKINTERVAL] [-largeTickFreq N]",+ " [-stream true]", " -if INFILE - filename from where to read the trace.", " If omitted or '-', read from stdin.", " -o PNGFILE - filename to which the output will be written in PNG format.",@@ -204,6 +237,15 @@ " -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.",+ " -fromTime TIME - clip picture on left (time in same format as in trace)",+ " -toTime TIME - clip picture on right (time in same format as in trace)",+ " -numTracks NUMTRACKS - explicitly specify number of tracks when using '-stream true'",+ " -stream true - use 'streaming mode' where the input is not loaded into memory and you",+ " can process multi-gigabyte inputs.",+ " In this mode, you MUST use an actual filename in '-if'.",+ " Note that you better also indicate -fromTime, -toTime and -numTracks,",+ " otherwise the data will be re-scanned once per each of these properties",+ " that is not indicated.", "", "Input is read from stdin. Example input (speaks for itself):", "2010-10-21 16:45:09,431 >foo green",@@ -231,19 +273,29 @@ let tickIntervalMs = read $ getArg "tickInterval" "1000" args let largeTickFreq = read $ getArg "largeTickFreq" "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 ptime = strptime (B.pack timeFormat)+ let parseTime s = fromMaybe (error $ "Invalid time: " ++ show s) . ptime $ s let fromTime = fst `fmap` (strptime timeFormat $ getArg "fromTime" "" args) let toTime = fst `fmap` (strptime timeFormat $ getArg "toTime" "" args)+ let forcedNumTracks = case getArg "numTracks" "" args of { "" -> Nothing ; n -> Just $ read n } let outPNG = getArg "o" "" args let inputFile = getArg "if" "-" args- input <- if inputFile == "-" then B.getContents else B.readFile inputFile let pruneLF b | not (B.null b) && (B.last b == '\r') = B.init b | otherwise = b- let events = (parse parseTime . pruneLF) `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 phantomColor = case getArg "phantom" "" args of { "" -> Nothing; c -> Just c }- let pic = renderEvents (RenderConf barHeight tickIntervalMs largeTickFreq expireTimeMs cmpTracks phantomColor fromTime toTime) events+ let streaming = case getArg "stream" "false" args of { "true" -> True; _ -> False }++ let readInput = if inputFile == "-" then B.getContents else B.readFile inputFile+ let readEvents = (map (parse parseTime . pruneLF) . B.lines) `fmap` readInput+ + when (streaming && (inputFile == "-")) $ error "In streaming mode (-stream true) you MUST use an actual filename in '-if'"+ when (streaming && isNothing fromTime) $ putStrLn "Warning: without -fromTime, input will be re-scanned to compute it."+ when (streaming && isNothing toTime) $ putStrLn "Warning: without -toTime, input will be re-scanned to compute it."+ when (streaming && isNothing forcedNumTracks) $ putStrLn "Warning: without -numTracks, input will be re-scanned to compute it."++ let pic = renderEvents (RenderConf barHeight tickIntervalMs largeTickFreq expireTimeMs cmpTracks phantomColor fromTime toTime forcedNumTracks streaming) readEvents case outPNG of "" -> renderableToWindow pic w h f -> const () `fmap` renderableToPNGFile pic w h outPNG
splot.cabal view
@@ -1,5 +1,5 @@ Name: splot-Version: 0.1.19+Version: 0.2.0 License: BSD3 License-file: LICENSE Copyright: Eugene Kirpichov, 2010