{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneKindSignatures #-}

-- |
-- Description : EventBackend for rendering events as Haskell values
-- Copyright   : Copyright 2023 Shea Levy.
-- License     : Apache-2.0
-- Maintainer  : shea@shealevy.com
module Observe.Event.Render.InMemory
  ( listInMemoryBackend,
    timelessListInMemoryBackend,
    inMemoryBackend,

    -- * MemoryEvent
    MemoryEvent (..),
    TimedEventAction (..),
    EventAction (..),

    -- * Effects

    -- ** InMemoryEffects
    InMemoryEffects (..),
    hoistInMemoryEffects,
    listInMemoryEffects,
    timelessListInMemoryEffects,

    -- ** AppendVectorEffects
    AppendVectorEffects (..),
    hoistAppendVectorEffects,
    ListAppendVector (..),
    listAppendVectorEffects,

    -- ** TimestampEffects
    TimestampEffects (..),
    hoistTimestampEffects,
    dummyTimestampEffects,
    ioTimestampEffects,
  )
where

import Control.Exception
import Control.Monad
import Control.Monad.Primitive
import Data.Kind
import Data.Maybe
import Data.Primitive.MutVar
import Data.Time.Clock
import Observe.Event.Backend

-- | An 'EventBackend' whose 'Event's are essentially plain Haskell values.
--
-- The 'reference' of an 'Event' from this 'EventBackend' will be a 'MemoryEvent',
-- which can be examined to extract information about the 'Event'.
listInMemoryBackend ::
  -- | Notify of an 'Event' with no parents or causes
  (MemoryEvent IO (ListAppendVector IO) UTCTime s -> IO ()) ->
  EventBackend IO (MemoryEvent IO (ListAppendVector IO) UTCTime s) s
listInMemoryBackend :: forall (s :: * -> *).
(MemoryEvent IO (ListAppendVector IO) UTCTime s -> IO ())
-> EventBackend
     IO (MemoryEvent IO (ListAppendVector IO) UTCTime s) s
listInMemoryBackend = forall (m :: * -> *) (appvec :: * -> *) ts (s :: * -> *).
Monad m =>
InMemoryEffects m appvec ts
-> (MemoryEvent m appvec ts s -> m ())
-> EventBackend m (MemoryEvent m appvec ts s) s
inMemoryBackend InMemoryEffects IO (ListAppendVector IO) UTCTime
listInMemoryEffects

-- | An 'EventBackend' whose 'Event's are essentially plain Haskell values.
--
-- The 'reference' of an 'Event' from this 'EventBackend' will be a 'MemoryEvent',
-- which can be examined to extract information about the 'Event'.
timelessListInMemoryBackend ::
  (PrimMonad m) =>
  -- | Notify of an 'Event' with no parents or causes
  (MemoryEvent m (ListAppendVector m) () s -> m ()) ->
  EventBackend m (MemoryEvent m (ListAppendVector m) () s) s
timelessListInMemoryBackend :: forall (m :: * -> *) (s :: * -> *).
PrimMonad m =>
(MemoryEvent m (ListAppendVector m) () s -> m ())
-> EventBackend m (MemoryEvent m (ListAppendVector m) () s) s
timelessListInMemoryBackend = forall (m :: * -> *) (appvec :: * -> *) ts (s :: * -> *).
Monad m =>
InMemoryEffects m appvec ts
-> (MemoryEvent m appvec ts s -> m ())
-> EventBackend m (MemoryEvent m appvec ts s) s
inMemoryBackend forall (m :: * -> *).
PrimMonad m =>
InMemoryEffects m (ListAppendVector m) ()
timelessListInMemoryEffects

-- | An 'EventBackend' whose 'Event's are essentially plain Haskell values.
--
-- The 'reference' of an 'Event' from this 'EventBackend' will be a 'MemoryEvent',
-- which can be examined to extract information about the 'Event'.
--
-- [@appvec@]: An append-only vector type, see 'AppendVectorEffects'
-- [@ts@]: A timestamp, see 'TimestampEffects'
inMemoryBackend ::
  (Monad m) =>
  InMemoryEffects m appvec ts ->
  -- | Notify of an 'Event' with no parents or causes
  (MemoryEvent m appvec ts s -> m ()) ->
  EventBackend m (MemoryEvent m appvec ts s) s
inMemoryBackend :: forall (m :: * -> *) (appvec :: * -> *) ts (s :: * -> *).
Monad m =>
InMemoryEffects m appvec ts
-> (MemoryEvent m appvec ts s -> m ())
-> EventBackend m (MemoryEvent m appvec ts s) s
inMemoryBackend (InMemoryEffects {TimestampEffects m ts
AppendVectorEffects m appvec
timestampEffects :: forall (m :: * -> *) (appvec :: * -> *) ts.
InMemoryEffects m appvec ts -> TimestampEffects m ts
appendVectorEffects :: forall (m :: * -> *) (appvec :: * -> *) ts.
InMemoryEffects m appvec ts -> AppendVectorEffects m appvec
timestampEffects :: TimestampEffects m ts
appendVectorEffects :: AppendVectorEffects m appvec
..}) MemoryEvent m appvec ts s -> m ()
emitDisconnectedEvent =
  EventBackend
    { newEvent :: forall f.
NewEventArgs (MemoryEvent m appvec ts s) s f
-> m (Event m (MemoryEvent m appvec ts s) f)
newEvent = \NewEventArgs (MemoryEvent m appvec ts s) s f
initArgs -> do
        ts
start <- m ts
getTimestamp
        appvec (TimedEventAction ts f)
dynamicValues <- forall a. m (appvec a)
newVector
        appvec (MemoryEvent m appvec ts s)
childEvents <- forall a. m (appvec a)
newVector
        appvec (MemoryEvent m appvec ts s)
causedEvents <- forall a. m (appvec a)
newVector
        let reference :: MemoryEvent m appvec ts s
reference = MemoryEvent {dynamicValues :: Maybe (appvec (TimedEventAction ts f))
dynamicValues = forall a. a -> Maybe a
Just appvec (TimedEventAction ts f)
dynamicValues, ts
appvec (MemoryEvent m appvec ts s)
NewEventArgs (MemoryEvent m appvec ts s) s f
causedEvents :: appvec (MemoryEvent m appvec ts s)
childEvents :: appvec (MemoryEvent m appvec ts s)
start :: ts
initArgs :: NewEventArgs (MemoryEvent m appvec ts s) s f
causedEvents :: appvec (MemoryEvent m appvec ts s)
childEvents :: appvec (MemoryEvent m appvec ts s)
start :: ts
initArgs :: NewEventArgs (MemoryEvent m appvec ts s) s f
..}
        Bool
hasParents <-
          forall a. Maybe a -> Bool
isJust
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse
              (\(MemoryEvent {childEvents :: forall (m :: * -> *) (appvec :: * -> *) ts (s :: * -> *).
MemoryEvent m appvec ts s -> appvec (MemoryEvent m appvec ts s)
childEvents = appvec (MemoryEvent m appvec ts s)
cevs}) -> forall a. appvec a -> a -> m ()
appendVector appvec (MemoryEvent m appvec ts s)
cevs MemoryEvent m appvec ts s
reference)
              (forall r (s :: * -> *) f. NewEventArgs r s f -> Maybe r
newEventParent NewEventArgs (MemoryEvent m appvec ts s) s f
initArgs)
        Bool
hasCauses <-
          Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse
              (\(MemoryEvent {causedEvents :: forall (m :: * -> *) (appvec :: * -> *) ts (s :: * -> *).
MemoryEvent m appvec ts s -> appvec (MemoryEvent m appvec ts s)
causedEvents = appvec (MemoryEvent m appvec ts s)
cevs}) -> forall a. appvec a -> a -> m ()
appendVector appvec (MemoryEvent m appvec ts s)
cevs MemoryEvent m appvec ts s
reference)
              (forall r (s :: * -> *) f. NewEventArgs r s f -> [r]
newEventCauses NewEventArgs (MemoryEvent m appvec ts s) s f
initArgs)
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
hasParents Bool -> Bool -> Bool
|| Bool
hasCauses) forall a b. (a -> b) -> a -> b
$ MemoryEvent m appvec ts s -> m ()
emitDisconnectedEvent MemoryEvent m appvec ts s
reference
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
          Event
            { addField :: f -> m ()
addField = \f
f -> do
                ts
eventTime <- m ts
getTimestamp
                forall a. appvec a -> a -> m ()
appendVector appvec (TimedEventAction ts f)
dynamicValues forall a b. (a -> b) -> a -> b
$ TimedEventAction {act :: EventAction f
act = forall f. f -> EventAction f
AddField f
f, ts
eventTime :: ts
eventTime :: ts
..},
              finalize :: Maybe SomeException -> m ()
finalize = \Maybe SomeException
me -> do
                ts
eventTime <- m ts
getTimestamp
                forall a. appvec a -> a -> m ()
appendVector appvec (TimedEventAction ts f)
dynamicValues forall a b. (a -> b) -> a -> b
$ TimedEventAction {act :: EventAction f
act = forall f. Maybe SomeException -> EventAction f
Finalize Maybe SomeException
me, ts
eventTime :: ts
eventTime :: ts
..},
              MemoryEvent m appvec ts s
reference :: MemoryEvent m appvec ts s
reference :: MemoryEvent m appvec ts s
..
            },
      emitImmediateEvent :: forall f.
NewEventArgs (MemoryEvent m appvec ts s) s f
-> m (MemoryEvent m appvec ts s)
emitImmediateEvent = \NewEventArgs (MemoryEvent m appvec ts s) s f
initArgs -> do
        ts
start <- m ts
getTimestamp
        let dynamicValues :: Maybe a
dynamicValues = forall a. Maybe a
Nothing
        appvec (MemoryEvent m appvec ts s)
childEvents <- forall a. m (appvec a)
newVector
        appvec (MemoryEvent m appvec ts s)
causedEvents <- forall a. m (appvec a)
newVector
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ MemoryEvent {ts
appvec (MemoryEvent m appvec ts s)
NewEventArgs (MemoryEvent m appvec ts s) s f
forall a. Maybe a
causedEvents :: appvec (MemoryEvent m appvec ts s)
childEvents :: appvec (MemoryEvent m appvec ts s)
dynamicValues :: forall a. Maybe a
start :: ts
initArgs :: NewEventArgs (MemoryEvent m appvec ts s) s f
causedEvents :: appvec (MemoryEvent m appvec ts s)
childEvents :: appvec (MemoryEvent m appvec ts s)
start :: ts
initArgs :: NewEventArgs (MemoryEvent m appvec ts s) s f
dynamicValues :: Maybe (appvec (TimedEventAction ts f))
..}
    }
  where
    AppendVectorEffects {forall a. m (appvec a)
forall a. appvec a -> a -> m ()
appendVector :: forall (m :: * -> *) (appvec :: * -> *).
AppendVectorEffects m appvec -> forall a. appvec a -> a -> m ()
newVector :: forall (m :: * -> *) (appvec :: * -> *).
AppendVectorEffects m appvec -> forall a. m (appvec a)
appendVector :: forall a. appvec a -> a -> m ()
newVector :: forall a. m (appvec a)
..} = AppendVectorEffects m appvec
appendVectorEffects
    TimestampEffects {m ts
getTimestamp :: forall (m :: * -> *) ts. TimestampEffects m ts -> m ts
getTimestamp :: m ts
..} = TimestampEffects m ts
timestampEffects

