diff --git a/BUGS b/BUGS --- a/BUGS +++ b/BUGS @@ -1,8 +1,1 @@ empty heap profile gives NaN in SVG - detect and abort? -use Text for correct unicode instead of ByteString - $ ./unicode +RTS -h - $ hp2pretty unicode.hp - $ rsvg unicode.svg unicode.png - Error reading SVG:Error domain 1 code 9 on line 83 column 39 unicode.svg: Input is not proper UTF-8, indicate encoding ! - Bytes: 0xF8 0x62 0x2F 0x6D - $ diff --git a/NEWS b/NEWS --- a/NEWS +++ b/NEWS @@ -1,3 +1,8 @@ +v0.6 2015-04-08 text + +ByteString is replaced by Text, fixing bugs with Unicode. + + v0.5 2011-10-15 acceleration Vastly improved runtime performance thanks to 'floatshow' diff --git a/hp2pretty.cabal b/hp2pretty.cabal --- a/hp2pretty.cabal +++ b/hp2pretty.cabal @@ -1,5 +1,5 @@ Name: hp2pretty -Version: 0.5 +Version: 0.6 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,6 +8,9 @@ Also none (count'em) of hp2ps' options are implemented yet in hp2pretty. . + In hp2pretty-0.6 ByteString is replaced by Text, fixing bugs + with Unicode. + . In hp2pretty-0.5 using attoparsec and floatshow internally should give a healthy speedup. . @@ -25,21 +28,20 @@ cost label, which should make colours have stable semantics across program runs. -Homepage: http://gitorious.org/hp2pretty +Homepage: http://code.mathr.co.uk/hp2pretty License: BSD3 License-file: LICENSE Author: Claude Heiland-Allen -Maintainer: claudiusmaximus@goto10.org -Copyright: (C) 2010,2011 Claude Heiland-Allen +Maintainer: claude@mathr.co.uk +Copyright: (C) 2010,2011,2015 Claude Heiland-Allen Category: Development Build-type: Simple Extra-source-files: BUGS NEWS README THANKS Cabal-version: >=1.6 Executable hp2pretty - Build-depends: base >= 4 && < 5, array, attoparsec, bytestring, containers, filepath, floatshow, mtl + Build-depends: base >= 4 && < 5, array, attoparsec, containers, filepath, floatshow, mtl, text GHC-options: -Wall -rtsopts - GHC-prof-options: -prof -auto-all -caf-all HS-source-dirs: src Main-is: Main.hs Other-modules: Types @@ -53,9 +55,9 @@ Source-repository head type: git - location: git://gitorious.org/hp2pretty/hp2pretty.git + location: http://code.mathr.co.uk/hp2pretty.git Source-repository this type: git - location: git://gitorious.org/hp2pretty/hp2pretty.git - tag: v0.5 + location: http://code.mathr.co.uk/hp2pretty.git + tag: v0.6 diff --git a/src/Bands.hs b/src/Bands.hs --- a/src/Bands.hs +++ b/src/Bands.hs @@ -8,13 +8,13 @@ import Data.Array.Unboxed (UArray) import Data.Map (Map, lookup, size) 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 Data.Attoparsec.Char8 (parseOnly, double) +import Data.Text (Text, pack, unpack, lines, words, isPrefixOf, length) +import qualified Data.Text as T +import Data.Attoparsec.Text (parseOnly, double) import Types -bands :: Header -> Map ByteString Int -> ByteString -> (UArray Int Double, UArray (Int, Int) Double) +bands :: Header -> Map Text Int -> Text -> (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 @@ -30,7 +30,7 @@ vals' <- unsafeFreezeSTUArray vals return (times', vals') -chunkSamples :: [ByteString] -> [[ByteString]] +chunkSamples :: [Text] -> [[Text]] chunkSamples [] = [] chunkSamples (x:xs) | sBEGIN_SAMPLE `isPrefixOf` x = @@ -40,17 +40,17 @@ (_:ws) -> (x:ys) : chunkSamples ws | otherwise = [] -- expected BEGIN_SAMPLE or EOF... -sampleTime :: ByteString -> ByteString -> Double +sampleTime :: Text -> Text -> Double sampleTime name h = if name `isPrefixOf` h - then readDouble . BS.drop (length name + 1) $ h + then readDouble . T.drop (length name + 1) $ h else error $ "Parse.sampleTime: expected " ++ unpack name ++ " but got " ++ unpack h -readDouble :: ByteString -> Double +readDouble :: Text -> Double readDouble s = case parseOnly double s of Right x -> x _ -> error $ "Parse.readDouble: no parse " ++ unpack s -sBEGIN_SAMPLE, sEND_SAMPLE :: ByteString +sBEGIN_SAMPLE, sEND_SAMPLE :: Text sBEGIN_SAMPLE = pack "BEGIN_SAMPLE" sEND_SAMPLE = pack "END_SAMPLE" diff --git a/src/Graphics.hs b/src/Graphics.hs --- a/src/Graphics.hs +++ b/src/Graphics.hs @@ -1,6 +1,6 @@ module Graphics where -import Data.ByteString.Char8 (ByteString, foldl') +import Data.Text (Text, foldl') import Data.Char (ord) import Data.Bits (shiftR) import Data.Int (Int32, Int64) @@ -18,12 +18,12 @@ 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] + { 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] } rescalePoint :: (Point,Point) -> (Point,Point) -> Point -> Point @@ -38,10 +38,10 @@ black = RGB 0 0 0 white = RGB 1 1 1 -colour :: ByteString -> RGB +colour :: Text -> RGB colour s = hsvToRGB (c 0x12345) (c 0x6789a) (c 0xbcdef) where - c m = fromIntegral (hashByteString m s) * 667 / fromIntegral (maxBound :: Int32) + c m = fromIntegral (hashText m s) * 667 / fromIntegral (maxBound :: Int32) hsvToRGB :: Double -> Double -> Double -> RGB hsvToRGB h0 s0 v0 = @@ -64,8 +64,8 @@ -- 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 +hashText :: Int32 -> Text -> Int32 +hashText magic = foldl' f golden where f m c = fromIntegral (ord c) * magic + hashInt32 m hashInt32 :: Int32 -> Int32 diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -2,7 +2,7 @@ module Main (main) where import Prelude hiding (print, readFile) -import Data.ByteString.Char8 (readFile, hPutStr) +import Data.Text.IO (readFile, hPutStr) import Control.Monad (forM_, when) import Data.List (foldl1', isPrefixOf, partition) import Data.Monoid (Last(..), mconcat) diff --git a/src/Pretty.hs b/src/Pretty.hs --- a/src/Pretty.hs +++ b/src/Pretty.hs @@ -4,14 +4,14 @@ 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.Text (Text, pack) import Data.List (sortBy) import Data.Map (Map, toList) import Data.Ord (comparing) import Types -pretty :: Header -> UArray (Int, Int) Double -> Map ByteString Int -> (([Double], [Double]), ([ByteString], UArray (Int, Int) Double)) +pretty :: Header -> UArray (Int, Int) Double -> Map Text Int -> (([Double], [Double]), ([Text], UArray (Int, Int) Double)) pretty header vals bs = let sticks = uncurry (ticks 20) (hSampleRange header) vticks = uncurry (ticks 20) (hValueRange header) diff --git a/src/Print.hs b/src/Print.hs --- a/src/Print.hs +++ b/src/Print.hs @@ -2,13 +2,13 @@ import Prelude hiding (print) import Data.Array.Unboxed (UArray, bounds, (!)) -import Data.ByteString.Char8 (ByteString, pack) +import Data.Text (Text, pack) import Numeric (showFFloat) import Types import Graphics -print :: Graphics -> Header -> [Double] -> [Double] -> [ByteString] -> UArray Int Double -> UArray (Int, Int) Double -> [ByteString] +print :: Graphics -> Header -> [Double] -> [Double] -> [Text] -> UArray Int Double -> UArray (Int, Int) Double -> [Text] print gfx header sticks vticks labels times coords = let bands = toPoints (bounds coords) times coords filled c = visual gfx (Just c) Nothing Nothing Nothing @@ -71,7 +71,7 @@ up b = [s0 + b - b .. s1] down b = [s1 + b - b, s1 - 1 .. s0] -showSI :: Double -> [ByteString] +showSI :: Double -> [Text] showSI x | x < 1e3 = [ showF x "" ] | x < 1e6 = [ showF (x/1e3 ) "k" ] | x < 1e9 = [ showF (x/1e6 ) "M" ] diff --git a/src/Prune.hs b/src/Prune.hs --- a/src/Prune.hs +++ b/src/Prune.hs @@ -1,11 +1,11 @@ module Prune (prune) where -import Data.ByteString.Char8 (ByteString) +import Data.Text (Text) import Data.List (foldl', sortBy) import Data.Ord (comparing) import Data.Map (Map, toList, fromList) -prune :: Map ByteString Double -> Map ByteString Int +prune :: Map Text Double -> Map Text Int prune ts = let ccTotals = sortBy (flip $ comparing snd) (toList ts) sizes = map snd ccTotals diff --git a/src/SVG.hs b/src/SVG.hs --- a/src/SVG.hs +++ b/src/SVG.hs @@ -1,8 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} module SVG (svg) where -import Data.ByteString.Char8 (ByteString, pack) -import qualified Data.ByteString.Char8 as BS +import Data.Text (Text, pack) +import qualified Data.Text as T import Numeric (showHex) import Text.FShow.RealFloat (fshow, Double7(D7)) @@ -20,7 +20,7 @@ , G.document = document } -text :: Maybe Angle -> Anchor -> FontSize -> Point -> [ByteString] -> [ByteString] +text :: Maybe Angle -> Anchor -> FontSize -> Point -> [Text] -> [Text] text r a s (x,y) inner = let coords = case r of Nothing -> ["x='", showF x, "' y='", showF y, "'"] @@ -30,21 +30,21 @@ showAnchor End = "end" in [""] ++ map escape inner ++ ["\n"] -escape :: ByteString -> ByteString -escape = BS.concatMap escapeChar +escape :: Text -> Text +escape = T.concatMap escapeChar where escapeChar '<' = "<" escapeChar '>' = ">" escapeChar '&' = "&" - escapeChar c = BS.singleton c + escapeChar c = T.singleton c -rect :: Point -> Size -> [ByteString] +rect :: Point -> Size -> [Text] rect (x,y) (w,h) = ["\n"] -line :: Point -> Point -> [ByteString] +line :: Point -> Point -> [Text] line (x1,y1) (x2,y2) = ["\n"] -visual :: Maybe RGB -> Maybe Opacity -> Maybe RGB -> Maybe StrokeWidth -> [ByteString] -> [ByteString] +visual :: Maybe RGB -> Maybe Opacity -> Maybe RGB -> Maybe StrokeWidth -> [Text] -> [Text] visual mfill mfillo mstroke mstrokew inner = let fill = maybe [] (\f -> [" fill='", showRGB f, "'"]) mfill fillo = maybe [] (\o -> [" fill-opacity='", showF o, "'"]) mfillo @@ -52,30 +52,30 @@ strokew = maybe [] (\w -> [" stroke-width='", showF w, "'"]) mstrokew in ["\n"] ++ inner ++ ["\n"] -document :: Size -> [ByteString] -> [ByteString] +document :: Size -> [Text] -> [Text] document (w,h) inner = [ "\n" , "\n" ] ++ inner ++ ["\n"] -polygon :: [Point] -> [ByteString] +polygon :: [Point] -> [Text] polygon ps = [""] -path :: [(Double,Double)] -> [ByteString] +path :: [(Double,Double)] -> [Text] 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 -> Text 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 :: Point -> [Text] showP (x,y) = [showF x, ",", showF y] -showF :: Double -> ByteString +showF :: Double -> Text showF x = pack $ fshow (D7 x) diff --git a/src/Total.hs b/src/Total.hs --- a/src/Total.hs +++ b/src/Total.hs @@ -5,15 +5,15 @@ import Data.List (foldl') import Data.Map (Map, empty, lookup, insert, alter) import Prelude hiding (lookup, lines, words, drop, length) -import Data.ByteString.Char8 (ByteString, pack, unpack, lines, words, isPrefixOf, drop, length) -import Data.Attoparsec.Char8 (parseOnly, double) +import Data.Text (Text, pack, unpack, lines, words, isPrefixOf, drop, length) +import Data.Attoparsec.Text (parseOnly, double) import Types data Parse = Parse - { symbols :: !(Map ByteString ByteString) -- intern symbols to save RAM - , totals :: !(Map ByteString Double ) -- compute running totals + { symbols :: !(Map Text Text) -- intern symbols to save RAM + , totals :: !(Map Text Double ) -- compute running totals , 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 :: ByteString -> (Header, Map ByteString Double) +total :: Text -> (Header, Map Text Double) total s = let ls = lines s (hs, ss) = splitAt 4 ls @@ -43,13 +43,13 @@ , totals parse1 ) -header :: ByteString -> ByteString -> ByteString +header :: Text -> Text -> Text 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 :: [Text] -> [[Text]] chunkSamples [] = [] chunkSamples (x:xs) | sBEGIN_SAMPLE `isPrefixOf` x = @@ -59,7 +59,7 @@ (_:ws) -> (x:ys) : chunkSamples ws | otherwise = [] -- expected BEGIN_SAMPLE or EOF... -parseFrame :: [ByteString] -> State Parse () +parseFrame :: [Text] -> State Parse () parseFrame [] = error "Parse.parseFrame: empty" parseFrame (l:ls) = do let !time = sampleTime sBEGIN_SAMPLE l @@ -72,7 +72,7 @@ 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 :: Text -> State Parse Double inserter s = do let [k,vs] = words s !v = readDouble vs @@ -90,18 +90,18 @@ accum x Nothing = Just x accum x (Just y) = Just $! x + y -sampleTime :: ByteString -> ByteString -> Double +sampleTime :: Text -> Text -> 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 :: Text -> Double readDouble s = case parseOnly double s of Right x -> x _ -> error $ "Parse.readDouble: no parse " ++ unpack s -sJOB, sDATE, sSAMPLE_UNIT, sVALUE_UNIT, sBEGIN_SAMPLE, sEND_SAMPLE :: ByteString +sJOB, sDATE, sSAMPLE_UNIT, sVALUE_UNIT, sBEGIN_SAMPLE, sEND_SAMPLE :: Text sJOB = pack "JOB" sDATE = pack "DATE" sSAMPLE_UNIT = pack "SAMPLE_UNIT" diff --git a/src/Types.hs b/src/Types.hs --- a/src/Types.hs +++ b/src/Types.hs @@ -1,13 +1,13 @@ module Types where -import Data.ByteString.Char8 (ByteString) +import Data.Text (Text) data Header = Header - { hJob :: ByteString - , hDate :: ByteString - , hSampleUnit :: ByteString - , hValueUnit :: ByteString + { hJob :: Text + , hDate :: Text + , hSampleUnit :: Text + , hValueUnit :: Text , hSampleRange :: (Double, Double) , hValueRange :: (Double, Double) , hCount :: Int