hp2pretty 0.3 → 0.4
raw patch · 7 files changed
+124/−36 lines, 7 filesdep +filepath
Dependencies added: filepath
Files
- BUGS +1/−0
- NEWS +14/−0
- THANKS +1/−0
- hp2pretty.cabal +19/−6
- src/Graphics.hs +43/−20
- src/Main.hs +43/−9
- src/Print.hs +3/−1
+ BUGS view
@@ -0,0 +1,1 @@+empty heap profile gives NaN in SVG - detect and abort?
NEWS view
@@ -1,3 +1,17 @@+v0.4 2011-05-18 comparability++Colours are stable across program runs (based on a hash of+the label names).++Command line flag to use the same scale for all input files+(--uniform-scale=none|time|memory|both).++Usage change: specify XX.hp file(s) on the command line, the+output is to corresponding XX.svg files.++Source code statistics: 543 lines, 3273 words, 20045 chars.++ v0.3 2010-11-02 special characters Fixes a bug where broken SVG was generated when label names
THANKS view
@@ -1,1 +1,2 @@ Ian Lynagh (label text XML escaping bugfix patch)+Edward Z. Yang (feature requests for stable colours and uniform scales)
hp2pretty.cabal view
@@ -1,5 +1,5 @@ Name: hp2pretty-Version: 0.3+Version: 0.4 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@@ -8,20 +8,33 @@ Also none (count'em) of hp2ps' options are implemented yet in hp2pretty. .- Usage: "hp2pretty <in.hp >out.svg"+ Usage has changed since the previous release:+ .+ hp2pretty *.hp+ .+ hp2pretty --uniform-scale=time *.hp+ .+ hp2pretty --uniform-scale=memory *.hp+ .+ hp2pretty --uniform-scale=both *.hp+ .+ Colours have also changed: now they are based on a hash of the+ cost label, which should make colours have stable semantics+ across program runs.+ Homepage: http://gitorious.org/hp2pretty License: BSD3 License-file: LICENSE Author: Claude Heiland-Allen Maintainer: claudiusmaximus@goto10.org-Copyright: (C) 2010 Claude Heiland-Allen+Copyright: (C) 2010,2011 Claude Heiland-Allen Category: Development Build-type: Simple-Extra-source-files: NEWS README THANKS+Extra-source-files: BUGS NEWS README THANKS Cabal-version: >=1.6 Executable hp2pretty- Build-depends: base >= 4 && < 5, array, bytestring, containers, mtl+ Build-depends: base >= 4 && < 5, array, bytestring, containers, filepath, mtl GHC-options: -Wall GHC-prof-options: -prof -auto-all HS-source-dirs: src@@ -42,4 +55,4 @@ Source-repository this type: git location: git://gitorious.org/hp2pretty/hp2pretty.git- tag: v0.3+ tag: v0.4
src/Graphics.hs view
@@ -1,6 +1,9 @@ module Graphics where -import Data.ByteString.Char8 (ByteString)+import Data.ByteString.Char8 (ByteString, foldl')+import Data.Char (ord)+import Data.Bits (shiftR)+import Data.Int (Int32, Int64) type Point = (Double, Double) type Size = (Double, Double)@@ -35,23 +38,43 @@ black = RGB 0 0 0 white = RGB 1 1 1 -colours :: [RGB]-colours = map hueToRGB [0, 2 * pi / (phi * phi) ..]+colour :: ByteString -> RGB+colour s = hsvToRGB (c 0x12345) (c 0x6789a) (c 0xbcdef) 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+ c m = fromIntegral (hashByteString m s) * 667 / fromIntegral (maxBound :: Int32)++hsvToRGB :: Double -> Double -> Double -> RGB+hsvToRGB h0 s0 v0 =+ let s = 0.5 + 0.5 * (s0 - (fromIntegral (floor s0 :: Int)))+ v = 0.5 + 0.5 * (v0 - (fromIntegral (floor v0 :: Int)))+ h = floor h0 :: Int+ i = h `mod` 6+ f = h0 - fromIntegral h+ 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++-- hashing functions copied and modified from BSD-style LICENSE'd+-- base-4.3.1.0:Data.HashTable (c) The University of Glasgow 2003++hashByteString :: Int32 -> ByteString -> Int32+hashByteString magic = foldl' f golden+ where f m c = fromIntegral (ord c) * magic + hashInt32 m++hashInt32 :: Int32 -> Int32+hashInt32 x = mulHi x golden + x++mulHi :: Int32 -> Int32 -> Int32+mulHi a b = fromIntegral (r `shiftR` 32)+ where r :: Int64+ r = fromIntegral a * fromIntegral b++golden :: Int32+golden = 1013904242
src/Main.hs view
@@ -1,7 +1,15 @@+{-# LANGUAGE BangPatterns #-} module Main (main) where -import Prelude hiding (print, getContents, putStr)-import Data.ByteString.Char8 (getContents, putStr)+import Prelude hiding (print, readFile)+import Data.ByteString.Char8 (readFile, hPutStr)+import Control.Monad (forM_, when)+import Data.List (foldl1', isPrefixOf, partition)+import Data.Monoid (Last(..), mconcat)+import System.Environment (getArgs)+import System.Exit (exitSuccess)+import System.FilePath (replaceExtension)+import System.IO (withFile, IOMode(WriteMode)) import Total (total) import Prune (prune)@@ -9,13 +17,39 @@ import Pretty (pretty) import Print (print) import SVG (svg)+import Types (Header(..)) main :: IO () 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+ args <- getArgs+ let (flags, files) = partition (isPrefixOf "--") args+ uniformity "--uniform-scale=none" = Last (Just (False, False))+ uniformity "--uniform-scale=time" = Last (Just (True, False))+ uniformity "--uniform-scale=memory" = Last (Just (False, True))+ uniformity "--uniform-scale=both" = Last (Just (True, True))+ uniformity _ = Last Nothing+ Last (Just (uniformTime, uniformMemory)) = mconcat (Last (Just (False, False)) : map uniformity flags)+ when (null files) exitSuccess+ if not (uniformTime || uniformMemory)+ then forM_ files $ \file -> do+ input <- readFile file+ 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+ withFile (replaceExtension file "svg") WriteMode $ \h -> mapM_ (hPutStr h) outputs+ else do+ inputs <- mapM readFile files+ let hts0 = map total inputs+ (smima, vmima) = foldl1' (\((!smi, !sma), (!vmi, !vma)) ((!smi', !sma'), (!vmi', !vma')) -> ((smi`min`smi', sma`max`sma'), (vmi`min`vmi', vma`max`vma'))) . map (\(h, _) -> (hSampleRange h, hValueRange h)) $ hts0+ hts1 | uniformTime = map (\(h, t) -> (h{ hSampleRange = smima }, t)) hts0+ | otherwise = hts0+ hts | uniformMemory = map (\(h, t) -> (h{ hValueRange = vmima }, t)) hts1+ | otherwise = hts1+ forM_ (zip3 files inputs hts) $ \(file, input, (header, totals)) -> do+ let 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+ withFile (replaceExtension file "svg") WriteMode $ \h -> mapM_ (hPutStr h) outputs
src/Print.hs view
@@ -12,8 +12,10 @@ print gfx header sticks vticks labels times coords = let bands = toPoints (bounds coords) times coords filled c = visual gfx (Just c) Nothing Nothing Nothing+ labels' = reverse labels+ colours = map colour labels' 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+ key = concat . zipWith3 (keyBox (gW + border * 2.5) (border * 1.5) (gH / 16)) [(0::Int) ..] colours $ 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)) ++