diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +2014-09-23 Will Sewell + + * Version 0.2.2 adds support for GHC 7.10 + 2014-02-12 Edsko de Vries * Initial release diff --git a/ghc-events-analyze.cabal b/ghc-events-analyze.cabal --- a/ghc-events-analyze.cabal +++ b/ghc-events-analyze.cabal @@ -1,5 +1,5 @@ name: ghc-events-analyze -version: 0.2.1 +version: 0.2.2 synopsis: Analyze and visualize event logs description: ghc-events-analyze is a simple Haskell profiling tool that uses GHC's eventlog system. It helps with some profiling @@ -51,19 +51,19 @@ GHC.RTS.Events.Analyze.Reports.Timed GHC.RTS.Events.Analyze.Reports.Timed.SVG - build-depends: base >= 4.5 && < 4.8, + build-depends: base >= 4.5 && < 4.9, ghc-events >= 0.4 && < 0.5, optparse-applicative >= 0.11 && < 0.12, - diagrams-lib >= 1.2 && < 1.3, - diagrams-svg >= 1.1 && < 1.3, - SVGFonts >= 1.4 && < 1.5, + diagrams-lib >= 1.2 && < 1.4, + diagrams-svg >= 1.1 && < 1.4, + SVGFonts >= 1.4 && < 1.6, containers >= 0.5 && < 0.6, - lens >= 3.10 && < 4.5, + lens >= 3.10 && < 4.13, mtl >= 2.2.1 && < 2.3, transformers >= 0.3 && < 0.5, - filepath >= 1.3 && < 1.4, + filepath >= 1.3 && < 1.5, parsec >= 3.1 && < 3.2, - th-lift >= 0.6 && < 0.7, + th-lift >= 0.6 && < 0.8, -- No version: whatever is bundled with ghc template-haskell @@ -79,5 +79,6 @@ BangPatterns RankNTypes MultiParamTypeClasses - other-extensions: TemplateHaskell + other-extensions: CPP + TemplateHaskell QuasiQuotes diff --git a/src/GHC/RTS/Events/Analyze/Analysis.hs b/src/GHC/RTS/Events/Analyze/Analysis.hs --- a/src/GHC/RTS/Events/Analyze/Analysis.hs +++ b/src/GHC/RTS/Events/Analyze/Analysis.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleContexts #-} module GHC.RTS.Events.Analyze.Analysis ( -- * Auxiliary readEventLog diff --git a/src/GHC/RTS/Events/Analyze/Reports/Timed/SVG.hs b/src/GHC/RTS/Events/Analyze/Reports/Timed/SVG.hs --- a/src/GHC/RTS/Events/Analyze/Reports/Timed/SVG.hs +++ b/src/GHC/RTS/Events/Analyze/Reports/Timed/SVG.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} module GHC.RTS.Events.Analyze.Reports.Timed.SVG ( writeReport ) where @@ -5,13 +7,24 @@ import Data.Maybe (catMaybes) import Data.Monoid (mempty, mconcat, (<>)) import Diagrams.Backend.SVG (B, renderSVG) -import Diagrams.Prelude (Diagram, Colour, R2, SizeSpec2D, (#), (|||)) +#if MIN_VERSION_diagrams_lib(1,3,0) +import Diagrams.Prelude (QDiagram, Colour, V2, N, Any, (#), (|||)) +#else +import Diagrams.Prelude (Diagram, Colour, R2, (#), (|||)) +#endif import GHC.RTS.Events (Timestamp) -import Graphics.SVGFonts.ReadFont (TextOpts(..)) import Text.Printf (printf) import qualified Data.Map as Map import qualified Diagrams.Prelude as D + +#if MIN_VERSION_SVGFonts(1,5,0) +import Graphics.SVGFonts.Text (TextOpts(..)) +import qualified Graphics.SVGFonts.Text as F +import qualified Graphics.SVGFonts.Fonts as F +#else +import Graphics.SVGFonts.ReadFont (TextOpts(..)) import qualified Graphics.SVGFonts.ReadFont as F +#endif import GHC.RTS.Events.Analyze.Types import GHC.RTS.Events.Analyze.Reports.Timed hiding (writeReport) @@ -20,13 +33,27 @@ writeReport options quantized report path = uncurry (renderSVG path) $ renderReport options quantized report +#if MIN_VERSION_diagrams_lib(1,3,0) +type D = QDiagram B V2 (N B) Any +type SizeSpec = D.SizeSpec V2 Double +#else type D = Diagram B R2 +type SizeSpec = D.SizeSpec2D +#endif -renderReport :: Options -> Quantized -> Report -> (SizeSpec2D, D) +renderReport :: Options -> Quantized -> Report -> (SizeSpec, D) renderReport Options{optionsNumBuckets, optionsMilliseconds} Quantized{quantBucketSize} - report = (D.sizeSpec2D rendered, rendered) + report = (sizeSpec, rendered) where +#if MIN_VERSION_diagrams_lib(1,3,0) + sizeSpec = let w = Just $ D.width rendered + h = Just $ D.height rendered + in D.mkSizeSpec2D w h +#else + sizeSpec = D.sizeSpec2D rendered +#endif + rendered :: D rendered = D.vcat $ map (uncurry renderSVGFragment) $ zip (cycle [D.white, D.ghostwhite]) @@ -104,14 +131,26 @@ renderText :: String -> Double -> D renderText str size = - D.stroke (F.textSVG' (textOpts str size)) # D.fc D.black # D.lc D.black # D.alignL # D.lw D.none - + D.stroke textSVG # D.fc D.black # D.lc D.black # D.alignL # D.lw D.none + where +#if MIN_VERSION_SVGFonts(1,5,0) + textSVG = F.textSVG' (textOpts size) str +#else + textSVG = F.textSVG' (textOpts str size) +#endif +#if MIN_VERSION_SVGFonts(1,5,0) +textOpts :: Double -> TextOpts Double +textOpts size = + TextOpts { + textFont = F.lin +#else textOpts :: String -> Double -> TextOpts textOpts str size = TextOpts { txt = str , fdo = F.lin +#endif , mode = F.INSIDE_H , spacing = F.KERN , underline = False @@ -158,10 +197,15 @@ blockMod = 10 `div` (round blockWidth) timelineBlock b | b `rem` (5 * blockMod) == 0 - = D.strokeLine bigLine # D.lw (D.Local 0.5) + = D.strokeLine bigLine # D.lw (localMeasure 0.5) <> (renderText (bucketTime b) blockHeight # D.translateY (blockHeight - 2)) | otherwise - = D.strokeLine smallLine # D.lw (D.Local 0.5) # D.translateY 1 + = D.strokeLine smallLine # D.lw (localMeasure 0.5) # D.translateY 1 +#if MIN_VERSION_diagrams_lib(1,3,0) + localMeasure = D.local +#else + localMeasure = D.Local +#endif bucketTime :: Int -> String bucketTime b = let timeNs :: Timestamp diff --git a/src/GHC/RTS/Events/Analyze/Script.hs b/src/GHC/RTS/Events/Analyze/Script.hs --- a/src/GHC/RTS/Events/Analyze/Script.hs +++ b/src/GHC/RTS/Events/Analyze/Script.hs @@ -1,5 +1,6 @@ {-# OPTIONS_GHC -w -W #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE CPP #-} module GHC.RTS.Events.Analyze.Script ( -- * Types Script @@ -18,7 +19,9 @@ import Control.Applicative ((<$>), (<*>), (*>), (<*), pure) import Data.List (intercalate) +#if !MIN_VERSION_template_haskell(2,10,0) import Data.Word (Word32) +#endif import Language.Haskell.TH.Lift (deriveLiftMany) import Language.Haskell.TH.Quote import Language.Haskell.TH.Syntax @@ -195,8 +198,10 @@ $(deriveLiftMany [''EventId, ''EventFilter, ''EventSort, ''Command]) +#if !MIN_VERSION_template_haskell(2,10,0) instance Lift Word32 where lift = let conv :: Word32 -> Int ; conv = fromEnum in lift . conv +#endif scriptQQ :: QuasiQuoter scriptQQ = QuasiQuoter { diff --git a/src/GHC/RTS/Events/Analyze/StrictState.hs b/src/GHC/RTS/Events/Analyze/StrictState.hs --- a/src/GHC/RTS/Events/Analyze/StrictState.hs +++ b/src/GHC/RTS/Events/Analyze/StrictState.hs @@ -16,6 +16,7 @@ , module Control.Monad.State.Strict ) where +import Control.Applicative import Control.Monad.IO.Class (MonadIO) import Control.Monad.State.Strict (MonadState(..)) import qualified Control.Monad.State.Strict as St @@ -27,7 +28,7 @@ -------------------------------------------------------------------------------} newtype StateT s m a = StateT { unStateT :: St.StateT s m a } - deriving (Functor, Monad, MonadTrans, MonadIO) + deriving (Functor, Applicative, Monad, MonadTrans, MonadIO) runStateT :: StateT s m a -> s -> m (a, s) runStateT = St.runStateT . unStateT