{- |
Module      : GHC.Eventlog.Live.Machine.WithStartTime
Description : Machines for processing eventlog data.
Stability   : experimental
Portability : portable
-}
module GHC.Eventlog.Live.Machine.WithStartTime (
  WithStartTime (..),
  setWithStartTime'value,
  tryGetTimeUnixNano,
  withStartTime,
  withStartTime',
  dropStartTime,
) where

import Control.Monad (forever)
import Data.Machine (Is (..), PlanT, Process, await, construct, mapping, yield)
import GHC.RTS.Events (Event (..), EventInfo, Timestamp)
import GHC.RTS.Events qualified as E

-------------------------------------------------------------------------------
-- Start time

{- |
Data decorated with a start time in nanoseconds since the Unix epoch.
-}
data WithStartTime a = WithStartTime
  { forall a. WithStartTime a -> a
value :: !a
  , forall a. WithStartTime a -> Maybe Timestamp
maybeStartTimeUnixNano :: !(Maybe Timestamp)
  }
  deriving ((forall a b. (a -> b) -> WithStartTime a -> WithStartTime b)
-> (forall a b. a -> WithStartTime b -> WithStartTime a)
-> Functor WithStartTime
forall a b. a -> WithStartTime b -> WithStartTime a
forall a b. (a -> b) -> WithStartTime a -> WithStartTime b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> WithStartTime a -> WithStartTime b
fmap :: forall a b. (a -> b) -> WithStartTime a -> WithStartTime b
$c<$ :: forall a b. a -> WithStartTime b -> WithStartTime a
<$ :: forall a b. a -> WithStartTime b -> WithStartTime a
Functor, Int -> WithStartTime a -> ShowS
[WithStartTime a] -> ShowS
WithStartTime a -> String
(Int -> WithStartTime a -> ShowS)
-> (WithStartTime a -> String)
-> ([WithStartTime a] -> ShowS)
-> Show (WithStartTime a)
forall a. Show a => Int -> WithStartTime a -> ShowS
forall a. Show a => [WithStartTime a] -> ShowS
forall a. Show a => WithStartTime a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> WithStartTime a -> ShowS
showsPrec :: Int -> WithStartTime a -> ShowS
$cshow :: forall a. Show a => WithStartTime a -> String
show :: WithStartTime a -> String
$cshowList :: forall a. Show a => [WithStartTime a] -> ShowS
showList :: [WithStartTime a] -> ShowS
Show)

{- |
Setter for the value of a t`WithStartTime`
-}
setWithStartTime'value :: WithStartTime a -> b -> WithStartTime b
setWithStartTime'value :: forall a b. WithStartTime a -> b -> WithStartTime b
setWithStartTime'value (WithStartTime a
_a Maybe Timestamp
t) b
b = b -> Maybe Timestamp -> WithStartTime b
forall a. a -> Maybe Timestamp -> WithStartTime a
WithStartTime b
b Maybe Timestamp
t

{- |
If the event has a start time, return `Just` the time of the event in
nanoseconds since the Unix epoch. Otherwise, return `Nothing`.
-}
tryGetTimeUnixNano :: WithStartTime Event -> Maybe Timestamp
tryGetTimeUnixNano :: WithStartTime Event -> Maybe Timestamp
tryGetTimeUnixNano WithStartTime Event
i = (WithStartTime Event
i.value.evTime Timestamp -> Timestamp -> Timestamp
forall a. Num a => a -> a -> a
+) (Timestamp -> Timestamp) -> Maybe Timestamp -> Maybe Timestamp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WithStartTime Event
i.maybeStartTimeUnixNano

{- |
Wrap every event in t`WithStartTime`. Every event after `E.WallClockTime` will
have its start time field set to `Just` the process start time.

This machine swallows the first and only `E.WallClockTime` event.
-}
withStartTime :: Process Event (WithStartTime Event)
withStartTime :: Process Event (WithStartTime Event)
withStartTime = (Event -> EventInfo)
-> (Event -> Maybe Timestamp -> WithStartTime Event)
-> Process Event (WithStartTime Event)
forall a b.
(a -> EventInfo) -> (a -> Maybe Timestamp -> b) -> Process a b
withStartTime' Event -> EventInfo
E.evSpec Event -> Maybe Timestamp -> WithStartTime Event
forall a. a -> Maybe Timestamp -> WithStartTime a
WithStartTime

