diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,14 @@ +### 0.4.0.0 + +- Add parser for `--stats` flag (`statsParser`). +- Add support for aggregation: + - Add `aggregateByTick`. + - Add `GHC.Eventlog.Live.Machine.Group` module for aggregation. +- **BREAKING**: Change `processHeapProfSampleData` to yield all the metrics + from a single garbage collection pass at once as `HeapProfSampleData`. +- **BREAKING**: Replace `[Attr]` with opaque `Attrs` type. +- **BREAKING**: Log info to stderr with `--verbosity==debug`. + ### 0.3.0.0 - **BREAKING**: Move capability usage analysis machines to their own module. diff --git a/eventlog-live.cabal b/eventlog-live.cabal --- a/eventlog-live.cabal +++ b/eventlog-live.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: eventlog-live -version: 0.3.0.0 +version: 0.4.0.0 synopsis: Live processing of eventlog data. description: This package supports live processing of eventlog data. @@ -64,11 +64,13 @@ DataKinds DeriveFoldable DeriveFunctor + DeriveGeneric DeriveTraversable DerivingStrategies DuplicateRecordFields FlexibleContexts FlexibleInstances + FunctionalDependencies GADTs GeneralizedNewtypeDeriving ImportQualifiedPost @@ -83,6 +85,7 @@ RankNTypes RecordWildCards ScopedTypeVariables + StandaloneDeriving TupleSections TypeApplications TypeFamilies @@ -92,6 +95,7 @@ hs-source-dirs: src exposed-modules: GHC.Eventlog.Live.Data.Attribute + GHC.Eventlog.Live.Data.Group GHC.Eventlog.Live.Data.Metric GHC.Eventlog.Live.Data.Span GHC.Eventlog.Live.Logger diff --git a/src/GHC/Eventlog/Live/Data/Attribute.hs b/src/GHC/Eventlog/Live/Data/Attribute.hs --- a/src/GHC/Eventlog/Live/Data/Attribute.hs +++ b/src/GHC/Eventlog/Live/Data/Attribute.hs @@ -5,6 +5,8 @@ Portability : portable -} module GHC.Eventlog.Live.Data.Attribute ( + Attrs, + toList, Attr, AttrKey, AttrValue (..), @@ -12,12 +14,38 @@ (~=), ) where +import Data.HashMap.Strict (HashMap) +import Data.HashMap.Strict qualified as M +import Data.Hashable (Hashable) import Data.Int (Int16, Int32, Int64, Int8) import Data.Text (Text) import Data.Text qualified as T import Data.Word (Word16, Word32, Word64, Word8) +import GHC.Generics (Generic) +import GHC.IsList (IsList (..)) {- | +A set of attributes is a t`HashMap` +-} +newtype Attrs = Attrs {attrMap :: HashMap AttrKey AttrValue} + deriving (Eq, Generic, Show) + +instance Hashable Attrs + +instance Semigroup Attrs where + (<>) :: Attrs -> Attrs -> Attrs + x <> y = Attrs{attrMap = x.attrMap <> y.attrMap} + +instance IsList Attrs where + type Item Attrs = Attr + + fromList :: [Item Attrs] -> Attrs + fromList = Attrs . M.fromList + + toList :: Attrs -> [Item Attrs] + toList = M.toList . (.attrMap) + +{- | An attribute is a key-value pair where the key is any string and the value is some numeric type, string, or null. Attributes should be constructed using the `(~=)` operator, which automatically converts Haskell types to t`AttrValue`. @@ -58,7 +86,9 @@ | AttrDouble !Double | AttrText !Text | AttrNull - deriving (Show) + deriving (Eq, Generic, Show) + +instance Hashable AttrValue {- | Utility class to help construct values of the t`AttrValue` type. diff --git a/src/GHC/Eventlog/Live/Data/Group.hs b/src/GHC/Eventlog/Live/Data/Group.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Eventlog/Live/Data/Group.hs @@ -0,0 +1,82 @@ +{- | +Module : GHC.Eventlog.Live.Data.Group +Description : Core machines for processing data in batches. +Stability : experimental +Portability : portable +-} +module GHC.Eventlog.Live.Data.Group ( + -- * GroupBy + GroupBy (..), + Group (..), + GroupedBy, + singleton, + elems, + groups, +) where + +import Data.HashMap.Strict (HashMap) +import Data.HashMap.Strict qualified as M +import Data.Hashable (Hashable (..)) +import Data.Kind (Type) +import Data.Semigroup (First (..), Last (..), Max (..), Min (..), Product (..), Sum (..)) + +{- | +This class defines the key to group by when aggregating. +-} +class (Hashable (Key a)) => GroupBy a where + type Key a :: Type + toKey :: a -> Key a + +deriving newtype instance (GroupBy a) => GroupBy (First a) +deriving newtype instance (GroupBy a) => GroupBy (Last a) +deriving newtype instance (GroupBy a) => GroupBy (Max a) +deriving newtype instance (GroupBy a) => GroupBy (Min a) +deriving newtype instance (GroupBy a) => GroupBy (Product a) +deriving newtype instance (GroupBy a) => GroupBy (Sum a) + +{- | +This type defines a set of groups, grouped by the key given by `GroupBy`. +-} +data GroupedBy a = (GroupBy a) => GroupedBy + { groups :: HashMap (Key a) (Group a) + } + +{- | +Internal helper. +This type defines a group representative and the group size. +-} +data Group a = Group + { representative :: !a + , size :: !Word + } + deriving (Show, Functor, Foldable, Traversable) + +{- | +Construct the singleton `GroupedBy`. +-} +singleton :: (GroupBy a) => a -> GroupedBy a +singleton a = GroupedBy{groups = M.singleton (toKey a) Group{representative = a, size = 1}} + +{- | +Get all group representatives from a `GroupedBy`. +-} +elems :: GroupedBy a -> [a] +elems = fmap (.representative) . groups + +{- | +Get all group representatives and sizes from a `GroupedBy`. +-} +groups :: GroupedBy a -> [Group a] +groups = M.elems . (.groups) + +instance (Semigroup a) => Semigroup (Group a) where + (<>) :: Group a -> Group a -> Group a + x <> y = + Group + { representative = x.representative <> y.representative + , size = x.size + y.size + } + +instance (Semigroup a, GroupBy a) => Semigroup (GroupedBy a) where + (<>) :: GroupedBy a -> GroupedBy a -> GroupedBy a + x <> y = GroupedBy{groups = M.unionWith (<>) x.groups y.groups} diff --git a/src/GHC/Eventlog/Live/Data/Metric.hs b/src/GHC/Eventlog/Live/Data/Metric.hs --- a/src/GHC/Eventlog/Live/Data/Metric.hs +++ b/src/GHC/Eventlog/Live/Data/Metric.hs @@ -8,7 +8,9 @@ Metric (..), ) where -import GHC.Eventlog.Live.Data.Attribute (Attr) +import Control.Exception (assert) +import GHC.Eventlog.Live.Data.Attribute (Attrs) +import GHC.Eventlog.Live.Data.Group (GroupBy (..)) import GHC.RTS.Events (Timestamp) {- | @@ -24,7 +26,23 @@ , maybeStartTimeUnixNano :: !(Maybe Timestamp) -- ^ The earliest time at which any measurement could have been taken. -- Usually, this represents the start time of a process. - , attr :: [Attr] - -- ^ A list of attributes. + , attrs :: Attrs + -- ^ A set of attributes. } deriving (Functor, Show) + +instance GroupBy (Metric a) where + type Key (Metric a) = Attrs + toKey :: Metric a -> Attrs + toKey = (.attrs) + +instance (Semigroup a) => Semigroup (Metric a) where + (<>) :: Metric a -> Metric a -> Metric a + x <> y = + assert (x.attrs == y.attrs) $ + Metric + { value = x.value <> y.value + , maybeTimeUnixNano = x.maybeTimeUnixNano `max` y.maybeTimeUnixNano + , maybeStartTimeUnixNano = x.maybeStartTimeUnixNano `min` y.maybeStartTimeUnixNano + , attrs = x.attrs + } diff --git a/src/GHC/Eventlog/Live/Logger.hs b/src/GHC/Eventlog/Live/Logger.hs --- a/src/GHC/Eventlog/Live/Logger.hs +++ b/src/GHC/Eventlog/Live/Logger.hs @@ -104,7 +104,11 @@ Log info messages to `IO.stderr`. -} logInfo :: (HasCallStack, MonadIO m) => Verbosity -> Text -> m () -logInfo = logMessage IO.stdout callStack verbosityInfo +logInfo verbosityThreshold = logMessage handle callStack verbosityInfo verbosityThreshold + where + handle + | verbosityThreshold <= verbosityDebug = IO.stderr + | otherwise = IO.stdout {- | Log debug messages to `IO.stderr`. diff --git a/src/GHC/Eventlog/Live/Machine/Analysis/Capability.hs b/src/GHC/Eventlog/Live/Machine/Analysis/Capability.hs --- a/src/GHC/Eventlog/Live/Machine/Analysis/Capability.hs +++ b/src/GHC/Eventlog/Live/Machine/Analysis/Capability.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} @@ -92,7 +93,7 @@ { value = j.value.startTimeUnixNano - i.endTimeUnixNano , maybeTimeUnixNano = Just i.endTimeUnixNano , maybeStartTimeUnixNano = j.maybeStartTimeUnixNano - , attr = ["cap" ~= cap, "category" ~= ("Idle" :: Text)] + , attrs = ["cap" ~= cap, "category" ~= ("Idle" :: Text)] } -- Yield a duration metric for the current span. let user = capabilityUser j.value @@ -101,7 +102,7 @@ { value = duration j.value , maybeTimeUnixNano = Just j.value.startTimeUnixNano , maybeStartTimeUnixNano = j.maybeStartTimeUnixNano - , attr = ["cap" ~= cap, "category" ~= showCapabilityUserCategory user, "user" ~= user] + , attrs = ["cap" ~= cap, "category" ~= showCapabilityUserCategory user, "user" ~= user] } go (Just j.value) diff --git a/src/GHC/Eventlog/Live/Machine/Analysis/Heap.hs b/src/GHC/Eventlog/Live/Machine/Analysis/Heap.hs --- a/src/GHC/Eventlog/Live/Machine/Analysis/Heap.hs +++ b/src/GHC/Eventlog/Live/Machine/Analysis/Heap.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} @@ -15,6 +16,8 @@ processHeapLiveData, MemReturnData (..), processMemReturnData, + HeapProfSampleData, + heapProfSamples, processHeapProfSampleData, -- ** Heap Profile Breakdown @@ -22,19 +25,21 @@ heapProfBreakdownShow, ) where -import Control.Monad (unless) +import Control.Monad (unless, when) import Control.Monad.IO.Class (MonadIO (..)) import Data.Either (isLeft) +import Data.Foldable (for_) import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict qualified as M import Data.Hashable (Hashable (..)) import Data.List qualified as L import Data.Machine (Process, ProcessT, await, construct, repeatedly, yield) -import Data.Maybe (listToMaybe, mapMaybe) +import Data.Maybe (isJust, listToMaybe, mapMaybe) import Data.Text (Text) import Data.Text qualified as T import Data.Word (Word32, Word64) -import GHC.Eventlog.Live.Data.Attribute (Attr, (~=)) +import GHC.Eventlog.Live.Data.Attribute (Attrs, (~=)) +import GHC.Eventlog.Live.Data.Group (GroupBy (..)) import GHC.Eventlog.Live.Data.Metric (Metric (..)) import GHC.Eventlog.Live.Logger (logWarning) import GHC.Eventlog.Live.Machine.WithStartTime (WithStartTime (..), tryGetTimeUnixNano) @@ -164,7 +169,50 @@ -- HeapProfSample {- | +The type of all heap profile samples from a single garbage collection pass. +-} +newtype HeapProfSampleData = HeapProfSampleData + { heapProfSampleMap :: HashMap Text (Metric Word64) + } + deriving (Show) + deriving newtype (Semigroup, Monoid) + +instance GroupBy HeapProfSampleData where + type Key HeapProfSampleData = () + + toKey :: HeapProfSampleData -> () + toKey = const () + +{- | +Get the elements of a heap profile sample collection. +-} +heapProfSamples :: HeapProfSampleData -> [Metric Word64] +heapProfSamples = M.elems . (.heapProfSampleMap) + +{- | Internal helper. +Insert a heap profiling sample into the collection. +-} +insertHeapProfSampleString :: + forall m. + (MonadIO m) => + Verbosity -> + Text -> + Metric Word64 -> + HeapProfSampleData -> + m HeapProfSampleData +insertHeapProfSampleString verbosityThreshold heapProfLabel heapProfSample heapProfSamples = do + let insert :: Maybe (Metric Word64) -> m (Maybe (Metric Word64)) + insert heapProfSample' = do + when (isJust heapProfSample') $ + logWarning verbosityThreshold $ + "Duplicate HeapProfSampleString for " <> heapProfLabel <> " within the same garbage collection pass." + pure (Just heapProfSample) + heapProfSampleMap' <- M.alterF insert heapProfLabel heapProfSamples.heapProfSampleMap + pure HeapProfSampleData{heapProfSampleMap = heapProfSampleMap'} + +{- | +Internal helper. The type of info table pointers. -} newtype InfoTablePtr = InfoTablePtr Word64 @@ -184,13 +232,13 @@ The type of an info table entry, as produced by the `E.InfoTableProv` event. -} data InfoTable = InfoTable - { infoTablePtr :: InfoTablePtr - , infoTableName :: Text - , infoTableClosureDesc :: Int - , infoTableTyDesc :: Text - , infoTableLabel :: Text - , infoTableModule :: Text - , infoTableSrcLoc :: Text + { infoTablePtr :: !InfoTablePtr + , infoTableName :: !Text + , infoTableClosureDesc :: !Int + , infoTableTyDesc :: !Text + , infoTableLabel :: !Text + , infoTableModule :: !Text + , infoTableSrcLoc :: !Text } deriving (Show) @@ -199,9 +247,10 @@ The type of the state kept by `processHeapProfSampleData`. -} data HeapProfSampleState = HeapProfSampleState - { eitherShouldWarnOrHeapProfBreakdown :: Either Bool HeapProfBreakdown - , infoTableMap :: HashMap InfoTablePtr InfoTable - , heapProfSampleEraStack :: [Word64] + { eitherShouldWarnOrHeapProfBreakdown :: !(Either Bool HeapProfBreakdown) + , infoTableMap :: !(HashMap InfoTablePtr InfoTable) + , heapProfSampleEraStack :: ![Word64] + , maybeHeapProfSampleData :: !(Maybe HeapProfSampleData) } deriving (Show) @@ -238,7 +287,7 @@ (MonadIO m) => Verbosity -> Maybe HeapProfBreakdown -> - ProcessT m (WithStartTime Event) (Metric Word64) + ProcessT m (WithStartTime Event) HeapProfSampleData processHeapProfSampleData verbosityThreshold maybeHeapProfBreakdown = construct $ go @@ -246,9 +295,10 @@ { eitherShouldWarnOrHeapProfBreakdown = maybe (Left True) Right maybeHeapProfBreakdown , infoTableMap = mempty , heapProfSampleEraStack = mempty + , maybeHeapProfSampleData = mempty } where - -- go :: HeapProfSampleState -> PlanT (Is (WithStartTime Event)) (Metric Word64) m Void + -- go :: HeapProfSampleState -> PlanT (Is (WithStartTime Event)) HeapProfSampleData m Void go st@HeapProfSampleState{..} = do await >>= \i -> case i.value.evSpec of -- Announces the heap profile breakdown, amongst other things. @@ -279,25 +329,47 @@ } go st{infoTableMap = M.insert infoTablePtr infoTable infoTableMap} -- Announces the beginning of a heap profile sample. - E.HeapProfSampleBegin{..} -> - go st{heapProfSampleEraStack = heapProfSampleEra : heapProfSampleEraStack} + E.HeapProfSampleBegin{..} -> do + -- Check that maybeHeapProfSampleData is Nothing. + for_ st.maybeHeapProfSampleData $ \heapProfSampleData -> do + logWarning + verbosityThreshold + "Unexpected event HeapProfSampleBegin while previous garbage collection pass was left open.\n\ + \This may indicate that the eventlog is not properly ordered or that its semantics have changed." + -- Yield the previous sample data anyway. + yield heapProfSampleData + -- Start a new garbage collection pass. + go + st + { heapProfSampleEraStack = heapProfSampleEra : heapProfSampleEraStack + , maybeHeapProfSampleData = Just mempty + } -- Announces the end of a heap profile sample. - E.HeapProfSampleEnd{..} -> - case L.uncons heapProfSampleEraStack of - Nothing -> do - logWarning verbosityThreshold . T.pack $ - printf - "Eventlog closed era %d, but there is no current era." - heapProfSampleEra - go st - Just (currentEra, heapProfSampleEraStack') -> do - unless (currentEra == heapProfSampleEra) $ + E.HeapProfSampleEnd{..} -> do + -- Yield the previous heap profile sample data + for_ st.maybeHeapProfSampleData yield + -- Pop the heapProfSampleEraStack + heapProfSampleEraStack' <- + case L.uncons heapProfSampleEraStack of + Nothing -> do logWarning verbosityThreshold . T.pack $ printf - "Eventlog closed era %d, but the current era is era %d." + "Eventlog closed era %d, but there is no current era." heapProfSampleEra - currentEra - go st{heapProfSampleEraStack = heapProfSampleEraStack'} + pure heapProfSampleEraStack + Just (currentEra, heapProfSampleEraStack') -> do + unless (currentEra == heapProfSampleEra) $ + logWarning verbosityThreshold . T.pack $ + printf + "Eventlog closed era %d, but the current era is era %d." + heapProfSampleEra + currentEra + pure heapProfSampleEraStack' + go + st + { heapProfSampleEraStack = heapProfSampleEraStack' + , maybeHeapProfSampleData = Nothing + } -- Announces a heap profile sample. E.HeapProfSampleString{..} -- If there is no heap profile breakdown, issue a warning, then disable warnings. @@ -323,21 +395,41 @@ !infoTablePtr <- readMaybe (T.unpack heapProfLabel) M.lookup infoTablePtr infoTableMap | otherwise = Nothing - yield $ - metric i heapProfResidency $ - [ "evCap" ~= i.value.evCap - , "heapProfBreakdown" ~= heapProfBreakdownShow heapProfBreakdown - , "heapProfId" ~= heapProfId - , "heapProfLabel" ~= heapProfLabel - , "heapProfSampleEra" ~= (fst <$> L.uncons heapProfSampleEraStack) - , "infoTableName" ~= fmap (.infoTableName) maybeInfoTable - , "infoTableClosureDesc" ~= fmap (.infoTableClosureDesc) maybeInfoTable - , "infoTableTyDesc" ~= fmap (.infoTableTyDesc) maybeInfoTable - , "infoTableLabel" ~= fmap (.infoTableLabel) maybeInfoTable - , "infoTableModule" ~= fmap (.infoTableModule) maybeInfoTable - , "infoTableSrcLoc" ~= fmap (.infoTableSrcLoc) maybeInfoTable - ] - go $ if isHeapProfBreakdownInfoTable heapProfBreakdown then st else st{infoTableMap = mempty} + -- Get the HeapProfSampleData + heapProfSampleData <- + case st.maybeHeapProfSampleData of + Nothing -> do + logWarning verbosityThreshold $ + "Unexpected event HeapProfSampleString out of scope of HeapProfSampleBegin and HeapProfSampleEnd.\n\ + \This may indicate that the eventlog is not properly ordered or that its semantics have changed." + pure mempty + Just heapProfSampleData -> + pure heapProfSampleData + -- Update the HeapProfSampleData + let heapProfSample = + metric i heapProfResidency $ + [ "evCap" ~= i.value.evCap + , "heapProfBreakdown" ~= heapProfBreakdownShow heapProfBreakdown + , "heapProfId" ~= heapProfId + , "heapProfLabel" ~= heapProfLabel + , "heapProfSampleEra" ~= (fst <$> L.uncons heapProfSampleEraStack) + , "infoTableName" ~= fmap (.infoTableName) maybeInfoTable + , "infoTableClosureDesc" ~= fmap (.infoTableClosureDesc) maybeInfoTable + , "infoTableTyDesc" ~= fmap (.infoTableTyDesc) maybeInfoTable + , "infoTableLabel" ~= fmap (.infoTableLabel) maybeInfoTable + , "infoTableModule" ~= fmap (.infoTableModule) maybeInfoTable + , "infoTableSrcLoc" ~= fmap (.infoTableSrcLoc) maybeInfoTable + ] + heapProfSampleData' <- + insertHeapProfSampleString verbosityThreshold heapProfLabel heapProfSample heapProfSampleData + -- Continue with the updated HeapProfSampleState + go + st + { -- If we're not profiling with -hi, discard the info table map + infoTableMap = if isHeapProfBreakdownInfoTable heapProfBreakdown then st.infoTableMap else mempty + , -- Add the update HeapProfSampleData + maybeHeapProfSampleData = Just heapProfSampleData' + } _otherwise -> go st {- | @@ -427,12 +519,12 @@ metric :: WithStartTime Event -> v -> - [Attr] -> + Attrs -> Metric v -metric i v attr = +metric i v attrs = Metric { value = v , maybeTimeUnixNano = tryGetTimeUnixNano i , maybeStartTimeUnixNano = i.maybeStartTimeUnixNano - , attr = attr + , attrs = attrs } diff --git a/src/GHC/Eventlog/Live/Machine/Core.hs b/src/GHC/Eventlog/Live/Machine/Core.hs --- a/src/GHC/Eventlog/Live/Machine/Core.hs +++ b/src/GHC/Eventlog/Live/Machine/Core.hs @@ -13,9 +13,10 @@ batchToTick, batchListToTick, batchByTickList, - liftTick, dropTick, onlyTick, + aggregateByTick, + liftTick, liftBatch, -- * Debug @@ -48,7 +49,7 @@ import Data.HashMap.Strict qualified as M import Data.Hashable (Hashable (..)) import Data.List qualified as L -import Data.Machine (Is (..), MachineT (..), Moore (..), PlanT, Process, ProcessT, Step (..), await, construct, encased, mapping, repeatedly, starve, stopped, yield, (~>)) +import Data.Machine (Is (..), MachineT (..), Moore (..), PlanT, Process, ProcessT, Step (..), asParts, await, construct, encased, mapping, repeatedly, starve, stopped, yield, (~>)) import Data.Maybe (fromMaybe) import Data.Semigroup (Max (..)) import Data.Text (Text) @@ -85,12 +86,14 @@ Generalised version of `batchByTickList`. -} batchByTick :: - forall m a. - (Monad m, Monoid a) => - ProcessT m (Tick a) a + forall a. + (Monoid a) => Process (Tick a) a batchByTick = batchByTickWith mempty where - batchByTickWith :: a -> MachineT m (Is (Tick a)) a + batchByTickWith :: + forall m. + (Monad m) => + a -> MachineT m (Is (Tick a)) a batchByTickWith acc = MachineT $ pure $ Await onNext Refl onStop where onNext :: Tick a -> MachineT m (Is (Tick a)) a @@ -135,6 +138,19 @@ Tick -> yield () Item{} -> pure () +{- | +This machine aggregates a value by tick. + +The difference between `batchByTick` and `aggregateByTick` is that +`batchByTick` yields a batch on every tick whereas +`aggregateByTick` only yields a batch if there were any values. +-} +aggregateByTick :: (Semigroup a) => Process (Tick a) a +aggregateByTick = + mapping (fmap Just) + ~> batchByTick + ~> asParts + ------------------------------------------------------------------------------- -- Machine combinators ------------------------------------------------------------------------------- @@ -150,14 +166,14 @@ Text -> (a -> Word) -> ProcessT m a x -counterBy verbosity label count +counterBy verbosity label counter | verbosityDebug >= verbosity = repeatedly go | otherwise = stopped where go :: PlanT (Is a) x m () go = await >>= \a -> - logDebug verbosity ("saw " <> T.pack (show (count a)) <> " " <> label) + logDebug verbosity (T.pack (show (counter a)) <> " " <> label) {- | This machine counts the number of inputs it received, @@ -177,7 +193,7 @@ go count = await >>= \case Item _ -> go (count + 1) - Tick -> logDebug verbosity ("saw " <> T.pack (show count) <> " " <> label) >> go 0 + Tick -> logDebug verbosity (T.pack (show count) <> " " <> label) >> go 0 ------------------------------------------------------------------------------- -- Machine combinators diff --git a/src/GHC/Eventlog/Live/Options.hs b/src/GHC/Eventlog/Live/Options.hs --- a/src/GHC/Eventlog/Live/Options.hs +++ b/src/GHC/Eventlog/Live/Options.hs @@ -13,6 +13,7 @@ eventlogLogFileParser, batchIntervalParser, verbosityParser, + statsParser, ) where import Control.Applicative (asum) @@ -24,7 +25,7 @@ import Text.Read (readEither) -------------------------------------------------------------------------------- --- Eventlog Socket +-- Eventlog Source {- | The type of eventlog sockets. @@ -187,3 +188,14 @@ "info" -> Right verbosityInfo "debug" -> Right verbosityDebug _otherwise -> Left $ "Could not parse verbosity '" <> rawVerbosity <> "'." + +-------------------------------------------------------------------------------- +-- Statistics + +statsParser :: O.Parser Bool +statsParser = + O.flag False True $ + ( O.short 's' + <> O.long "stats" + <> O.help "Display runtime statistics." + )