diff --git a/NEWS b/NEWS --- a/NEWS +++ b/NEWS @@ -1,3 +1,19 @@ +v0.2 2010-07-30 leaner and meaner + +Memory usage and speed have both been improved, in part by +reading the entire file into a strict ByteString and making +two parsing passes over it, where the first pass accumulates +statistics and the second pass extracts the relevant data to +arrays, thus avoid large intermediate data structures. + +Code abtraction has been improved, by separating the SVG +code into its own module and providing a Graphics interface, +so that later a PostScript implementation can be added more +easily. + +Source code statistics: 475 lines, 2854 words, 17007 chars. + + v0.1 2010-07-28 first release The result of a few days hacking, hp2pretty is born. Source code statistics: 397 lines, 2406 words, 14212 chars. diff --git a/README b/README --- a/README +++ b/README @@ -11,14 +11,15 @@ Benchmarks ----------- +========== -(updated 2010-07-28) +hp2pretty-0.1 +------------- $ wc in.hp 1484749 2969502 37406420 in.hp -$ time ./Main out.svg +$ time hp2pretty out.svg real 0m38.786s 0m39.423s 0m38.674s user 0m38.120s 0m38.800s 0m38.110s sys 0m00.360s 0m00.250s 0m00.400s @@ -35,5 +36,22 @@ Memory usage from 'top': hp2pretty ~275M hp2ps ~50M + +Tests were run on 64bit GNU/Linux with ghc-6.12.3. + + +hp2pretty-0.2 +------------- + +"in.hp" time (seconds) memory (bytes) +(bytes) hp2pretty hp2ps hp2pretty hp2ps + 37M 33.345 36.430 64M 25M + 1.3M 1.015 0.074 2.2M 1.0M + 47k 0.058 0.005 210k 60k + +Time is real time averaged over 3 runs as measured by 'bash'. +Memory is peak usage as measured by 'valgrind --tool=massif'. + +hp2pretty compiled via cabal-install with 'ghc -O --make'. Tests were run on 64bit GNU/Linux with ghc-6.12.3. diff --git a/hp2pretty.cabal b/hp2pretty.cabal --- a/hp2pretty.cabal +++ b/hp2pretty.cabal @@ -1,5 +1,5 @@ Name: hp2pretty -Version: 0.1 +Version: 0.2 Synopsis: generate pretty graphs from heap profiles Description: hp2pretty is a rewrite of hp2ps, implemented in Haskell, with the aims of being maintainable, with more flexible output, and @@ -22,13 +22,18 @@ Executable hp2pretty Build-depends: base >= 4 && < 5, array, bytestring, containers, mtl + GHC-options: -Wall + GHC-prof-options: -prof -auto-all HS-source-dirs: src Main-is: Main.hs - Other-modules: Parse - Process + Other-modules: Types + Total + Prune + Bands Pretty Print - Types + SVG + Graphics Source-repository head type: git @@ -37,4 +42,4 @@ Source-repository this type: git location: git://gitorious.org/hp2pretty/hp2pretty.git - tag: v0.1 + tag: v0.2 diff --git a/src/Bands.hs b/src/Bands.hs new file mode 100644 --- /dev/null +++ b/src/Bands.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE BangPatterns #-} +module Bands (bands) where + +import Control.Monad (forM_) +import Control.Monad.ST (runST) +import Data.Array.Base (unsafeFreezeSTUArray) +import Data.Array.ST (writeArray, readArray, newArray) +import Data.Array.Unboxed (UArray) +import Data.Map (Map, lookup, size) +import Numeric (readSigned, readFloat) +import Prelude hiding (lookup, lines, words, length) +import Data.ByteString.Char8 (ByteString, pack, unpack, lines, words, isPrefixOf, length) +import qualified Data.ByteString.Char8 as BS + +import Types + +bands :: Header -> Map ByteString Int -> ByteString -> (UArray Int Double, UArray (Int, Int) Double) +bands h bs input = runST $ do + times <- newArray (1, hCount h) 0 + vals <- newArray ((-1,1), (size bs, hCount h)) 0 + forM_ (zip [1 ..] . chunkSamples . drop 4 . lines $ input) $ \(i, (t:ss)) -> do + writeArray times i (sampleTime sBEGIN_SAMPLE t) + forM_ ss $ \s -> do + let [k,vs] = words s + !v = readDouble vs + case k `lookup` bs of + Nothing -> writeArray vals (0, i) . (+ v) =<< readArray vals (0, i) + Just b -> writeArray vals (b, i) v + times' <- unsafeFreezeSTUArray times + vals' <- unsafeFreezeSTUArray vals + return (times', vals') + +chunkSamples :: [ByteString] -> [[ByteString]] +chunkSamples [] = [] +chunkSamples (x:xs) + | sBEGIN_SAMPLE `isPrefixOf` x = + let (ys, zs) = break (sEND_SAMPLE `isPrefixOf`) xs + in case zs of + [] -> [] -- discard incomplete sample + (_:ws) -> (x:ys) : chunkSamples ws + | otherwise = [] -- expected BEGIN_SAMPLE or EOF... + +sampleTime :: ByteString -> ByteString -> Double +sampleTime name h = + if name `isPrefixOf` h + then readDouble . BS.drop (length name + 1) $ h + else error $ "Parse.sampleTime: expected " ++ unpack name ++ " but got " ++ unpack h + +readDouble :: ByteString -> Double +readDouble s = case readSigned readFloat (unpack s) of + ((x,_):_) -> x + _ -> error $ "Parse.readDouble: no parse " ++ unpack s + +sBEGIN_SAMPLE, sEND_SAMPLE :: ByteString +sBEGIN_SAMPLE = pack "BEGIN_SAMPLE" +sEND_SAMPLE = pack "END_SAMPLE" diff --git a/src/Graphics.hs b/src/Graphics.hs new file mode 100644 --- /dev/null +++ b/src/Graphics.hs @@ -0,0 +1,57 @@ +module Graphics where + +import Data.ByteString.Char8 (ByteString) + +type Point = (Double, Double) +type Size = (Double, Double) +type Angle = Double + +type FontSize = Double +data Anchor = Start | Middle | End + +type StrokeWidth = Double +type Opacity = Double +data RGB = RGB Double Double Double + +data Graphics = + Graphics + { text :: Maybe Angle -> Anchor -> FontSize -> Point -> [ByteString] -> [ByteString] + , rect :: Point -> Size -> [ByteString] + , line :: Point -> Point -> [ByteString] + , polygon :: [Point] -> [ByteString] + , visual :: Maybe RGB -> Maybe Opacity -> Maybe RGB -> Maybe StrokeWidth -> [ByteString] -> [ByteString] + , document :: Size -> [ByteString] -> [ByteString] + } + +rescalePoint :: (Point,Point) -> (Point,Point) -> Point -> Point +rescalePoint ((inX0,inY0),(inX1,inY1)) ((outX0,outY0),(outX1,outY1)) (x,y) = + let inW = inX1 - inX0 + inH = inY1 - inY0 + outW = outX1 - outX0 + outH = outY1 - outY0 + in ((x - inX0) / inW * outW + outX0, (y - inY0) / inH * outH + outY0) + +black, white :: RGB +black = RGB 0 0 0 +white = RGB 1 1 1 + +colours :: [RGB] +colours = map hueToRGB [0, 2 * pi / (phi * phi) ..] + where + phi = (sqrt 5 + 1) / 2 + hueToRGB h = + let s = 1 + v = 1 + hh = h * 3 / pi + i = floor hh `mod` 6 :: Int + f = hh - fromIntegral (floor hh :: Int) + p = v * (1 - s) + q = v * (1 - s * f) + t = v * (1 - s * (1 - f)) + in case i of + 0 -> RGB v t p + 1 -> RGB q v p + 2 -> RGB p v t + 3 -> RGB p q v + 4 -> RGB t p v + _ -> RGB v p q diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -1,12 +1,21 @@ -module Main where +module Main (main) where -import Prelude hiding (print, interact) -import Data.ByteString.Lazy.Char8(interact) +import Prelude hiding (print, getContents, putStr) +import Data.ByteString.Char8 (getContents, putStr) -import Parse (parse) -import Process (process) +import Total (total) +import Prune (prune) +import Bands (bands) import Pretty (pretty) import Print (print) +import SVG (svg) main :: IO () -main = interact $ print . pretty . process . parse +main = do + input <- getContents + let (header, totals) = total input + keeps = prune totals + (times, vals) = bands header keeps input + ((sticks, vticks), (labels, coords)) = pretty header vals keeps + outputs = print svg header sticks vticks labels times coords + mapM_ putStr outputs diff --git a/src/Parse.hs b/src/Parse.hs deleted file mode 100644 --- a/src/Parse.hs +++ /dev/null @@ -1,101 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -module Parse where - -import Control.Monad.State.Strict (State(), runState, get, put) -import Control.Monad (foldM) -import Data.Map (Map, empty, insertWith', alter, (!)) -import Numeric (readSigned, readFloat) -import Prelude hiding (lines, words, drop, length) -import Data.ByteString.Lazy.Char8 (ByteString, pack, unpack, lines, words, isPrefixOf, drop, length) - -import Types - -data Parse = - Parse - { symbols :: !(Map ByteString ByteString) -- intern symbols to save RAM - , totals :: !(Map ByteString Double ) -- compute running totals - } - deriving (Read, Show, Eq, Ord) - -parse0 :: Parse -parse0 = Parse{ symbols = empty, totals = empty } - -parse :: ByteString -> Run -parse s = - let ls = lines s - (hs, ss) = splitAt 4 ls - [job, date, smpU, valU] = - zipWith header [sJOB, sDATE, sSAMPLE_UNIT, sVALUE_UNIT] hs - (frames, parse1) = flip runState parse0 . mapM parseFrame . chunkSamples $ ss - in Run - { hprJob = job - , hprDate = date - , hprSampleUnit = smpU - , hprValueUnit = valU - , hprFrames = frames - , hprTotals = totals parse1 - } - -header :: ByteString -> ByteString -> ByteString -header name h = - if name `isPrefixOf` h - then pack . read . unpack . drop (length name + 1) $ h - else error $ "Parse.header: expected " ++ unpack name - -chunkSamples :: [ByteString] -> [[ByteString]] -chunkSamples [] = [] -chunkSamples (x:xs) - | sBEGIN_SAMPLE `isPrefixOf` x = - let (ys, zs) = break (sEND_SAMPLE `isPrefixOf`) xs - in case zs of - [] -> [] -- discard incomplete sample - (_:ws) -> (x:ys) : chunkSamples ws - | otherwise = [] -- expected BEGIN_SAMPLE or EOF... - -parseFrame :: [ByteString] -> State Parse Frame -parseFrame [] = error "Parse.parseFrame: empty" -parseFrame (l:ls) = do - let time = sampleTime sBEGIN_SAMPLE l - samples <- foldM inserter empty ls - return Frame - { hpfTime = time - , hpfSamples = samples - } - -inserter :: Map ByteString Double -> ByteString -> State Parse (Map ByteString Double) -inserter !m s = do - let [k,vs] = words s - !v = readDouble vs - p <- get - let symbols' = alter (intern k) k (symbols p) - totals' = alter (accum v) k (totals p) - put $! p{ symbols = symbols', totals = totals' } - p' <- get - return $! insertWith' (+) (symbols p' ! k) v m - -intern :: ByteString -> Maybe ByteString -> Maybe ByteString -intern s Nothing = Just s -intern _ js = js - -accum :: Double -> Maybe Double -> Maybe Double -accum x Nothing = Just x -accum x (Just y) = Just $! x + y - -sampleTime :: ByteString -> ByteString -> Double -sampleTime name h = - if name `isPrefixOf` h - then readDouble . drop (length name + 1) $ h - else error $ "Parse.sampleTime: expected " ++ unpack name ++ " but got " ++ unpack h - -readDouble :: ByteString -> Double -readDouble s = case readSigned readFloat (unpack s) of - ((x,_):_) -> x - _ -> error $ "Parse.readDouble: no parse " ++ unpack s - -sJOB, sDATE, sSAMPLE_UNIT, sVALUE_UNIT, sBEGIN_SAMPLE, sEND_SAMPLE :: ByteString -sJOB = pack "JOB" -sDATE = pack "DATE" -sSAMPLE_UNIT = pack "SAMPLE_UNIT" -sVALUE_UNIT = pack "VALUE_UNIT" -sBEGIN_SAMPLE = pack "BEGIN_SAMPLE" -sEND_SAMPLE = pack "END_SAMPLE" diff --git a/src/Pretty.hs b/src/Pretty.hs --- a/src/Pretty.hs +++ b/src/Pretty.hs @@ -1,41 +1,30 @@ -module Pretty where +module Pretty (pretty) where import Control.Monad (forM_, liftM2) -import Data.Array.ST -import Data.Array.Unboxed (UArray) -import Data.ByteString.Lazy.Char8 (pack) +import Data.Array.MArray (thaw) +import Data.Array.ST (runSTUArray, writeArray, readArray) +import Data.Array.Unboxed (UArray, bounds) +import Data.ByteString.Char8 (ByteString, pack) +import Data.List (sortBy) +import Data.Map (Map, toList) +import Data.Ord (comparing) import Types -pretty :: Info -> Graph -pretty hpi = - let sticks = uncurry (ticks 20) (hpiSampleRange hpi) - vticks = uncurry (ticks 20) (hpiValueRange hpi) - labels = pack "(trace elements)" : (reverse . map fst . hpiValues) hpi - values = hpiTrace hpi : (reverse . map snd . hpiValues) hpi - bands = accumulate values - in Graph - { hpgJob = hpiJob hpi - , hpgDate = hpiDate hpi - , hpgSampleUnit = hpiSampleUnit hpi - , hpgValueUnit = hpiValueUnit hpi - , hpgSampleRange= hpiSampleRange hpi - , hpgValueRange = hpiValueRange hpi - , hpgSampleTicks= sticks - , hpgValueTicks = vticks - , hpgLabels = labels - , hpgBands = bands - , hpgSamples = hpiSamples hpi - } +pretty :: Header -> UArray (Int, Int) Double -> Map ByteString Int -> (([Double], [Double]), ([ByteString], UArray (Int, Int) Double)) +pretty header vals bs = + let sticks = uncurry (ticks 20) (hSampleRange header) + vticks = uncurry (ticks 20) (hValueRange header) + labels = pack "(trace elements)" : (map fst . sortBy (comparing snd) . toList $ bs) + coords = accumulate vals + in ((sticks, vticks), (labels, coords)) -accumulate :: [[Double]] -> UArray (Int, Int) Double -accumulate [] = error $ "accumulate': empty" -accumulate xss@(x:_) = runSTUArray $ do - let bands = length xss - samples = length x - a <- newListArray ((0,1),(bands,samples)) $ replicate samples 0 ++ concat xss - forM_ [1 .. samples] $ \s -> - forM_ [1 .. bands] $ \b -> +accumulate :: UArray (Int, Int) Double -> UArray (Int, Int) Double +accumulate a0 = runSTUArray $ do + let ((b0,s0),(b1,s1)) = bounds a0 + a <- thaw a0 + forM_ [s0 .. s1] $ \s -> + forM_ [b0 + 1 .. b1] $ \b -> writeArray a (b, s) =<< liftM2 (+) (readArray a (b - 1, s)) (readArray a (b, s)) return a diff --git a/src/Print.hs b/src/Print.hs --- a/src/Print.hs +++ b/src/Print.hs @@ -1,139 +1,84 @@ -{-# LANGUAGE OverloadedStrings #-} -module Print where +module Print (print) where -import Prelude hiding (concat, unlines) -import qualified Prelude as P -import Data.Array.Unboxed (bounds, (!)) -import Data.ByteString.Lazy.Char8 (ByteString, pack, concat) -import Numeric (showHex, showFFloat) +import Prelude hiding (print) +import Data.Array.Unboxed (UArray, bounds, (!)) +import Data.ByteString.Char8 (ByteString, pack) +import Numeric (showFFloat) import Types +import Graphics -print :: Graph -> ByteString -print hpg = - let fwd = hpgSamples hpg - rwd = reverse fwd --)) (hpgBands hpg) - ((b0,s0),(b1,s1)) = bounds (hpgBands hpg) - bands = - [ (fwd ++ rwd) `zip` (bfwd ++ brwd) - | b <- [b0 + 1 .. b1] - , let bfwd = [ hpgBands hpg ! (b - 1, s) | s <- [s0 .. s1] ] - , let brwd = [ hpgBands hpg ! (b, s) | s <- [s1, s1 - 1 .. s0] ] - ] -- zipWith (\s t -> s ++ reverse t) paths (tail paths) - polygons = zipWith polygon colours . map (map p) . reverse $ bands - key = zipWith3 (keyBox (gW + border * 2.5) (border * 1.5) (gH / 16)) [0..] colours . reverse . hpgLabels $ hpg +print :: Graphics -> Header -> [Double] -> [Double] -> [ByteString] -> UArray Int Double -> UArray (Int, Int) Double -> [ByteString] +print gfx header sticks vticks labels times coords = + let bands = toPoints (bounds coords) times coords + filled c = visual gfx (Just c) Nothing Nothing Nothing + polygons = concat . zipWith (\c ps -> filled c (polygon gfx ps)) colours . map (map p) $ bands + key = concat . zipWith3 (keyBox (gW + border * 2.5) (border * 1.5) (gH / 16)) [(0::Int) ..] colours . reverse $ labels + keyBox x y0 dy i c l = + let y = y0 + fromIntegral i * dy + in (filled c $ rect gfx (x, y + 0.1 * dy) (dy * 0.8, dy * 0.8)) ++ + text gfx Nothing Start 15 (x + dy, y + dy * 0.6) [l] w = 1280 h = 720 gW = 960 - 2 * border gH = 720 - 3 * border border = 60 textOffset = 10 - (xMin, xMax) = hpgSampleRange hpg - (yMin, yMax) = hpgValueRange hpg + (xMin, xMax) = hSampleRange header + (yMin, yMax) = hValueRange header gRange@((gx0,gy0),(gx1,gy1)) = ((border*1.5, gH + border*1.5), (gW + border*1.5, border*1.5)) p = rescalePoint ((xMin, yMin), (xMax, yMax)) gRange - title = [ "" , hpgJob hpg , " (" , hpgDate hpg , ")" ] - background = [ "" ] - box = [ "" ] - gStart = [ "" ] - leftLabel = [ "" , hpgValueUnit hpg , "" ] - leftTicks = map (\(y,l) -> let { (x1, y1) = p (xMin, y) ; (x2, y2) = p (xMax, y) } in - [ "" ] ++ - if l then [] else [ "" , showSI y , "" ] - ) (zip (hpgValueTicks hpg) (replicate (length (hpgValueTicks hpg) - 1) False ++ [True])) - bottomLabel = [ "" , hpgSampleUnit hpg , "" ] - bottomTicks = map (\(x,l) -> let { (x1, y1) = p (x, yMin) ; (x2, y2) = p (x, yMax) } in - [ "" ] ++ - if l then [] else [ "" , showSI x , "" ] - ) (zip (hpgSampleTicks hpg) (replicate (length (hpgSampleTicks hpg) - 1) False ++ [True])) - gEnd = [ "" ] - in concat . P.concat $ [ xmldecl, svgStart w h, background, gStart, title, leftLabel, P.concat leftTicks, bottomLabel, P.concat bottomTicks, box, P.concat polygons, P.concat key, gEnd, svgEnd ] - -showSI :: Double -> ByteString -showSI x | x < 1e3 = showF x - | x < 1e6 = concat [ showF (x/1e3 ) , "k" ] - | x < 1e9 = concat [ showF (x/1e6 ) , "M" ] - | x < 1e12 = concat [ showF (x/1e9 ) , "G" ] - | x < 1e15 = concat [ showF (x/1e12) , "T" ] - | otherwise = concat [ showF (x/1e15) , "P" ] - -showF :: Double -> ByteString -showF x = pack $ showFFloat Nothing x "" - -showI :: Int -> ByteString -showI x = pack $ show x - -keyBox :: Double -> Double -> Double -> Int -> ByteString -> ByteString -> [ByteString] -keyBox x y0 dy i c l = - let y = y0 + fromIntegral i * dy - in [ "" - , "" , l , "" ] - -polygon :: ByteString -> [(Double,Double)] -> [ByteString] -polygon c ps = [ "" ] - -path :: [(Double,Double)] -> [ByteString] -path [] = error "Print.path: []" -path (p0:ps) = - let lineTo p = [ " L " ] ++ toSVGPoint p - in [ "M " ] ++ toSVGPoint p0 ++ concatMap lineTo (ps ++ [p0]) ++ [ " Z" ] - -rescalePoint :: ((Double,Double),(Double,Double)) -> ((Double,Double),(Double,Double)) -> (Double, Double) -> (Double,Double) -rescalePoint ((inX0,inY0),(inX1,inY1)) ((outX0,outY0),(outX1,outY1)) (x,y) = - let inW = inX1 - inX0 - inH = inY1 - inY0 - outW = outX1 - outX0 - outH = outY1 - outY0 - in ((x - inX0) / inW * outW + outX0, (y - inY0) / inH * outH + outY0) - -toSVGPoint :: (Double,Double) -> [ByteString] -toSVGPoint (x,y) = [ showF x , "," , showF y ] - -xmldecl :: [ByteString] -xmldecl = [ "" ] - -svgStart :: Int -> Int -> [ByteString] -svgStart w h = [ "" ] - -svgEnd :: [ByteString] -svgEnd = [ "" ] - -phi :: Double -phi = (sqrt 5 + 1) / 2 - -hues :: [Double] -hues = [0, 2 * pi / (phi * phi) ..] - -sats :: [Double] -sats = repeat 1 - -vals :: [Double] -vals = repeat 1 - -wrap :: Double -> Double -wrap x = x - fromIntegral (floor x :: Int) - -colours :: [ByteString] -colours = map toSVGColour $ zipWith3 toRGB hues sats vals + title = text gfx Nothing Middle 25 (w / 2, border * 0.75) [hJob header, pack " (", hDate header, pack ")"] + background = filled white $ rect gfx (0,0) (w,h) + box = filled white $ rect gfx (gx0,gy1) (gW,gH) + leftLabel = text gfx (Just (-90)) Middle 20 (border/2, (gy0 + gy1)/2) [hValueUnit header] + leftTicks = concatMap (\(y,l) -> let { (x1, y1) = p (xMin, y) ; (x2, y2) = p (xMax, y) } in + line gfx (x1 - border/2, y1) (x2, y2) ++ + if l then [] else text gfx Nothing End 15 (x1 - textOffset, y1 - textOffset) (showSI y) + ) (zip vticks (replicate (length vticks - 1) False ++ [True])) + bottomLabel = text gfx Nothing Middle 20 ((gx0 + gx1)/2, gy0 + border) [hSampleUnit header] + bottomTicks = concatMap (\(x,l) -> let { (x1, y1) = p (x, yMin) ; (x2, y2) = p (x, yMax) } in + line gfx (x1, y1 + border/2) (x2, y2) ++ + if l then [] else text gfx Nothing Start 15 (x1 + textOffset, y1+2*textOffset) (showSI x) + ) (zip sticks (replicate (length sticks - 1) False ++ [True])) + in document gfx (w,h) . concat $ + [ background + , visual gfx (Just black) Nothing (Just black) (Just 1) $ concat + [ title + , leftLabel + , bottomLabel + , leftTicks + , bottomTicks + , visual gfx Nothing (Just 0.7) Nothing Nothing $ concat + [ box + , polygons + , key + ] + ] + ] -toRGB :: Double -> Double -> Double -> (Double, Double, Double) -toRGB h s v = - let hh = h * 3 / pi - i = floor hh `mod` 6 :: Int - f = hh - fromIntegral (floor hh :: Int) - p = v * (1 - s) - q = v * (1 - s * f) - t = v * (1 - s * (1 - f)) - in case i of - 0 -> (v,t,p) - 1 -> (q,v,p) - 2 -> (p,v,t) - 3 -> (p,q,v) - 4 -> (t,p,v) - _ -> (v,p,q) +toPoints :: ((Int,Int),(Int,Int)) -> UArray Int Double -> UArray (Int,Int) Double -> [[(Double,Double)]] +toPoints ((b0,s0),(b1,s1)) times coords = + [ fwd ++ rwd + | b <- [b1, b1 - 1 .. b0 + 1] + , let fwd = [ (times ! s, coords ! (b - 1, s)) | s <- up b ] + , let rwd = [ (times ! s, coords ! (b, s)) | s <- down b ] + ] + where + -- ugly hack to force recomputation instead of sharing a large list + up b = [s0 + b - b .. s1] + down b = [s1 + b - b, s1 - 1 .. s0] -toSVGColour :: (Double, Double, Double) -> ByteString -toSVGColour (r,g,b) = - let toInt x = let y = floor (256 * x) in 0 `max` y `min` 255 :: Int - hex2 i = (if i < 16 then ('0':) else id) (showHex i "") - in pack $ '#' : concatMap (hex2 . toInt) [r,g,b] +showSI :: Double -> [ByteString] +showSI x | x < 1e3 = [ showF x "" ] + | x < 1e6 = [ showF (x/1e3 ) "k" ] + | x < 1e9 = [ showF (x/1e6 ) "M" ] + | x < 1e12 = [ showF (x/1e9 ) "G" ] + | x < 1e15 = [ showF (x/1e12) "T" ] + | otherwise = [ showF (x/1e15) "P" ] + where + showF y si = let (xs, ys) = break ('.' ==) $ showFFloat (Just 3) y "" + zs = reverse . dropWhile ('0' ==) . reverse . drop 1 $ ys + in case zs of + "" -> pack $ xs ++ si + ws -> pack $ xs ++ "." ++ ws ++ si diff --git a/src/Process.hs b/src/Process.hs deleted file mode 100644 --- a/src/Process.hs +++ /dev/null @@ -1,39 +0,0 @@ -module Process where - -import Control.Arrow ((&&&)) -import Data.List (foldl', sortBy) -import Data.Map (toList, fromList, difference, elems, findWithDefault) -import Data.Ord (comparing) - -import Types - -process :: Run -> Info -process hpr = - let frames = hprFrames hpr - samples = map hpfSamples frames - ccTotals = sortBy (flip $ comparing snd) (toList $ hprTotals hpr) - sizes = map snd ccTotals - total = sum' sizes - limit = 0.99 * total - bigs = takeWhile (< limit) . drop 1 . scanl (+) 0 $ sizes - bands = zipWith const ccTotals $ take 15 bigs - ccs = map fst bands - ccsMap = fromList . map (\c -> (c, ())) $ ccs - sr = (minimum &&& maximum) . map hpfTime $ frames - vr = (0, maximum . map (sum . elems) $ samples) - values = [ (c, [ findWithDefault 0 c m | m <- samples ]) | c <- ccs ] - traces = map (sum' . elems . (`difference` ccsMap)) samples - in Info - { hpiJob = hprJob hpr - , hpiDate = hprDate hpr - , hpiSampleUnit = hprSampleUnit hpr - , hpiValueUnit = hprValueUnit hpr - , hpiSampleRange= sr - , hpiValueRange = vr - , hpiSamples = map hpfTime frames - , hpiValues = values - , hpiTrace = traces - } - -sum' :: [Double] -> Double -sum' = foldl' (+) 0 diff --git a/src/Prune.hs b/src/Prune.hs new file mode 100644 --- /dev/null +++ b/src/Prune.hs @@ -0,0 +1,20 @@ +module Prune (prune) where + +import Data.ByteString.Char8 (ByteString) +import Data.List (foldl', sortBy) +import Data.Ord (comparing) +import Data.Map (Map, toList, fromList) + +prune :: Map ByteString Double -> Map ByteString Int +prune ts = + let ccTotals = sortBy (flip $ comparing snd) (toList ts) + sizes = map snd ccTotals + total = sum' sizes + limit = 0.99 * total + bigs = takeWhile (< limit) . scanl (+) 0 $ sizes + bands = zipWith const ccTotals $ take 15 bigs + ccs = map fst bands + in fromList (reverse ccs `zip` [1 ..]) + +sum' :: [Double] -> Double +sum' = foldl' (+) 0 diff --git a/src/SVG.hs b/src/SVG.hs new file mode 100644 --- /dev/null +++ b/src/SVG.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE OverloadedStrings #-} +module SVG (svg) where + +import Data.ByteString.Char8 (ByteString, pack) +import Numeric (showHex, showFFloat) + +import Graphics (Graphics(Graphics), Point, Size, Angle, FontSize, Anchor(..), StrokeWidth, Opacity, RGB(..)) +import qualified Graphics as G + +svg :: Graphics +svg = + Graphics + { G.text = text + , G.rect = rect + , G.line = line + , G.polygon = polygon + , G.visual = visual + , G.document = document + } + +text :: Maybe Angle -> Anchor -> FontSize -> Point -> [ByteString] -> [ByteString] +text r a s (x,y) inner = + let coords = case r of + Nothing -> ["x='", showF x, "' y='", showF y, "'"] + Just ra -> ["transform='translate(" , showF x, "," , showF y, ") rotate(", showF ra, ")'"] + showAnchor Start = "start" + showAnchor Middle = "middle" + showAnchor End = "end" + in [""] ++ inner ++ ["\n"] + +rect :: Point -> Size -> [ByteString] +rect (x,y) (w,h) = ["\n"] + +line :: Point -> Point -> [ByteString] +line (x1,y1) (x2,y2) = ["\n"] + +visual :: Maybe RGB -> Maybe Opacity -> Maybe RGB -> Maybe StrokeWidth -> [ByteString] -> [ByteString] +visual mfill mfillo mstroke mstrokew inner = + let fill = maybe [] (\f -> [" fill='", showRGB f, "'"]) mfill + fillo = maybe [] (\o -> [" fill-opacity='", showF o, "'"]) mfillo + stroke = maybe [] (\s -> [" stroke='", showRGB s, "'"]) mstroke + strokew = maybe [] (\w -> [" stroke-width='", showF w, "'"]) mstrokew + in ["\n"] ++ inner ++ ["\n"] + +document :: Size -> [ByteString] -> [ByteString] +document (w,h) inner = + [ "\n" + , "\n" + ] ++ inner ++ ["\n"] + +polygon :: [Point] -> [ByteString] +polygon ps = [""] + +path :: [(Double,Double)] -> [ByteString] +path [] = error "SVG.path: empty" +path (p0:ps) = + let lineTo p = [ " L " ] ++ showP p + in [ "M " ] ++ showP p0 ++ concatMap lineTo (ps ++ [p0]) ++ [ " Z" ] + +showRGB :: RGB -> ByteString +showRGB (RGB r g b) = + let toInt x = let y = floor (256 * x) in 0 `max` y `min` 255 :: Int + hex2 i = (if i < 16 then ('0':) else id) (showHex i "") + in pack $ '#' : concatMap (hex2 . toInt) [r,g,b] + +showP :: Point -> [ByteString] +showP (x,y) = [showF x, ",", showF y] + +showF :: Double -> ByteString +showF x = pack $ showFFloat Nothing x "" diff --git a/src/Total.hs b/src/Total.hs new file mode 100644 --- /dev/null +++ b/src/Total.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE BangPatterns #-} +module Total (total) where + +import Control.Monad.State.Strict (State(), execState, get, put) +import Data.List (foldl') +import Data.Map (Map, empty, lookup, insert, alter) +import Numeric (readSigned, readFloat) +import Prelude hiding (lookup, lines, words, drop, length) +import Data.ByteString.Char8 (ByteString, pack, unpack, lines, words, isPrefixOf, drop, length) + +import Types + +data Parse = + Parse + { symbols :: !(Map ByteString ByteString) -- intern symbols to save RAM + , totals :: !(Map ByteString Double ) -- compute running totals + , sampleMin :: !Double + , sampleMax :: !Double + , valueMin :: !Double + , valueMax :: !Double + , count :: !Int -- number of frames + } + +parse0 :: Parse +parse0 = Parse{ symbols = empty, totals = empty, sampleMin = 0, sampleMax = 0, valueMin = 0, valueMax = 0, count = 0 } + +total :: ByteString -> (Header, Map ByteString Double) +total s = + let ls = lines s + (hs, ss) = splitAt 4 ls + [job, date, smpU, valU] = + zipWith header [sJOB, sDATE, sSAMPLE_UNIT, sVALUE_UNIT] hs + parse1 = flip execState parse0 . mapM_ parseFrame . chunkSamples $ ss + in ( Header + { hJob = job + , hDate = date + , hSampleUnit = smpU + , hValueUnit = valU + , hSampleRange= (sampleMin parse1, sampleMax parse1) + , hValueRange = (valueMin parse1, valueMax parse1) + , hCount = count parse1 + } + , totals parse1 + ) + +header :: ByteString -> ByteString -> ByteString +header name h = + if name `isPrefixOf` h + then pack . read . unpack . drop (length name + 1) $ h + else error $ "Parse.header: expected " ++ unpack name + +chunkSamples :: [ByteString] -> [[ByteString]] +chunkSamples [] = [] +chunkSamples (x:xs) + | sBEGIN_SAMPLE `isPrefixOf` x = + let (ys, zs) = break (sEND_SAMPLE `isPrefixOf`) xs + in case zs of + [] -> [] -- discard incomplete sample + (_:ws) -> (x:ys) : chunkSamples ws + | otherwise = [] -- expected BEGIN_SAMPLE or EOF... + +parseFrame :: [ByteString] -> State Parse () +parseFrame [] = error "Parse.parseFrame: empty" +parseFrame (l:ls) = do + let !time = sampleTime sBEGIN_SAMPLE l + samples <- mapM inserter ls + p <- get + let v = foldl' (+) 0 samples + sMin = if count p == 0 then time else time `min` sampleMin p + sMax = if count p == 0 then time else time `max` sampleMax p + vMin = v `min` valueMin p + vMax = v `max` valueMax p + put $! p{ count = count p + 1, sampleMin = sMin, sampleMax = sMax, valueMin = vMin, valueMax = vMax } + +inserter :: ByteString -> State Parse Double +inserter s = do + let [k,vs] = words s + !v = readDouble vs + p <- get + k' <- case lookup k (symbols p) of + Nothing -> do + put $! p{ symbols = insert k k (symbols p) } + return k + Just kk -> return kk + p' <- get + put $! p'{ totals = alter (accum v) k' (totals p') } + return $! v + +accum :: Double -> Maybe Double -> Maybe Double +accum x Nothing = Just x +accum x (Just y) = Just $! x + y + +sampleTime :: ByteString -> ByteString -> Double +sampleTime name h = + if name `isPrefixOf` h + then readDouble . drop (length name + 1) $ h + else error $ "Parse.sampleTime: expected " ++ unpack name ++ " but got " ++ unpack h + +readDouble :: ByteString -> Double +readDouble s = case readSigned readFloat (unpack s) of + ((x,_):_) -> x + _ -> error $ "Parse.readDouble: no parse " ++ unpack s + +sJOB, sDATE, sSAMPLE_UNIT, sVALUE_UNIT, sBEGIN_SAMPLE, sEND_SAMPLE :: ByteString +sJOB = pack "JOB" +sDATE = pack "DATE" +sSAMPLE_UNIT = pack "SAMPLE_UNIT" +sVALUE_UNIT = pack "VALUE_UNIT" +sBEGIN_SAMPLE = pack "BEGIN_SAMPLE" +sEND_SAMPLE = pack "END_SAMPLE" diff --git a/src/Types.hs b/src/Types.hs --- a/src/Types.hs +++ b/src/Types.hs @@ -1,53 +1,14 @@ module Types where -import Data.Array.Unboxed (UArray) -import Data.ByteString.Lazy.Char8(ByteString) -import Data.Map (Map) - -data Run = - Run - { hprJob :: ByteString - , hprDate :: ByteString - , hprSampleUnit :: ByteString - , hprValueUnit :: ByteString - , hprFrames :: [Frame] - , hprTotals :: Map ByteString Double - } - deriving (Read, Show, Eq, Ord) - -data Frame = - Frame - { hpfTime :: Double - , hpfSamples :: Map ByteString Double - } - deriving (Read, Show, Eq, Ord) - -data Info = - Info - { hpiJob :: ByteString - , hpiDate :: ByteString - , hpiSampleUnit :: ByteString - , hpiValueUnit :: ByteString - , hpiSampleRange:: (Double, Double) - , hpiValueRange :: (Double, Double) - , hpiSamples :: [Double] - , hpiValues :: [(ByteString, [Double])] - , hpiTrace :: [Double] - } - deriving (Read, Show, Eq, Ord) +import Data.ByteString.Char8 (ByteString) -data Graph = - Graph - { hpgJob :: ByteString - , hpgDate :: ByteString - , hpgSampleUnit :: ByteString - , hpgValueUnit :: ByteString - , hpgSampleRange:: (Double, Double) - , hpgValueRange :: (Double, Double) - , hpgSampleTicks:: [Double] - , hpgValueTicks :: [Double] - , hpgLabels :: [ByteString] - , hpgBands :: UArray (Int, Int) Double - , hpgSamples :: [Double] +data Header = + Header + { hJob :: ByteString + , hDate :: ByteString + , hSampleUnit :: ByteString + , hValueUnit :: ByteString + , hSampleRange :: (Double, Double) + , hValueRange :: (Double, Double) + , hCount :: Int } - deriving (Show, Eq, Ord)