{- |
Generalised version of `withStartTime` that can be adapted to work on arbitrary
types using a getter and a setter.
-}
withStartTime' :: (a -> EventInfo) -> (a -> Maybe Timestamp -> b) -> Process a b
withStartTime' :: forall a b.
(a -> EventInfo) -> (a -> Maybe Timestamp -> b) -> Process a b
withStartTime' a -> EventInfo
getEventInfo a -> Maybe Timestamp -> b
setStartTime = PlanT (Is a) b m a -> MachineT m (Is a) b
forall (m :: * -> *) (k :: * -> *) o a.
Monad m =>
PlanT k o m a -> MachineT m k o
construct PlanT (Is a) b m a
start
 where
  start :: PlanT (Is a) b m a
start =
    PlanT (Is a) b m a
Plan (Is a) b a
forall (k :: * -> * -> *) i o. Category k => Plan (k i) o i
await PlanT (Is a) b m a
-> (a -> PlanT (Is a) b m a) -> PlanT (Is a) b m a
forall a b.
PlanT (Is a) b m a
-> (a -> PlanT (Is a) b m b) -> PlanT (Is a) b m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      a
value
        -- The `WallClockTime` event announces the wall-clock time at which the
        -- process was started.
        | E.WallClockTime{Word32
Timestamp
capset :: Word32
sec :: Timestamp
nsec :: Word32
capset :: EventInfo -> Word32
nsec :: EventInfo -> Word32
sec :: EventInfo -> Timestamp
..} <- a -> EventInfo
getEventInfo a
value -> do
            -- This will start overflowing on Sunday, 21 July 2554 23:34:33, UTC.
            let !startTimeNs :: Timestamp
startTimeNs = Timestamp
sec Timestamp -> Timestamp -> Timestamp
forall a. Num a => a -> a -> a
* Timestamp
1_000_000_000 Timestamp -> Timestamp -> Timestamp
forall a. Num a => a -> a -> a
+ Word32 -> Timestamp
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
nsec
            -- We do not re-emit the `WallClockTime` event.
            Timestamp -> PlanT (Is a) b m a
continue Timestamp
startTimeNs
        | Bool
otherwise ->
            b -> Plan (Is a) b ()
forall o (k :: * -> *). o -> Plan k o ()
yield (a
value a -> Maybe Timestamp -> b
`setStartTime` Maybe Timestamp
forall a. Maybe a
Nothing) PlanT (Is a) b m () -> PlanT (Is a) b m a -> PlanT (Is a) b m a
forall a b.
PlanT (Is a) b m a -> PlanT (Is a) b m b -> PlanT (Is a) b m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> PlanT (Is a) b m a
start
  continue :: Timestamp -> PlanT (Is a) b m a
continue Timestamp
startTimeUnixNano =
    (a -> b) -> PlanT (Is a) b m a
forall a b (m :: * -> *). (a -> b) -> PlanT (Is a) b m a
mappingPlan ((a -> b) -> PlanT (Is a) b m a) -> (a -> b) -> PlanT (Is a) b m a
forall a b. (a -> b) -> a -> b
$ \a
value ->
      a
value a -> Maybe Timestamp -> b
`setStartTime` Timestamp -> Maybe Timestamp
forall a. a -> Maybe a
Just Timestamp
startTimeUnixNano

{- |
Drop the t`WithStartTime` wrapper.
-}
dropStartTime :: Process (WithStartTime a) a
dropStartTime :: forall a (m :: * -> *).
Monad m =>
MachineT m (Is (WithStartTime a)) a
dropStartTime = (WithStartTime a -> a) -> Machine (Is (WithStartTime a)) a
forall (k :: * -> * -> *) a b.
Category k =>
(a -> b) -> Machine (k a) b
mapping (.value)

{- |
Internal helper. Variant of `mapping` for plans.
-}
mappingPlan :: (a -> b) -> PlanT (Is a) b m a
mappingPlan :: forall a b (m :: * -> *). (a -> b) -> PlanT (Is a) b m a
mappingPlan a -> b
f = PlanT (Is a) b m () -> PlanT (Is a) b m a
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (PlanT (Is a) b m a
Plan (Is a) b a
forall (k :: * -> * -> *) i o. Category k => Plan (k i) o i
await PlanT (Is a) b m a
-> (a -> PlanT (Is a) b m ()) -> PlanT (Is a) b m ()
forall a b.
PlanT (Is a) b m a
-> (a -> PlanT (Is a) b m b) -> PlanT (Is a) b m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
a -> b -> Plan (Is a) b ()
forall o (k :: * -> *). o -> Plan k o ()
yield (a -> b
f a
a))