-- | An plain data type representing an 'Event'
--
-- [@appvec@]: An append-only vector type, see 'AppendVectorEffects'
-- [@ts@]: A timestamp, see 'TimestampEffects'
type MemoryEvent :: (Type -> Type) -> (Type -> Type) -> Type -> (Type -> Type) -> Type
data MemoryEvent m appvec ts s = forall f.
  MemoryEvent
  { -- | The arguments the 'Event' was initialized with
    ()
initArgs :: !(NewEventArgs (MemoryEvent m appvec ts s) s f),
    -- | The start time of the 'Event'
    forall (m :: * -> *) (appvec :: * -> *) ts (s :: * -> *).
MemoryEvent m appvec ts s -> ts
start :: !ts,
    -- | Event information added during the event's lifecycle
    --
    -- 'Nothing' if this was the result of 'emitImmediateEvent' and thus had no lifecycle
    ()
dynamicValues :: !(Maybe (appvec (TimedEventAction ts f))),
    -- | Direct children of this event
    forall (m :: * -> *) (appvec :: * -> *) ts (s :: * -> *).
MemoryEvent m appvec ts s -> appvec (MemoryEvent m appvec ts s)
childEvents :: !(appvec (MemoryEvent m appvec ts s)),
    -- | Events directly caused by this event
    forall (m :: * -> *) (appvec :: * -> *) ts (s :: * -> *).
MemoryEvent m appvec ts s -> appvec (MemoryEvent m appvec ts s)
causedEvents :: !(appvec (MemoryEvent m appvec ts s))
  }

