packages feed

hp2pretty 0.1 → 0.2

raw patch · 14 files changed

+477/−360 lines, 14 files

Files

NEWS view
@@ -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.
README view
@@ -11,14 +11,15 @@   Benchmarks-----------+========== -(updated 2010-07-28)+hp2pretty-0.1+-------------  $ wc in.hp  1484749  2969502 37406420 in.hp -$ time ./Main <in.hp >out.svg+$ time hp2pretty <in.hp >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.
hp2pretty.cabal view
@@ -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
+ src/Bands.hs view
@@ -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"
+ src/Graphics.hs view
@@ -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
src/Main.hs view
@@ -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
− src/Parse.hs 
@@ -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"
src/Pretty.hs view
@@ -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
src/Print.hs view
@@ -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 = [ "<text font-size='25' text-anchor='middle' x='" , showF (fromIntegral w / 2) , "' y='" , showF (border * 0.75) , "'>" , hpgJob hpg , " (" , hpgDate hpg , ")</text>" ]-      background = [ "<rect fill='white' x='0' y='0' width='" , showI w , "' height='" , showI h , "' />" ]-      box = [ "<rect fill='white' x='" , showF gx0 , "' y='" , showF gy1 , "' width='" , showF gW , "' height='" , showF gH , "' />" ]-      gStart = [ "<g fill-opacity='0.5' fill='black' stroke='black' stroke-width='1'>" ]-      leftLabel = [ "<text font-size='20' text-anchor='middle' transform='translate(" , showF (border/2) , "," , showF ((gy0 + gy1)/2) , ") rotate(-90)'>" , hpgValueUnit hpg , "</text>" ]-      leftTicks = map (\(y,l) -> let { (x1, y1) = p (xMin, y) ; (x2, y2) = p (xMax, y) } in-          [ "<line x1='" , showF (x1 - border/2) , "' x2='" , showF x2 , "' y1='" , showF y1 , "' y2='" , showF y2 , "' />" ] ++-          if l then [] else [ "<text font-size='15' text-anchor='end'   x='" , showF (x1 - textOffset) , "' y='" , showF (y1 - textOffset) , "'>" , showSI y , "</text>" ]-        ) (zip (hpgValueTicks hpg) (replicate (length (hpgValueTicks hpg) - 1) False ++ [True]))-      bottomLabel = [ "<text font-size='20' text-anchor='middle' x='" , showF ((gx0 + gx1)/2) , "' y='" , showF (gy0 + border) , "'>" , hpgSampleUnit hpg , "</text>" ]-      bottomTicks = map (\(x,l) -> let { (x1, y1) = p (x, yMin) ; (x2, y2) = p (x, yMax) } in-          [ "<line y1='" , showF (y1 + border/2) , "' y2='" , showF y2 , "' x1='" , showF x1 , "' x2='" , showF x2 , "' />" ] ++-          if l then [] else [ "<text font-size='15' text-anchor='start' x='" , showF (x1 + textOffset) , "' y='" , showF (y1+2*textOffset) , "'>" , showSI x , "</text>" ]-        ) (zip (hpgSampleTicks hpg) (replicate (length (hpgSampleTicks hpg) - 1) False ++ [True]))-      gEnd = [ "</g>" ]-  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  [ "<rect fill-opacity='0.7' fill='" , c , "' x='" , showF x , "' y='" , showF (y + 0.1 * dy) , "' width='" , showF (dy * 0.8) , "' height='" , showF (dy * 0.8) , "' />"-      , "<text font-size='15' text-anchor='start' x='" , showF (x + dy) , "' y='" , showF (y + dy * 0.6) , "'>" , l , "</text>" ]--polygon :: ByteString -> [(Double,Double)] -> [ByteString]-polygon c ps = [ "<path fill-opacity='0.7' fill='" , c , "' d='" ] ++ path 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 = [ "<?xml version='1.0' encoding='UTF-8' ?>" ]--svgStart :: Int -> Int -> [ByteString]-svgStart w h = [ "<svg xmlns='http://www.w3.org/2000/svg' version='1.0' width='" , showI w , "' height='" , showI h , "'>" ]--svgEnd :: [ByteString]-svgEnd = [ "</svg>" ]--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
− src/Process.hs 
@@ -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
+ src/Prune.hs view
@@ -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
+ src/SVG.hs view
@@ -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  ["<text "] ++ coords ++ [" font-size='", showF s, "' text-anchor='", showAnchor a, "'>"] ++ inner ++ ["</text>\n"]++rect :: Point -> Size -> [ByteString]+rect (x,y) (w,h) = ["<rect x='", showF x, "' y='", showF y, "' width='" , showF w , "' height='" , showF h , "' />\n"]++line :: Point -> Point -> [ByteString]+line (x1,y1) (x2,y2) = ["<line x1='" , showF x1, "' x2='", showF x2, "' y1='", showF y1, "' y2='", showF 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 ["<g"] ++ fill ++ fillo ++ stroke ++ strokew ++ [">\n"] ++ inner ++ ["</g>\n"]++document :: Size -> [ByteString] -> [ByteString]+document (w,h) inner =+  [ "<?xml version='1.0' encoding='UTF-8' ?>\n"+  , "<svg xmlns='http://www.w3.org/2000/svg' version='1.0'"+  , " width='", showF w, "' height='", showF h, "'>\n"+  ] ++ inner ++ ["</svg>\n"]++polygon :: [Point] -> [ByteString]+polygon ps = ["<path d='"] ++ path 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 ""
+ src/Total.hs view
@@ -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"
src/Types.hs view
@@ -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)