diff --git a/NEWS b/NEWS --- a/NEWS +++ b/NEWS @@ -1,3 +1,13 @@ +v0.8 2017-06-29 patterns + +New flags and features: + --sort=size|stddev|name (order bands by this property) + --reverse (reverse sort order) + --trace=1.0 (trace elements threshold percentage) + --bands=15 (limit number of bands) + --pattern (pattern fill, better for printing) + + v0.7 2017-06-27 bugfix A bugfix in header parsing (thanks to Pepe Iborra). An diff --git a/README b/README --- a/README +++ b/README @@ -6,8 +6,32 @@ the aims of being maintainable, with more flexible output, and more beautiful output. Currently hp2pretty outputs Scalable Vector Graphics (SVG) only, though PostScript (PS) is planned. -Also none (count'em) of hp2ps' options are implemented yet in -hp2pretty. +Not all of hp2ps' options are implemented yet in hp2pretty. + + +Usage +===== + + hp2pretty - generate pretty graphs from heap profiles + + Usage: hp2pretty [--uniform-scale AXES] [--sort FIELD] [--reverse] + [--trace PERCENT] [--bands COUNT] [--pattern] FILES... + Convert heap profile FILES.hp to pretty graphs FILES.svg + + Available options: + --uniform-scale AXES Whether to use a uniform scale for all outputs. One + of: none (default), time, memory, both. + --sort FIELD How to sort the bands. One of: size (default), + stddev, name. + --reverse Reverse the order of bands. + --trace PERCENT Percentage of trace elements to + combine. (default: 1.0) + --bands COUNT Maximum number of bands to draw (0 for + unlimited). (default: 15) + --pattern Use patterns instead of solid colours to fill bands. + FILES... Heap profiles (FILE.hp will be converted to + FILE.svg). + -h,--help Show this help text Benchmarks diff --git a/THANKS b/THANKS --- a/THANKS +++ b/THANKS @@ -1,2 +1,3 @@ Ian Lynagh (label text XML escaping bugfix patch) Edward Z. Yang (feature requests for stable colours and uniform scales) +Pepe Iborra (parsing bugfix) diff --git a/hp2pretty.cabal b/hp2pretty.cabal --- a/hp2pretty.cabal +++ b/hp2pretty.cabal @@ -1,13 +1,25 @@ Name: hp2pretty -Version: 0.7 +Version: 0.8 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 more beautiful output. Currently hp2pretty outputs Scalable Vector Graphics (SVG) only, though PostScript (PS) is planned. - Also none (count'em) of hp2ps' options are implemented yet in - hp2pretty. + Not all of hp2ps' options are implemented yet in hp2pretty. . + In hp2pretty-0.8 output filtering and sorting flags are added, + as well as low-ink pattern fills for printing: + . + > hp2pretty --trace=1 *.hp + > hp2pretty --bands=15 *.hp + > hp2pretty --sort=size *.hp + > hp2pretty --sort=stddev *.hp + > hp2pretty --sort=name *.hp + > hp2pretty --reverse *.hp + > hp2pretty --pattern *.hp + . + In hp2pretty-0.7 a parsing bug is fixed. + . In hp2pretty-0.6 ByteString is replaced by Text, fixing bugs with Unicode. . @@ -16,13 +28,10 @@ . In hp2pretty-0.4 usage changed since the previous release: . - hp2pretty *.hp - . - hp2pretty --uniform-scale=time *.hp - . - hp2pretty --uniform-scale=memory *.hp - . - hp2pretty --uniform-scale=both *.hp + > hp2pretty *.hp + > hp2pretty --uniform-scale=time *.hp + > hp2pretty --uniform-scale=memory *.hp + > hp2pretty --uniform-scale=both *.hp . Colours also changed: now they are based on a hash of the cost label, which should make colours have stable semantics @@ -40,11 +49,20 @@ Cabal-version: >=1.6 Executable hp2pretty - Build-depends: base >= 4 && < 5, array, attoparsec, containers, filepath, floatshow, mtl, text + Build-depends: base >= 4 && < 5, + array, + attoparsec, + containers, + filepath, + floatshow, + mtl, + optparse-applicative, + text GHC-options: -Wall -rtsopts HS-source-dirs: src Main-is: Main.hs - Other-modules: Types + Other-modules: Args + Types Total Prune Bands @@ -52,6 +70,7 @@ Print SVG Graphics + Pattern Source-repository head type: git @@ -60,4 +79,4 @@ Source-repository this type: git location: https://code.mathr.co.uk/hp2pretty.git - tag: v0.7 + tag: v0.8 diff --git a/src/Args.hs b/src/Args.hs new file mode 100644 --- /dev/null +++ b/src/Args.hs @@ -0,0 +1,75 @@ +module Args (args, Args(..), Uniform(..), Sort(..)) where + +import Options.Applicative +import Data.Semigroup ((<>)) + +data Uniform = None | Time | Memory | Both deriving (Eq) +data Sort = Size | StdDev | Name + +data Args = Args + { uniformity :: Uniform + , sorting :: Sort + , reversing :: Bool + , tracePercent :: Double + , nBands :: Int + , patterned :: Bool + , files :: [String] + } + +argParser :: Parser Args +argParser = Args + <$> option parseUniform + ( long "uniform-scale" + <> help "Whether to use a uniform scale for all outputs. One of: none (default), time, memory, both." + <> value None + <> metavar "AXES" ) + <*> option parseSort + ( long "sort" + <> help "How to sort the bands. One of: size (default), stddev, name." + <> value Size + <> metavar "FIELD" ) + <*> switch + ( long "reverse" + <> help "Reverse the order of bands." ) + <*> option auto + ( long "trace" + <> help "Percentage of trace elements to combine." + <> value 1 + <> showDefault + <> metavar "PERCENT" ) + <*> option auto + ( long "bands" + <> help "Maximum number of bands to draw (0 for unlimited)." + <> value 15 + <> showDefault + <> metavar "COUNT" ) + <*> switch + ( long "pattern" + <> help "Use patterns instead of solid colours to fill bands." ) + <*> some (argument str + ( help "Heap profiles (FILE.hp will be converted to FILE.svg)." + <> metavar "FILES..." )) + +parseUniform :: ReadM Uniform +parseUniform = eitherReader $ \s -> case s of + "none" -> Right None + "time" -> Right Time + "memory" -> Right Memory + "both" -> Right Both + _ -> Left "expected one of: none, time, memory, both" + +parseSort :: ReadM Sort +parseSort = eitherReader $ \s -> case s of + "size" -> Right Size + "stddev" -> Right StdDev + "name" -> Right Name + _ -> Left "expected one of: size, stddev, name" + + +args :: IO Args +args = execParser opts + where + opts = info (argParser <**> helper) + ( fullDesc + <> progDesc "Convert heap profile FILES.hp to pretty graphs FILES.svg" + <> header "hp2pretty - generate pretty graphs from heap profiles" ) diff --git a/src/Graphics.hs b/src/Graphics.hs --- a/src/Graphics.hs +++ b/src/Graphics.hs @@ -5,6 +5,8 @@ import Data.Bits (shiftR) import Data.Int (Int32, Int64) +import Pattern (patterns) + type Point = (Double, Double) type Size = (Double, Double) type Angle = Double @@ -16,14 +18,17 @@ type Opacity = Double data RGB = RGB Double Double Double +type PatternID = Text + data Graphics = Graphics { text :: Maybe Angle -> Anchor -> FontSize -> Point -> [Text] -> [Text] , rect :: Point -> Size -> [Text] , line :: Point -> Point -> [Text] , polygon :: [Point] -> [Text] - , visual :: Maybe RGB -> Maybe Opacity -> Maybe RGB -> Maybe StrokeWidth -> [Text] -> [Text] - , document :: Size -> [Text] -> [Text] + , pattern :: Text -> (PatternID, [Text]) + , visual :: Maybe (Either PatternID RGB) -> Maybe Opacity -> Maybe RGB -> Maybe StrokeWidth -> [Text] -> [Text] + , document :: Size -> [Text] -> [Text] -> [Text] } rescalePoint :: (Point,Point) -> (Point,Point) -> Point -> Point @@ -60,6 +65,9 @@ 3 -> RGB p q v 4 -> RGB t p v _ -> RGB v p q + +patternIx :: Text -> Int +patternIx s = fromIntegral (hashText 0x54321 s * 555) `mod` length patterns -- hashing functions copied and modified from BSD-style LICENSE'd -- base-4.3.1.0:Data.HashTable (c) The University of Glasgow 2003 diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -5,14 +5,16 @@ import Data.Text.IO (readFile, hPutStr) import Control.Monad (forM_, when) import Data.List (foldl1', isPrefixOf, partition) +import Data.Tuple (swap) import Data.Monoid (Last(..), mconcat) import System.Environment (getArgs) import System.Exit (exitSuccess) import System.FilePath (replaceExtension) import System.IO (withFile, IOMode(WriteMode)) +import Args (args, Args(..), Uniform(..), Sort(..)) import Total (total) -import Prune (prune) +import Prune (prune, cmpName, cmpSize, cmpStdDev) import Bands (bands) import Pretty (pretty) import Print (print) @@ -21,35 +23,41 @@ main :: IO () main = do - 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 + a <- args + let uniformTime = uniformity a `elem` [Time, Both] + uniformMemory = uniformity a `elem` [Memory, Both] + sorting' = case sorting a of + Name -> cmpName + Size -> cmpSize + StdDev -> cmpStdDev + reversing' = if reversing a then swap else id + cmp = fst $ reversing' sorting' + when (null (files a)) exitSuccess if not (uniformTime || uniformMemory) - then forM_ files $ \file -> do + then forM_ (files a) $ \file -> do input <- readFile file let (header, totals) = total input - keeps = prune totals + keeps = prune cmp (tracePercent a) (bound $ nBands a) totals (times, vals) = bands header keeps input ((sticks, vticks), (labels, coords)) = pretty header vals keeps - outputs = print svg header sticks vticks labels times coords + outputs = print svg (patterned a) header sticks vticks labels times coords withFile (replaceExtension file "svg") WriteMode $ \h -> mapM_ (hPutStr h) outputs else do - inputs <- mapM readFile files + inputs <- mapM readFile (files a) 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 + forM_ (zip3 (files a) inputs hts) $ \(file, input, (header, totals)) -> do + let keeps = prune cmp (tracePercent a) (bound $ nBands a) totals (times, vals) = bands header keeps input ((sticks, vticks), (labels, coords)) = pretty header vals keeps - outputs = print svg header sticks vticks labels times coords + outputs = print svg (patterned a) header sticks vticks labels times coords withFile (replaceExtension file "svg") WriteMode $ \h -> mapM_ (hPutStr h) outputs + +bound :: Int -> Int +bound n + | n <= 0 = maxBound + | otherwise = n diff --git a/src/Pattern.hs b/src/Pattern.hs new file mode 100644 --- /dev/null +++ b/src/Pattern.hs @@ -0,0 +1,44 @@ +module Pattern (patterns, Pattern) where + +import Data.Tuple (swap) + +type Point = (Double, Double) + +type Pattern = [(Point, Point)] + +loop :: [Point] -> [(Point, Point)] +loop ps = zip ps (tail (cycle ps)) + +patterns :: [Pattern] +patterns = + -- short and long dashes in 4 directions + [ [ ((5, 8), (11, 8)) ] + , [ ((3, 8), (13, 8)) ] + , [ ((8, 5), (8, 11)) ] + , [ ((8, 3), (8, 13)) ] + , [ ((5, 5), (11, 11)) ] + , [ ((3, 3), (13, 13)) ] + , [ ((5, 11), (11, 5)) ] + , [ ((3, 13), (13, 3)) ] + -- small and large crosses in 2 directions + , [ ((5, 8), (11, 8)), ((8, 5), (8, 11)) ] + , [ ((3, 8), (13, 8)), ((8, 3), (8, 13)) ] + , [ ((5, 5), (11, 11)), ((5, 11), (11, 5)) ] + , [ ((3, 3), (13, 13)), ((3, 13), (13, 3)) ] + , [ ((3, 8), (13, 8)), ((8, 3), (8, 13)), ((3, 3), (13, 13)), ((3, 13), (13, 3)) ] + , [ ((5, 8), (11, 8)), ((8, 5), (8, 11)), ((5, 5), (11, 11)), ((5, 11), (11, 5)) ] + -- small and large triangles in 4 directions + , loop [ (5, 5), (11, 5), (8, 11) ] + , loop [ (3, 3), (13, 3), (8, 13) ] + , loop [ (5, 11), (11, 11), (8, 5) ] + , loop [ (3, 13), (13, 13), (8, 3) ] + , loop (map swap [ (5, 5), (11, 5), (8, 11) ]) + , loop (map swap [ (3, 3), (13, 3), (8, 13) ]) + , loop (map swap [ (5, 11), (11, 11), (8, 5) ]) + , loop (map swap [ (3, 13), (13, 13), (8, 3) ]) + -- small and large squares in 2 directions + , loop [ (5, 5), (11, 5), (11, 11), (5, 11) ] + , loop [ (3, 3), (13, 3), (13, 13), (3, 13) ] + , loop [ (5, 8), (8, 5), (11, 8), (8, 11) ] + , loop [ (3, 8), (8, 3), (13, 8), (8, 13) ] + ] diff --git a/src/Print.hs b/src/Print.hs --- a/src/Print.hs +++ b/src/Print.hs @@ -8,12 +8,17 @@ import Types import Graphics -print :: Graphics -> Header -> [Double] -> [Double] -> [Text] -> UArray Int Double -> UArray (Int, Int) Double -> [Text] -print gfx header sticks vticks labels times coords = +first :: (a -> c) -> (a, b) -> (c, b) +first f (a, b) = (f a, b) + +print :: Graphics -> Bool -> Header -> [Double] -> [Double] -> [Text] -> UArray Int Double -> UArray (Int, Int) Double -> [Text] +print gfx patterned 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' + (colours, defs) + | patterned = first (map Left) . unzip $ map (pattern gfx) labels' + | otherwise = (map (Right . 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 $ labels' keyBox x y0 dy i c l = @@ -31,8 +36,8 @@ 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 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) + background = filled (Right white) $ rect gfx (0,0) (w,h) + box = filled (Right 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) ++ @@ -43,9 +48,9 @@ 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 $ + in document gfx (w,h) (concat defs) . concat $ [ background - , visual gfx (Just black) Nothing (Just black) (Just 1) $ concat + , visual gfx (Just (Right black)) Nothing (Just black) (Just 1) $ concat [ title , leftLabel , bottomLabel diff --git a/src/Prune.hs b/src/Prune.hs --- a/src/Prune.hs +++ b/src/Prune.hs @@ -1,19 +1,43 @@ -module Prune (prune) where +module Prune + ( prune + , Compare + , cmpName + , cmpSize + , cmpStdDev + ) where import Data.Text (Text) import Data.List (foldl', sortBy) import Data.Ord (comparing) import Data.Map (Map, toList, fromList) -prune :: Map Text Double -> Map Text Int -prune ts = - let ccTotals = sortBy (flip $ comparing snd) (toList ts) - sizes = map snd ccTotals +type Compare a = a -> a -> Ordering + +cmpName, cmpSize, cmpStdDev + :: (Compare (Text, (Double, Double)), Compare (Text, (Double, Double))) +cmpName = (cmpNameAscending, cmpNameDescending) +cmpSize = (cmpSizeDescending, cmpSizeAscending) +cmpStdDev = (cmpStdDevDescending, cmpStdDevAscending) + +cmpNameAscending, cmpNameDescending, + cmpStdDevAscending, cmpStdDevDescending, + cmpSizeAscending, cmpSizeDescending :: Compare (Text, (Double, Double)) +cmpNameAscending = comparing fst +cmpNameDescending = flip cmpNameAscending +cmpStdDevAscending = comparing (snd . snd) +cmpStdDevDescending = flip cmpStdDevAscending +cmpSizeAscending = comparing (fst . snd) +cmpSizeDescending = flip cmpSizeAscending + +prune :: Compare (Text, (Double, Double)) -> Double -> Int -> Map Text (Double, Double) -> Map Text Int +prune cmp tracePercent nBands ts = + let ccTotals = sortBy cmpSizeDescending (toList ts) + sizes = map (fst . snd) ccTotals total = sum' sizes - limit = 0.99 * total + limit = (1 - tracePercent / 100) * total bigs = takeWhile (< limit) . scanl (+) 0 $ sizes - bands = zipWith const ccTotals $ take 15 bigs - ccs = map fst bands + bands = zipWith const ccTotals $ take nBands bigs + ccs = map fst (sortBy cmp bands) in fromList (reverse ccs `zip` [1 ..]) sum' :: [Double] -> Double diff --git a/src/SVG.hs b/src/SVG.hs --- a/src/SVG.hs +++ b/src/SVG.hs @@ -3,11 +3,14 @@ import Data.Text (Text, pack) import qualified Data.Text as T +import Data.List (intersperse) +import Data.Monoid ((<>)) import Numeric (showHex) import Text.FShow.RealFloat (fshow, Double7(D7)) -import Graphics (Graphics(Graphics), Point, Size, Angle, FontSize, Anchor(..), StrokeWidth, Opacity, RGB(..)) +import Graphics (Graphics(Graphics), Point, Size, Angle, FontSize, Anchor(..), StrokeWidth, Opacity, RGB(..), PatternID, colour, patternIx) import qualified Graphics as G +import Pattern (Pattern, patterns) svg :: Graphics svg = @@ -16,6 +19,7 @@ , G.rect = rect , G.line = line , G.polygon = polygon + , G.pattern = pattern , G.visual = visual , G.document = document } @@ -44,20 +48,33 @@ line :: Point -> Point -> [Text] line (x1,y1) (x2,y2) = ["\n"] -visual :: Maybe RGB -> Maybe Opacity -> Maybe RGB -> Maybe StrokeWidth -> [Text] -> [Text] +pattern :: Text -> (PatternID, [Text]) +pattern t = ("url(#" <> pid <> ")", + [ "\n" + , " \n" + , "\n"]) + where + pid = mconcat ["P", pack (show ix), "p", T.tail s] + s = showRGB rgb + p ((x0, y0), (x1, y1)) = pack $ "M " ++ show x0 ++ "," ++ show y0 ++ " L " ++ show x1 ++ "," ++ show y1 + rgb = colour t + ix = patternIx t + ps = patterns !! ix + +visual :: Maybe (Either PatternID RGB) -> Maybe Opacity -> Maybe RGB -> Maybe StrokeWidth -> [Text] -> [Text] visual mfill mfillo mstroke mstrokew inner = - let fill = maybe [] (\f -> [" fill='", showRGB f, "'"]) mfill + let fill = maybe [] (\f -> [" fill='", either id 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 -> [Text] -> [Text] -document (w,h) inner = +document :: Size -> [Text] -> [Text] -> [Text] +document (w,h) defs inner = [ "\n" , "\n" - ] ++ inner ++ ["\n"] + ] ++ ["\n"] ++ defs ++ ["\n"] ++ inner ++ ["\n"] polygon :: [Point] -> [Text] polygon ps = [""] diff --git a/src/Total.hs b/src/Total.hs --- a/src/Total.hs +++ b/src/Total.hs @@ -13,7 +13,7 @@ data Parse = Parse { symbols :: !(Map Text Text) -- intern symbols to save RAM - , totals :: !(Map Text Double ) -- compute running totals + , totals :: !(Map Text (Double, Double)) -- compute running totass and total of squares , sampleMin :: !Double , sampleMax :: !Double , valueMin :: !Double @@ -24,7 +24,7 @@ parse0 :: Parse parse0 = Parse{ symbols = empty, totals = empty, sampleMin = 0, sampleMax = 0, valueMin = 0, valueMax = 0, count = 0 } -total :: Text -> (Header, Map Text Double) +total :: Text -> (Header, Map Text (Double, Double)) total s = let ls = lines s (hs, ss) = splitAt 4 ls @@ -40,9 +40,12 @@ , hValueRange = (valueMin parse1, valueMax parse1) , hCount = count parse1 } - , totals parse1 + , fmap (stddev $ fromIntegral (count parse1)) (totals parse1) ) +stddev :: Double -> (Double, Double) -> (Double, Double) +stddev s0 (s1, s2) = (s1, sqrt (s0 * s2 - s1 * s1) / s0) + header :: Text -> Text -> Text header name h = if name `isPrefixOf` h @@ -86,9 +89,9 @@ 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 +accum :: Double -> Maybe (Double, Double) -> Maybe (Double, Double) +accum x Nothing = Just $! (((,) $! x) $! (x * x)) +accum x (Just (y, yy)) = Just $! (((,) $! (x + y)) $! (x * x + yy)) sampleTime :: Text -> Text -> Double sampleTime name h =