ghc-events-analyze 0.2.8 → 0.2.9
raw patch · 18 files changed
+303/−133 lines, 18 filesdep +asyncdep −blaze-svgdep −bytestringdep −regex-basedep ~SVGFontsdep ~basedep ~containers
Dependencies added: async
Dependencies removed: blaze-svg, bytestring, regex-base
Dependency ranges changed: SVGFonts, base, containers, diagrams-lib, diagrams-svg, filepath, ghc-events, hashable, lens, mtl, optparse-applicative, regex-pcre-builtin, template-haskell, text, th-lift, transformers
Files
- ChangeLog +6/−0
- LICENSE +1/−1
- examples/BlogpostExamples.hs +17/−0
- examples/Examples/Common.hs +23/−0
- examples/Examples/Ex0.hs +16/−0
- examples/Examples/Ex0_Windowed.hs +38/−0
- examples/Examples/Ex1.hs +32/−0
- ghc-events-analyze.cabal +97/−53
- src/GHC/RTS/Events/Analyze.hs +4/−5
- src/GHC/RTS/Events/Analyze/Analysis.hs +7/−8
- src/GHC/RTS/Events/Analyze/Options.hs +1/−2
- src/GHC/RTS/Events/Analyze/Reports/Timed.hs +5/−6
- src/GHC/RTS/Events/Analyze/Reports/Timed/SVG.hs +22/−24
- src/GHC/RTS/Events/Analyze/Reports/Totals.hs +2/−2
- src/GHC/RTS/Events/Analyze/Script.hs +21/−17
- src/GHC/RTS/Events/Analyze/StrictState.hs +3/−4
- src/GHC/RTS/Events/Analyze/Types.hs +5/−7
- src/GHC/RTS/Events/Analyze/Utils.hs +3/−4
ChangeLog view
@@ -1,3 +1,9 @@+0.2.9++ * Support `ghc-9.6.5` and `SVGFonts-1.8`+ (2025-07-19 Vladimir Ovechkin <vovechkin@anduril.com>)+ * Drop support for `ghc < 9.2`, general cleanup.+ 0.2.8 * Support for ghc-events-0.13
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2013-2014 Well-Typed LLP+Copyright (c) 2013-2025 Well-Typed LLP All rights reserved.
+ examples/BlogpostExamples.hs view
@@ -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
+ examples/Examples/Common.hs view
@@ -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"+
+ examples/Examples/Ex0.hs view
@@ -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]
+ examples/Examples/Ex0_Windowed.hs view
@@ -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"
+ examples/Examples/Ex1.hs view
@@ -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]
ghc-events-analyze.cabal view
@@ -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 <http://www.well-typed.com/blog/2014/02/ghc-events-analyze/ Performance profiling with ghc-events-analyze> 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
src/GHC/RTS/Events/Analyze.hs view
@@ -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
src/GHC/RTS/Events/Analyze/Analysis.hs view
@@ -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)
src/GHC/RTS/Events/Analyze/Options.hs view
@@ -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
src/GHC/RTS/Events/Analyze/Reports/Timed.hs view
@@ -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
src/GHC/RTS/Events/Analyze/Reports/Timed/SVG.hs view
@@ -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
src/GHC/RTS/Events/Analyze/Reports/Totals.hs view
@@ -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)
src/GHC/RTS/Events/Analyze/Script.hs view
@@ -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
src/GHC/RTS/Events/Analyze/StrictState.hs view
@@ -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
src/GHC/RTS/Events/Analyze/Types.hs view
@@ -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
src/GHC/RTS/Events/Analyze/Utils.hs view
@@ -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