-- | An action that occurred during an 'Event' at some time.
--
-- [@ts@]: A timestamp, see 'TimestampEffects'
data TimedEventAction ts f = TimedEventAction
  { -- | When the event occurred
    forall ts f. TimedEventAction ts f -> ts
eventTime :: !ts,
    -- | The action that occurred
    forall ts f. TimedEventAction ts f -> EventAction f
act :: !(EventAction f)
  }

-- | An action on an 'Event'
data EventAction f
  = -- | A field was added with 'addField'
    AddField !f
  | -- | The 'Event' was finalized with 'finalize'
    Finalize !(Maybe SomeException)

-- | Monadic effects needed to construct an 'inMemoryBackend'
--
-- [@appvec@]: An append-only vector type, see 'AppendVectorEffects'
-- [@ts@]: A timestamp, see 'TimestampEffects'
data InMemoryEffects m appvec ts = InMemoryEffects
  { -- | Manipulate append-only vectors
    forall (m :: * -> *) (appvec :: * -> *) ts.
InMemoryEffects m appvec ts -> AppendVectorEffects m appvec
appendVectorEffects :: !(AppendVectorEffects m appvec),
    -- | Get timestamps
    forall (m :: * -> *) (appvec :: * -> *) ts.
InMemoryEffects m appvec ts -> TimestampEffects m ts
timestampEffects :: !(TimestampEffects m ts)
  }

