diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +0.2.9 + + * Support `ghc-9.6.5` and `SVGFonts-1.8` + (2025-07-19 Vladimir Ovechkin ) + * Drop support for `ghc < 9.2`, general cleanup. + 0.2.8 * Support for ghc-events-0.13 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2013-2014 Well-Typed LLP +Copyright (c) 2013-2025 Well-Typed LLP All rights reserved. diff --git a/examples/BlogpostExamples.hs b/examples/BlogpostExamples.hs new file mode 100644 --- /dev/null +++ b/examples/BlogpostExamples.hs @@ -0,0 +1,17 @@ +module BlogpostExamples (main) where + +import System.Environment + +import Examples.Ex0 qualified as Ex0 +import Examples.Ex0_Windowed qualified as Ex0_Windowed +import Examples.Ex1 qualified as Ex1 + +main :: IO () +main = do + args <- getArgs + case args of + [] -> return () -- For use by @cabal test@ + ["ex0"] -> Ex0.main + ["ex0-windowed"] -> Ex0_Windowed.main + ["ex1"] -> Ex1.main + _otherwise -> error $ "Invalid arguments " ++ show args diff --git a/examples/Examples/Common.hs b/examples/Examples/Common.hs new file mode 100644 --- /dev/null +++ b/examples/Examples/Common.hs @@ -0,0 +1,23 @@ +module Examples.Common ( + fib + , printFib + , blips + ) where + +import Control.Concurrent (threadDelay) + +-- Intentionally slow fib +fib :: Integer -> Integer +fib 0 = 1 +fib 1 = 1 +fib n = fib (n - 1) + fib (n - 2) + +printFib :: Integer -> IO () +printFib n = print (fib n) + +blips :: IO () +blips = do + putStrLn "BLIP" + threadDelay 5000000 + putStrLn "BLIP" + diff --git a/examples/Examples/Ex0.hs b/examples/Examples/Ex0.hs new file mode 100644 --- /dev/null +++ b/examples/Examples/Ex0.hs @@ -0,0 +1,16 @@ +module Examples.Ex0 (main) where + +import Control.Concurrent (threadDelay) +import Control.Concurrent.Async (async, wait) + +import Examples.Common + +main :: IO () +main = do + -- To generate a picture similar to the one in the blog post, the entire test + -- should take roughly 30 seconds. Tweak arguments to 'fib' accordingly. + a1 <- async $ mapM_ printFib [30, 32 .. 42] + a2 <- async $ mapM_ printFib [31, 33 .. 43] + threadDelay 5000000 + a3 <- async $ blips + mapM_ wait [a1, a2, a3] diff --git a/examples/Examples/Ex0_Windowed.hs b/examples/Examples/Ex0_Windowed.hs new file mode 100644 --- /dev/null +++ b/examples/Examples/Ex0_Windowed.hs @@ -0,0 +1,38 @@ +module Examples.Ex0_Windowed (main) where + +import Control.Concurrent (threadDelay) +import Control.Concurrent.Async (async, wait) +import Debug.Trace (traceEventIO) + +import Examples.Common + +main :: IO () +main = do + -- See 'Ex0' on how to tweak the parameters to 'fib' + + traceEventIO "START WINDOW" + do a1 <- async $ mapM_ printFib [30, 32 .. 42] + a2 <- async $ mapM_ printFib [31, 33 .. 43] + threadDelay 5000000 + ax <- async $ blips + mapM_ wait [a1, a2, ax] + traceEventIO "STOP WINDOW" + + traceEventIO "START WINDOW" + do a1 <- async $ mapM_ printFib [29, 32 .. 41] + a2 <- async $ mapM_ printFib [30, 33 .. 42] + a3 <- async $ mapM_ printFib [31, 34 .. 43] + threadDelay 5000000 + ax <- async $ blips + mapM_ wait [a1, a2, a3, ax] + traceEventIO "STOP WINDOW" + + traceEventIO "START WINDOW" + do a1 <- async $ mapM_ printFib [28, 32 .. 40] + a2 <- async $ mapM_ printFib [29, 33 .. 41] + a3 <- async $ mapM_ printFib [30, 34 .. 42] + a4 <- async $ mapM_ printFib [31, 35 .. 43] + threadDelay 5000000 + ax <- async $ blips + mapM_ wait [a1, a2, a3, a4, ax] + traceEventIO "STOP WINDOW" diff --git a/examples/Examples/Ex1.hs b/examples/Examples/Ex1.hs new file mode 100644 --- /dev/null +++ b/examples/Examples/Ex1.hs @@ -0,0 +1,32 @@ +module Examples.Ex1 (main) where + +import Control.Concurrent (myThreadId, threadDelay) +import Control.Concurrent.Async (Async, async, wait) +import Control.Exception (bracket_) +import Debug.Trace (traceEventIO) +import GHC.Conc (labelThread) + +import Examples.Common + +event :: String -> IO a -> IO a +event label = + bracket_ (traceEventIO $ "START " ++ label) + (traceEventIO $ "STOP " ++ label) + +async' :: String -> IO a -> IO (Async a) +async' label act = async $ do + tid <- myThreadId + labelThread tid label + act + +printFib' :: Integer -> IO () +printFib' n = event ("fib" ++ show n) $ printFib n + +main :: IO () +main = do + -- See 'Ex0' on how to tweak the parameters to 'fib' + a1 <- async' "evens" $ mapM_ printFib' [30, 32 .. 42] + a2 <- async' "odds" $ mapM_ printFib' [31, 33 .. 43] + threadDelay 5000000 + a3 <- async' "blips" $ blips + mapM_ wait [a1, a2, a3] 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,6 @@ +cabal-version: 2.2 name: ghc-events-analyze -version: 0.2.8 +version: 0.2.9 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 @@ -24,69 +25,112 @@ The blog post describes the motivation in more detail. -license: BSD3 +license: BSD-3-Clause license-file: LICENSE author: Edsko de Vries, Duncan Coutts, Mikolaj Konarski maintainer: edsko@well-typed.com -copyright: 2013-2014 Well-Typed LLP +copyright: 2013-2025 Well-Typed LLP category: Development, Profiling, Trace build-type: Simple -extra-source-files: ChangeLog -cabal-version: >=1.10 +extra-doc-files: ChangeLog +tested-with: GHC==9.2.8 + GHC==9.4.8 + GHC==9.6.7 + GHC==9.8.4 + GHC==9.10.2 + GHC==9.12.2 + source-repository head type: git location: https://github.com/edsko/ghc-events-analyze +common lang + default-language: GHC2021 + build-depends: base >= 4.16 && < 4.22 + + ghc-options: + -Wall + -Wredundant-constraints + -Wunused-packages + -Wprepositive-qualified-module + -rtsopts + + default-extensions: + DeriveAnyClass + DerivingStrategies + RecordWildCards + ViewPatterns + + if impl(ghc >= 9.8) + ghc-options: -Wno-x-partial + executable ghc-events-analyze - main-is: GHC/RTS/Events/Analyze.hs - other-modules: GHC.RTS.Events.Analyze.Analysis - GHC.RTS.Events.Analyze.Options - GHC.RTS.Events.Analyze.StrictState - GHC.RTS.Events.Analyze.Utils - GHC.RTS.Events.Analyze.Types - GHC.RTS.Events.Analyze.Script - GHC.RTS.Events.Analyze.Script.Standard - GHC.RTS.Events.Analyze.Reports.Totals - GHC.RTS.Events.Analyze.Reports.Timed - GHC.RTS.Events.Analyze.Reports.Timed.SVG + import: lang + hs-source-dirs: src + main-is: GHC/RTS/Events/Analyze.hs - build-depends: base >= 4.9 && < 4.15, - blaze-svg >= 0.3 && < 0.4, - bytestring >= 0.10 && < 0.12, - containers >= 0.5 && < 0.7, - diagrams-lib >= 1.3 && < 1.5, - diagrams-svg >= 1.1 && < 1.5, - filepath >= 1.3 && < 1.5, - ghc-events >= 0.13 && < 0.14, - hashable >= 1.2 && < 1.4, - lens >= 3.10 && < 4.20, - mtl >= 2.2.1 && < 2.3, - optparse-applicative >= 0.11 && < 0.17, - parsec >= 3.1 && < 3.2, - regex-base >= 0.93 && < 0.95, - regex-pcre-builtin >= 0.94 && < 0.96, - SVGFonts >= 1.7 && < 1.8, - text < 1.3, - th-lift >= 0.6 && < 0.9, - th-lift-instances >= 0.1 && < 0.2, - transformers >= 0.3 && < 0.6, - unordered-containers >= 0.2 && < 0.3, - -- No version: whatever is bundled with ghc - template-haskell + other-modules: + GHC.RTS.Events.Analyze.Analysis + GHC.RTS.Events.Analyze.Options + GHC.RTS.Events.Analyze.Reports.Timed + GHC.RTS.Events.Analyze.Reports.Timed.SVG + GHC.RTS.Events.Analyze.Reports.Totals + GHC.RTS.Events.Analyze.Script + GHC.RTS.Events.Analyze.Script.Standard + GHC.RTS.Events.Analyze.StrictState + GHC.RTS.Events.Analyze.Types + GHC.RTS.Events.Analyze.Utils - hs-source-dirs: src - default-language: Haskell2010 - ghc-options: -Wall -rtsopts + build-depends: + -- bundled libraries + , containers >= 0.6 && < 0.8 + , filepath >= 1.4 && < 1.6 + , mtl >= 2.2 && < 2.4 + , parsec >= 3.1 && < 3.2 + , template-haskell >= 2.18 && < 2.24 + , text >= 1.2 && < 2.2 + , transformers >= 0.5 && < 0.7 - default-extensions: NamedFieldPuns - RecordWildCards - NoMonomorphismRestriction - ScopedTypeVariables - ViewPatterns - BangPatterns - RankNTypes - MultiParamTypeClasses - other-extensions: CPP - TemplateHaskell - QuasiQuotes + build-depends: + -- other external dependencies + , diagrams-lib >= 1.5 && < 1.6 + , diagrams-svg >= 1.5 && < 1.6 + , ghc-events >= 0.20 && < 0.21 + , hashable >= 1.4 && < 1.6 + , lens >= 5.3 && < 5.4 + , optparse-applicative >= 0.19 && < 0.20 + , regex-pcre-builtin >= 0.95 && < 0.96 + , SVGFonts >= 1.8 && < 1.9 + , th-lift >= 0.8 && < 0.9 + , th-lift-instances >= 0.1 && < 0.2 + , unordered-containers >= 0.2 && < 0.3 + + other-extensions: + TemplateHaskell + QuasiQuotes + +common blogpost-examples + import: lang + ghc-options: -main-is BlogpostExamples + hs-source-dirs: examples + + other-modules: + Examples.Common + Examples.Ex0 + Examples.Ex0_Windowed + Examples.Ex1 + + build-depends: + , async >= 2.2 && < 2.3 + +test-suite blogpost-examples-nt + import: blogpost-examples + main-is: BlogpostExamples.hs + type: exitcode-stdio-1.0 + +test-suite blogpost-examples-threaded + import: blogpost-examples + type: exitcode-stdio-1.0 + main-is: BlogpostExamples.hs + ghc-options: -threaded diff --git a/src/GHC/RTS/Events/Analyze.hs b/src/GHC/RTS/Events/Analyze.hs --- a/src/GHC/RTS/Events/Analyze.hs +++ b/src/GHC/RTS/Events/Analyze.hs @@ -1,17 +1,16 @@ -{-# LANGUAGE CPP #-} module Main where import Control.Monad (when, forM_) -import qualified Data.List.NonEmpty as NonEmpty +import Data.List.NonEmpty qualified as NonEmpty import Data.Maybe (isNothing) import System.FilePath (replaceExtension, takeFileName) import Text.Parsec.String (parseFromFile) import GHC.RTS.Events.Analyze.Analysis import GHC.RTS.Events.Analyze.Options -import qualified GHC.RTS.Events.Analyze.Reports.Totals as Totals -import qualified GHC.RTS.Events.Analyze.Reports.Timed as Timed -import qualified GHC.RTS.Events.Analyze.Reports.Timed.SVG as TimedSVG +import GHC.RTS.Events.Analyze.Reports.Timed qualified as Timed +import GHC.RTS.Events.Analyze.Reports.Timed.SVG qualified as TimedSVG +import GHC.RTS.Events.Analyze.Reports.Totals qualified as Totals import GHC.RTS.Events.Analyze.Script import GHC.RTS.Events.Analyze.Script.Standard 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,4 +1,3 @@ -{-# LANGUAGE FlexibleContexts, CPP #-} module GHC.RTS.Events.Analyze.Analysis ( -- * Auxiliary readEventLog @@ -12,19 +11,19 @@ , quantize ) where -import Prelude hiding (log) import Control.Applicative ((<|>)) import Control.Lens import Control.Monad (forM_, when, void) -import Data.Maybe (fromMaybe, isNothing) import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as Map +import Data.HashMap.Strict qualified as Map import Data.IntMap.Strict (IntMap) -import qualified Data.IntMap.Strict as IntMap +import Data.IntMap.Strict qualified as IntMap import Data.List.NonEmpty (NonEmpty(..)) -import qualified Data.List.NonEmpty as NonEmpty +import Data.List.NonEmpty qualified as NonEmpty +import Data.Maybe (fromMaybe, isNothing) import Data.Text (Text) -import qualified Data.Text as T +import Data.Text qualified as T +import Prelude hiding (log) import GHC.RTS.Events ( Event(..) @@ -33,7 +32,7 @@ , ThreadStopStatus(..) , Timestamp ) -import qualified GHC.RTS.Events as Events +import GHC.RTS.Events qualified as Events import GHC.RTS.Events.Analyze.Utils import GHC.RTS.Events.Analyze.StrictState (State, execState, put, get, runState) diff --git a/src/GHC/RTS/Events/Analyze/Options.hs b/src/GHC/RTS/Events/Analyze/Options.hs --- a/src/GHC/RTS/Events/Analyze/Options.hs +++ b/src/GHC/RTS/Events/Analyze/Options.hs @@ -1,11 +1,10 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} + module GHC.RTS.Events.Analyze.Options ( Options(..) , parseOptions ) where -import Data.Foldable (asum) import Options.Applicative import GHC.RTS.Events.Analyze.Types diff --git a/src/GHC/RTS/Events/Analyze/Reports/Timed.hs b/src/GHC/RTS/Events/Analyze/Reports/Timed.hs --- a/src/GHC/RTS/Events/Analyze/Reports/Timed.hs +++ b/src/GHC/RTS/Events/Analyze/Reports/Timed.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} module GHC.RTS.Events.Analyze.Reports.Timed ( Report @@ -10,15 +9,15 @@ import Control.Lens (itoList, (^.), over, each, _3) import Data.Function (on) -import Data.List (group, sortBy) +import Data.HashMap.Strict qualified as Map import Data.IntMap.Strict (IntMap) +import Data.IntMap.Strict qualified as IntMap +import Data.List (group, sortBy) import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.IO as T +import Data.Text qualified as T +import Data.Text.IO qualified as T import System.IO (Handle, withFile, IOMode(WriteMode)) import Text.Printf (printf) -import qualified Data.HashMap.Strict as Map -import qualified Data.IntMap.Strict as IntMap import GHC.RTS.Events.Analyze.Analysis import GHC.RTS.Events.Analyze.Script 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,23 +1,23 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE CPP #-} module GHC.RTS.Events.Analyze.Reports.Timed.SVG ( writeReport ) where + import Control.Lens (itoList) -import Data.List (foldl') -import Data.Monoid ((<>)) +import Data.List qualified as List +import Data.Text qualified as T import Diagrams.Backend.SVG (B, renderSVG) import Diagrams.Prelude (QDiagram, Colour, V2, N, Any, (#), (|||)) import GHC.RTS.Events (Timestamp) +import Graphics.SVGFonts (fit_height, set_envelope) import Graphics.SVGFonts.Text (TextOpts(..)) import Text.Printf (printf) -import qualified Data.Text as T -import qualified Diagrams.Prelude as D -import qualified Graphics.SVGFonts.Fonts as F -import qualified Graphics.SVGFonts.Text as F -import qualified Graphics.SVGFonts.ReadFont as F -import qualified Diagrams.TwoD.Text as TT +import Diagrams.Prelude qualified as D +import Diagrams.TwoD.Text qualified as TT +import Graphics.SVGFonts.Fonts qualified as F +import Graphics.SVGFonts.ReadFont qualified as F +import Graphics.SVGFonts.Text qualified as F + import GHC.RTS.Events.Analyze.Types import GHC.RTS.Events.Analyze.Reports.Timed hiding (writeReport) @@ -78,9 +78,11 @@ widestHeader :: Double widestHeader = let headers = [ (header, length header) | SVGLine header _ <- fragments ] - (maxHeader, _) = foldl' (\(s, l) (s', l') -> - if l' > l then (s', l') else (s, l)) - ("", 0) headers + (maxHeader, _) = + List.foldl' + (\(s, l) (s', l') -> if l' > l then (s', l') else (s, l)) + ("", 0) + headers in D.width $! mkSVGText maxHeader (optionsBucketHeight + 2) font data SVGFragment = @@ -96,7 +98,7 @@ go (ReportLine line,c) = uncurry SVGLine $ renderLine options c line renderLine :: Options -> Colour Double -> ReportLine -> (String, D) -renderLine options@Options{..} lc line@ReportLineData{..} = +renderLine options lc line@ReportLineData{..} = ( T.unpack lineHeader -- renderText lineHeader (optionsBucketHeight + 2) , blocks lc <> bgBlocks options lineBackground ) @@ -131,20 +133,16 @@ -- memory hungry in comparison to something simple like 'TT.text'. -- This function should therefore be used as little as possible. mkSVGText :: String -> Double -> F.PreparedFont Double -> D -mkSVGText str size font = - D.stroke textSVG # D.fc D.black # D.lc D.black # D.alignL # D.lw D.none +mkSVGText str size font = textSVG # D.fc D.black # D.lc D.black # D.alignL # D.lw D.none where - textSVG = F.textSVG' (textOpts size font) str + textSVG = F.svgText (textOpts font) str # fit_height size # set_envelope -textOpts :: Double -> F.PreparedFont Double -> TextOpts Double -textOpts size font = +textOpts :: F.PreparedFont Double -> TextOpts Double +textOpts font = TextOpts { textFont = font - , mode = F.INSIDE_H , spacing = F.KERN , underline = False - , textWidth = 0 -- not important - , textHeight = size } -- | Render text with diagram's own engine. The issue with this text @@ -187,8 +185,8 @@ -- memoize the rendering of the last time label: if it's the same -- for the next 10 displays, why render it 10 times? Text is expensive. - in case foldl' (\acc tb -> timelineBlock acc tb) mempty timeBlocks of - (_, _, fullDiag) -> fullDiag + in case List.foldl' (\acc tb -> timelineBlock acc tb) mempty timeBlocks of + (_, _, fullDiag) -> fullDiag where timelineBlockWidth :: Double diff --git a/src/GHC/RTS/Events/Analyze/Reports/Totals.hs b/src/GHC/RTS/Events/Analyze/Reports/Totals.hs --- a/src/GHC/RTS/Events/Analyze/Reports/Totals.hs +++ b/src/GHC/RTS/Events/Analyze/Reports/Totals.hs @@ -11,8 +11,8 @@ import Data.Function (on) import Data.List (sortBy, group) import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.IO as T +import Data.Text qualified as T +import Data.Text.IO qualified as T import GHC.RTS.Events (Timestamp) import System.IO (Handle, withFile, IOMode(WriteMode)) import Text.Printf (printf) 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,10 +1,7 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# OPTIONS_GHC -w -W #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE CPP #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + module GHC.RTS.Events.Analyze.Script ( -- * Types Script @@ -24,18 +21,14 @@ import Control.Applicative (optional) import Data.List (intercalate) import Data.Text (Text) -import qualified Data.Text as T +import Data.Text qualified as T import Instances.TH.Lift () import Language.Haskell.TH.Lift (deriveLiftMany) import Language.Haskell.TH.Quote import Language.Haskell.TH.Syntax import Text.Parsec hiding (optional) import Text.Parsec.Language (haskellDef) -import qualified Text.Parsec.Token as P - -#if !MIN_VERSION_base(4,13,0) -import Control.Monad.Fail (MonadFail) -#endif +import Text.Parsec.Token qualified as P import GHC.RTS.Events.Analyze.Types @@ -175,12 +168,23 @@ ] } -reserved = P.reserved lexer +reserved :: String -> Parser () +reserved = P.reserved lexer + +stringLiteral :: Parser String stringLiteral = P.stringLiteral lexer -natural = P.natural lexer -squares = P.squares lexer -commaSep1 = P.commaSep1 lexer -whiteSpace = P.whiteSpace lexer + +natural :: Parser Integer +natural = P.natural lexer + +squares :: Parser a -> Parser a +squares = P.squares lexer + +commaSep1 :: Parser a -> Parser [a] +commaSep1 = P.commaSep1 lexer + +whiteSpace :: Parser () +whiteSpace = P.whiteSpace lexer {------------------------------------------------------------------------------- Syntax analysis 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 @@ -1,5 +1,4 @@ -- | State monad which forces the state to whnf on every step -{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, CPP #-} module GHC.RTS.Events.Analyze.StrictState ( -- * Transformer StateT @@ -16,18 +15,18 @@ , module Control.Monad.State.Strict ) where +import Control.Monad.Identity (Identity(..)) import Control.Monad.IO.Class (MonadIO) import Control.Monad.State.Strict (MonadState(..)) -import qualified Control.Monad.State.Strict as St +import Control.Monad.State.Strict qualified as St import Control.Monad.Trans.Class (MonadTrans) -import Control.Monad.Identity (Identity(..)) {------------------------------------------------------------------------------- Transformer -------------------------------------------------------------------------------} newtype StateT s m a = StateT { unStateT :: St.StateT s m a } - deriving (Functor, Applicative, Monad, MonadTrans, MonadIO) + deriving newtype (Functor, Applicative, Monad, MonadTrans, MonadIO) runStateT :: StateT s m a -> s -> m (a, s) runStateT = St.runStateT . unStateT diff --git a/src/GHC/RTS/Events/Analyze/Types.hs b/src/GHC/RTS/Events/Analyze/Types.hs --- a/src/GHC/RTS/Events/Analyze/Types.hs +++ b/src/GHC/RTS/Events/Analyze/Types.hs @@ -1,8 +1,6 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TemplateHaskell #-} + module GHC.RTS.Events.Analyze.Types ( -- * Events EventId(..) @@ -45,8 +43,8 @@ import Data.IntMap.Strict (IntMap) import Data.List.NonEmpty (NonEmpty) import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Read as TR +import Data.Text qualified as T +import Data.Text.Read qualified as TR import GHC.Generics import GHC.RTS.Events (Timestamp, ThreadId) import Text.Regex.PCRE @@ -106,7 +104,7 @@ -- If the event name starts with a digit, regard it as a 'EventSubscript'. parseUserEvent :: Text -> EventId parseUserEvent s = - case TR.decimal s of + case TR.signed TR.decimal s of Left _ -> EventUser s 0 Right (eid, cs) -> EventUser (T.dropWhile isSpace cs) eid diff --git a/src/GHC/RTS/Events/Analyze/Utils.hs b/src/GHC/RTS/Events/Analyze/Utils.hs --- a/src/GHC/RTS/Events/Analyze/Utils.hs +++ b/src/GHC/RTS/Events/Analyze/Utils.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} module GHC.RTS.Events.Analyze.Utils ( throwLeft @@ -12,12 +11,12 @@ , showThreadId ) where -import Control.Lens import Control.Exception -import Data.List (transpose) +import Control.Lens import Data.Either (partitionEithers) +import Data.List (transpose) import Data.Text (Text) -import qualified Data.Text as T +import Data.Text qualified as T import GHC.RTS.Events (ThreadId) throwLeft :: Exception e => IO (Either e a) -> IO a