{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneKindSignatures #-}
module Observe.Event.Render.InMemory
( listInMemoryBackend,
timelessListInMemoryBackend,
inMemoryBackend,
MemoryEvent (..),
TimedEventAction (..),
EventAction (..),
InMemoryEffects (..),
hoistInMemoryEffects,
listInMemoryEffects,
timelessListInMemoryEffects,
AppendVectorEffects (..),
hoistAppendVectorEffects,
ListAppendVector (..),
listAppendVectorEffects,
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
listInMemoryBackend ::
(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
timelessListInMemoryBackend ::
(PrimMonad m) =>
(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
inMemoryBackend ::
(Monad m) =>
InMemoryEffects m appvec ts ->
(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
type MemoryEvent :: (Type -> Type) -> (Type -> Type) -> Type -> (Type -> Type) -> Type
data MemoryEvent m appvec ts s = forall f.
MemoryEvent
{
()
initArgs :: !(NewEventArgs (MemoryEvent m appvec ts s) s f),
forall (m :: * -> *) (appvec :: * -> *) ts (s :: * -> *).
MemoryEvent m appvec ts s -> ts
start :: !ts,
()
dynamicValues :: !(Maybe (appvec (TimedEventAction ts f))),
forall (m :: * -> *) (appvec :: * -> *) ts (s :: * -> *).
MemoryEvent m appvec ts s -> appvec (MemoryEvent m appvec ts s)
childEvents :: !(appvec (MemoryEvent m appvec ts s)),
forall (m :: * -> *) (appvec :: * -> *) ts (s :: * -> *).
MemoryEvent m appvec ts s -> appvec (MemoryEvent m appvec ts s)
causedEvents :: !(appvec (MemoryEvent m appvec ts s))
}
data TimedEventAction ts f = TimedEventAction
{
forall ts f. TimedEventAction ts f -> ts
eventTime :: !ts,
forall ts f. TimedEventAction ts f -> EventAction f
act :: !(EventAction f)
}
data EventAction f
=
AddField !f
|
Finalize !(Maybe SomeException)
data InMemoryEffects m appvec ts = InMemoryEffects
{
forall (m :: * -> *) (appvec :: * -> *) ts.
InMemoryEffects m appvec ts -> AppendVectorEffects m appvec
appendVectorEffects :: !(AppendVectorEffects m appvec),
forall (m :: * -> *) (appvec :: * -> *) ts.
InMemoryEffects m appvec ts -> TimestampEffects m ts
timestampEffects :: !(TimestampEffects m ts)
}
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
}
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
}
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
}
data AppendVectorEffects m appvec = AppendVectorEffects
{
forall (m :: * -> *) (appvec :: * -> *).
AppendVectorEffects m appvec -> forall a. m (appvec a)
newVector :: !(forall a. m (appvec a)),
forall (m :: * -> *) (appvec :: * -> *).
AppendVectorEffects m appvec -> forall a. appvec a -> a -> m ()
appendVector :: !(forall a. appvec a -> a -> m ())
}
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
}
newtype ListAppendVector m a = ListAppendVector (MutVar (PrimState m) [a])
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, ()))
}
newtype TimestampEffects m ts = TimestampEffects
{ forall (m :: * -> *) ts. TimestampEffects m ts -> m ts
getTimestamp :: m ts
}
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
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 ()
ioTimestampEffects :: TimestampEffects IO UTCTime
ioTimestampEffects :: TimestampEffects IO UTCTime
ioTimestampEffects = forall (m :: * -> *) ts. m ts -> TimestampEffects m ts
TimestampEffects IO UTCTime
getCurrentTime