-- | Hoist 'InMemoryEffects' along a given natural transformation into a new monad
hoistInMemoryEffects :: (forall x. m x -> n x) -> InMemoryEffects m appvec ts -> InMemoryEffects n appvec ts
hoistInMemoryEffects :: forall (m :: * -> *) (n :: * -> *) (appvec :: * -> *) ts.
(forall x. m x -> n x)
-> InMemoryEffects m appvec ts -> InMemoryEffects n appvec ts
hoistInMemoryEffects forall x. m x -> n x
nt (InMemoryEffects {TimestampEffects m ts
AppendVectorEffects m appvec
timestampEffects :: TimestampEffects m ts
appendVectorEffects :: AppendVectorEffects m appvec
timestampEffects :: forall (m :: * -> *) (appvec :: * -> *) ts.
InMemoryEffects m appvec ts -> TimestampEffects m ts
appendVectorEffects :: forall (m :: * -> *) (appvec :: * -> *) ts.
InMemoryEffects m appvec ts -> AppendVectorEffects m appvec
..}) =
  InMemoryEffects
    { appendVectorEffects :: AppendVectorEffects n appvec
appendVectorEffects = forall (m :: * -> *) (n :: * -> *) (appvec :: * -> *).
(forall x. m x -> n x)
-> AppendVectorEffects m appvec -> AppendVectorEffects n appvec
hoistAppendVectorEffects forall x. m x -> n x
nt AppendVectorEffects m appvec
appendVectorEffects,
      timestampEffects :: TimestampEffects n ts
timestampEffects = forall (m :: * -> *) (n :: * -> *) ts.
(forall x. m x -> n x)
-> TimestampEffects m ts -> TimestampEffects n ts
hoistTimestampEffects forall x. m x -> n x
nt TimestampEffects m ts
timestampEffects
    }

-- | 'InMemoryEffects' based on 'listAppendVectorEffects' and 'ioTimestampEffects'.
listInMemoryEffects :: InMemoryEffects IO (ListAppendVector IO) UTCTime
listInMemoryEffects :: InMemoryEffects IO (ListAppendVector IO) UTCTime
listInMemoryEffects =
  InMemoryEffects
    { appendVectorEffects :: AppendVectorEffects IO (ListAppendVector IO)
appendVectorEffects = forall (m :: * -> *).
PrimMonad m =>
AppendVectorEffects m (ListAppendVector m)
listAppendVectorEffects,
      timestampEffects :: TimestampEffects IO UTCTime
timestampEffects = TimestampEffects IO UTCTime
ioTimestampEffects
    }

-- | 'InMemoryEffects' based on 'listAppendVectorEffects' with meaningless timestamps.
timelessListInMemoryEffects :: (PrimMonad m) => InMemoryEffects m (ListAppendVector m) ()
timelessListInMemoryEffects :: forall (m :: * -> *).
PrimMonad m =>
InMemoryEffects m (ListAppendVector m) ()
timelessListInMemoryEffects =
  InMemoryEffects
    { appendVectorEffects :: AppendVectorEffects m (ListAppendVector m)
appendVectorEffects = forall (m :: * -> *).
PrimMonad m =>
AppendVectorEffects m (ListAppendVector m)
listAppendVectorEffects,
      timestampEffects :: TimestampEffects m ()
timestampEffects = forall (m :: * -> *). Applicative m => TimestampEffects m ()
dummyTimestampEffects
    }

-- | Monadic effects to manipulate append-only vectors.
data AppendVectorEffects m appvec = AppendVectorEffects
  { -- | Create a new vector
    forall (m :: * -> *) (appvec :: * -> *).
AppendVectorEffects m appvec -> forall a. m (appvec a)
newVector :: !(forall a. m (appvec a)),
    -- | Append a value to a vector
    forall (m :: * -> *) (appvec :: * -> *).
AppendVectorEffects m appvec -> forall a. appvec a -> a -> m ()
appendVector :: !(forall a. appvec a -> a -> m ())
  }

