diff --git a/Tools/StatePlot.hs b/Tools/StatePlot.hs --- a/Tools/StatePlot.hs +++ b/Tools/StatePlot.hs @@ -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 (( 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 (( 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 diff --git a/splot.cabal b/splot.cabal --- a/splot.cabal +++ b/splot.cabal @@ -1,5 +1,5 @@ Name: splot -Version: 0.1.19 +Version: 0.2.0 License: BSD3 License-file: LICENSE Copyright: Eugene Kirpichov, 2010