-- | Hoist 'AppendVectorEffects' along a given natural transformation into a new monad
hoistAppendVectorEffects :: (forall x. m x -> n x) -> AppendVectorEffects m appvec -> AppendVectorEffects n appvec
hoistAppendVectorEffects :: forall (m :: * -> *) (n :: * -> *) (appvec :: * -> *).
(forall x. m x -> n x)
-> AppendVectorEffects m appvec -> AppendVectorEffects n appvec
hoistAppendVectorEffects forall x. m x -> n x
nt (AppendVectorEffects {forall a. m (appvec a)
forall a. appvec a -> a -> m ()
appendVector :: forall a. appvec a -> a -> m ()
newVector :: forall a. m (appvec a)
appendVector :: forall (m :: * -> *) (appvec :: * -> *).
AppendVectorEffects m appvec -> forall a. appvec a -> a -> m ()
newVector :: forall (m :: * -> *) (appvec :: * -> *).
AppendVectorEffects m appvec -> forall a. m (appvec a)
..}) =
  AppendVectorEffects
    { newVector :: forall a. n (appvec a)
newVector = forall x. m x -> n x
nt forall a b. (a -> b) -> a -> b
$ forall a. m (appvec a)
newVector,
      appendVector :: forall a. appvec a -> a -> n ()
appendVector = \appvec a
v -> forall x. m x -> n x
nt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. appvec a -> a -> m ()
appendVector appvec a
v
    }

-- | An append-only vector in some 'PrimMonad' based on lists.
newtype ListAppendVector m a = ListAppendVector (MutVar (PrimState m) [a])

-- | 'AppendVectorEffects' in some 'PrimMonad' based on lists.
listAppendVectorEffects :: (PrimMonad m) => AppendVectorEffects m (ListAppendVector m)
listAppendVectorEffects :: forall (m :: * -> *).
PrimMonad m =>
AppendVectorEffects m (ListAppendVector m)
listAppendVectorEffects =
  AppendVectorEffects
    { newVector :: forall a. m (ListAppendVector m a)
newVector = forall (m :: * -> *) a.
MutVar (PrimState m) [a] -> ListAppendVector m a
ListAppendVector forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
PrimMonad m =>
a -> m (MutVar (PrimState m) a)
newMutVar [],
      appendVector :: forall a. ListAppendVector m a -> a -> m ()
appendVector = \(ListAppendVector MutVar (PrimState m) [a]
v) a
x -> forall (m :: * -> *) a b.
PrimMonad m =>
MutVar (PrimState m) a -> (a -> (a, b)) -> m b
atomicModifyMutVar MutVar (PrimState m) [a]
v (\[a]
l -> (a
x forall a. a -> [a] -> [a]
: [a]
l, ()))
    }

-- | Monadic effects to manage timestamps.
newtype TimestampEffects m ts = TimestampEffects
  { forall (m :: * -> *) ts. TimestampEffects m ts -> m ts
getTimestamp :: m ts
  }

-- | Hoist 'TimestampEffects' along a given natural transformation into a new monad
hoistTimestampEffects :: (forall x. m x -> n x) -> TimestampEffects m ts -> TimestampEffects n ts
hoistTimestampEffects :: forall (m :: * -> *) (n :: * -> *) ts.
(forall x. m x -> n x)
-> TimestampEffects m ts -> TimestampEffects n ts
hoistTimestampEffects forall x. m x -> n x
nt (TimestampEffects {m ts
getTimestamp :: m ts
getTimestamp :: forall (m :: * -> *) ts. TimestampEffects m ts -> m ts
..}) = forall (m :: * -> *) ts. m ts -> TimestampEffects m ts
TimestampEffects forall a b. (a -> b) -> a -> b
$ forall x. m x -> n x
nt m ts
getTimestamp

-- | 'TimestampEffects' with meaningless timestamps.
dummyTimestampEffects :: (Applicative m) => TimestampEffects m ()
dummyTimestampEffects :: forall (m :: * -> *). Applicative m => TimestampEffects m ()
dummyTimestampEffects = forall (m :: * -> *) ts. m ts -> TimestampEffects m ts
TimestampEffects forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | 'TimestampEffects' using the system clock
ioTimestampEffects :: TimestampEffects IO UTCTime
ioTimestampEffects :: TimestampEffects IO UTCTime
ioTimestampEffects = forall (m :: * -> *) ts. m ts -> TimestampEffects m ts
TimestampEffects IO UTCTime
getCurrentTime