{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
module Observe.Event
( Event,
reference,
addField,
addParent,
addProximate,
withEvent,
withSubEvent,
acquireEvent,
acquireSubEvent,
EventBackend,
subEventBackend,
causedEventBackend,
unitEventBackend,
pairEventBackend,
hoistEventBackend,
narrowEventBackend,
narrowEventBackend',
finalize,
failEvent,
newEvent,
newSubEvent,
)
where
import Control.Exception
import Control.Monad.Catch
import Control.Monad.IO.Unlift
import Data.Acquire
import Observe.Event.Backend
import Observe.Event.BackendModification
data Event m r s f = Event
{
forall (m :: * -> *) r (s :: * -> *) f.
Event m r s f -> EventBackend m r s
backend :: !(EventBackend m r s),
forall (m :: * -> *) r (s :: * -> *) f.
Event m r s f -> EventImpl m r f
impl :: !(EventImpl m r f),
forall (m :: * -> *) r (s :: * -> *) f. Event m r s f -> OnceFlag m
finishFlag :: !(OnceFlag m)
}
reference :: Event m r s f -> r
reference :: forall (m :: * -> *) r (s :: * -> *) f. Event m r s f -> r
reference (Event {OnceFlag m
EventImpl m r f
EventBackend m r s
finishFlag :: OnceFlag m
impl :: EventImpl m r f
backend :: EventBackend m r s
finishFlag :: forall (m :: * -> *) r (s :: * -> *) f. Event m r s f -> OnceFlag m
impl :: forall (m :: * -> *) r (s :: * -> *) f.
Event m r s f -> EventImpl m r f
backend :: forall (m :: * -> *) r (s :: * -> *) f.
Event m r s f -> EventBackend m r s
..}) = forall (m :: * -> *) r f. EventImpl m r f -> r
referenceImpl EventImpl m r f
impl
addField ::
Event m r s f ->
f ->
m ()
addField :: forall (m :: * -> *) r (s :: * -> *) f. Event m r s f -> f -> m ()
addField (Event {OnceFlag m
EventImpl m r f
EventBackend m r s
finishFlag :: OnceFlag m
impl :: EventImpl m r f
backend :: EventBackend m r s
finishFlag :: forall (m :: * -> *) r (s :: * -> *) f. Event m r s f -> OnceFlag m
impl :: forall (m :: * -> *) r (s :: * -> *) f.
Event m r s f -> EventImpl m r f
backend :: forall (m :: * -> *) r (s :: * -> *) f.
Event m r s f -> EventBackend m r s
..}) = forall (m :: * -> *) r f. EventImpl m r f -> f -> m ()
addFieldImpl EventImpl m r f
impl
addParent ::
Event m r s f ->
r ->
m ()
addParent :: forall (m :: * -> *) r (s :: * -> *) f. Event m r s f -> r -> m ()
addParent (Event {OnceFlag m
EventImpl m r f
EventBackend m r s
finishFlag :: OnceFlag m
impl :: EventImpl m r f
backend :: EventBackend m r s
finishFlag :: forall (m :: * -> *) r (s :: * -> *) f. Event m r s f -> OnceFlag m
impl :: forall (m :: * -> *) r (s :: * -> *) f.
Event m r s f -> EventImpl m r f
backend :: forall (m :: * -> *) r (s :: * -> *) f.
Event m r s f -> EventBackend m r s
..}) = forall (m :: * -> *) r f. EventImpl m r f -> r -> m ()
addParentImpl EventImpl m r f
impl
addProximate ::
Event m r s f ->
r ->
m ()
addProximate :: forall (m :: * -> *) r (s :: * -> *) f. Event m r s f -> r -> m ()
addProximate (Event {OnceFlag m
EventImpl m r f
EventBackend m r s
finishFlag :: OnceFlag m
impl :: EventImpl m r f
backend :: EventBackend m r s
finishFlag :: forall (m :: * -> *) r (s :: * -> *) f. Event m r s f -> OnceFlag m
impl :: forall (m :: * -> *) r (s :: * -> *) f.
Event m r s f -> EventImpl m r f
backend :: forall (m :: * -> *) r (s :: * -> *) f.
Event m r s f -> EventBackend m r s
..}) = forall (m :: * -> *) r f. EventImpl m r f -> r -> m ()
addProximateImpl EventImpl m r f
impl
finalize :: (Monad m) => Event m r s f -> m ()
finalize :: forall (m :: * -> *) r (s :: * -> *) f.
Monad m =>
Event m r s f -> m ()
finalize (Event {OnceFlag m
EventImpl m r f
EventBackend m r s
finishFlag :: OnceFlag m
impl :: EventImpl m r f
backend :: EventBackend m r s
finishFlag :: forall (m :: * -> *) r (s :: * -> *) f. Event m r s f -> OnceFlag m
impl :: forall (m :: * -> *) r (s :: * -> *) f.
Event m r s f -> EventImpl m r f
backend :: forall (m :: * -> *) r (s :: * -> *) f.
Event m r s f -> EventBackend m r s
..}) = forall (m :: * -> *). Monad m => OnceFlag m -> m () -> m ()
runOnce OnceFlag m
finishFlag forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r f. EventImpl m r f -> m ()
finalizeImpl EventImpl m r f
impl
failEvent :: (Monad m) => Event m r s f -> Maybe SomeException -> m ()
failEvent :: forall (m :: * -> *) r (s :: * -> *) f.
Monad m =>
Event m r s f -> Maybe SomeException -> m ()
failEvent (Event {OnceFlag m
EventImpl m r f
EventBackend m r s
finishFlag :: OnceFlag m
impl :: EventImpl m r f
backend :: EventBackend m r s
finishFlag :: forall (m :: * -> *) r (s :: * -> *) f. Event m r s f -> OnceFlag m
impl :: forall (m :: * -> *) r (s :: * -> *) f.
Event m r s f -> EventImpl m r f
backend :: forall (m :: * -> *) r (s :: * -> *) f.
Event m r s f -> EventBackend m r s
..}) = forall (m :: * -> *). Monad m => OnceFlag m -> m () -> m ()
runOnce OnceFlag m
finishFlag forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) r f.
EventImpl m r f -> Maybe SomeException -> m ()
failImpl EventImpl m r f
impl
newEvent ::
(Applicative m) =>
EventBackend m r s ->
forall f.
s f ->
m (Event m r s f)
newEvent :: forall (m :: * -> *) r (s :: * -> *).
Applicative m =>
EventBackend m r s -> forall f. s f -> m (Event m r s f)
newEvent backend :: EventBackend m r s
backend@(EventBackend {m (OnceFlag m)
forall f. s f -> m (EventImpl m r f)
newOnceFlag :: forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> m (OnceFlag m)
newEventImpl :: forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> forall f. s f -> m (EventImpl m r f)
newOnceFlag :: m (OnceFlag m)
newEventImpl :: forall f. s f -> m (EventImpl m r f)
..}) s f
sel = do
EventImpl m r f
impl <- forall f. s f -> m (EventImpl m r f)
newEventImpl s f
sel
OnceFlag m
finishFlag <- m (OnceFlag m)
newOnceFlag
pure Event {OnceFlag m
EventImpl m r f
EventBackend m r s
finishFlag :: OnceFlag m
impl :: EventImpl m r f
backend :: EventBackend m r s
finishFlag :: OnceFlag m
impl :: EventImpl m r f
backend :: EventBackend m r s
..}
newSubEvent ::
(Monad m) =>
Event m r s f ->
forall f'.
s f' ->
m (Event m r s f')
newSubEvent :: forall (m :: * -> *) r (s :: * -> *) f.
Monad m =>
Event m r s f -> forall f'. s f' -> m (Event m r s f')
newSubEvent (Event {OnceFlag m
EventImpl m r f
EventBackend m r s
finishFlag :: OnceFlag m
impl :: EventImpl m r f
backend :: EventBackend m r s
finishFlag :: forall (m :: * -> *) r (s :: * -> *) f. Event m r s f -> OnceFlag m
impl :: forall (m :: * -> *) r (s :: * -> *) f.
Event m r s f -> EventImpl m r f
backend :: forall (m :: * -> *) r (s :: * -> *) f.
Event m r s f -> EventBackend m r s
..}) s f'
sel = do
Event m r s f'
child <- forall (m :: * -> *) r (s :: * -> *).
Applicative m =>
EventBackend m r s -> forall f. s f -> m (Event m r s f)
newEvent EventBackend m r s
backend s f'
sel
forall (m :: * -> *) r (s :: * -> *) f. Event m r s f -> r -> m ()
addParent Event m r s f'
child forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r f. EventImpl m r f -> r
referenceImpl EventImpl m r f
impl
pure Event m r s f'
child
withEvent ::
(MonadMask m) =>
EventBackend m r s ->
forall f.
s f ->
(Event m r s f -> m a) ->
m a
withEvent :: forall (m :: * -> *) r (s :: * -> *) a.
MonadMask m =>
EventBackend m r s
-> forall f. s f -> (Event m r s f -> m a) -> m a
withEvent EventBackend m r s
backend s f
sel Event m r s f -> m a
go = do
(a
res, ()) <- forall (m :: * -> *) a b c.
MonadMask m =>
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)
generalBracket (forall (m :: * -> *) r (s :: * -> *).
Applicative m =>
EventBackend m r s -> forall f. s f -> m (Event m r s f)
newEvent EventBackend m r s
backend s f
sel) forall {m :: * -> *} {r} {s :: * -> *} {f} {a}.
Monad m =>
Event m r s f -> ExitCase a -> m ()
release Event m r s f -> m a
go
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
res
where
release :: Event m r s f -> ExitCase a -> m ()
release Event m r s f
ev (ExitCaseSuccess a
_) = forall (m :: * -> *) r (s :: * -> *) f.
Monad m =>
Event m r s f -> m ()
finalize Event m r s f
ev
release Event m r s f
ev (ExitCaseException SomeException
e) = forall (m :: * -> *) r (s :: * -> *) f.
Monad m =>
Event m r s f -> Maybe SomeException -> m ()
failEvent Event m r s f
ev forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just SomeException
e
release Event m r s f
ev ExitCase a
ExitCaseAbort = forall (m :: * -> *) r (s :: * -> *) f.
Monad m =>
Event m r s f -> Maybe SomeException -> m ()
failEvent Event m r s f
ev forall a. Maybe a
Nothing
withSubEvent ::
(MonadMask m) =>
Event m r s f ->
forall f'.
s f' ->
(Event m r s f' -> m a) ->
m a
withSubEvent :: forall (m :: * -> *) r (s :: * -> *) f a.
MonadMask m =>
Event m r s f -> forall f'. s f' -> (Event m r s f' -> m a) -> m a
withSubEvent (Event {OnceFlag m
EventImpl m r f
EventBackend m r s
finishFlag :: OnceFlag m
impl :: EventImpl m r f
backend :: EventBackend m r s
finishFlag :: forall (m :: * -> *) r (s :: * -> *) f. Event m r s f -> OnceFlag m
impl :: forall (m :: * -> *) r (s :: * -> *) f.
Event m r s f -> EventImpl m r f
backend :: forall (m :: * -> *) r (s :: * -> *) f.
Event m r s f -> EventBackend m r s
..}) s f'
sel Event m r s f' -> m a
go = forall (m :: * -> *) r (s :: * -> *) a.
MonadMask m =>
EventBackend m r s
-> forall f. s f -> (Event m r s f -> m a) -> m a
withEvent EventBackend m r s
backend s f'
sel forall a b. (a -> b) -> a -> b
$ \Event m r s f'
child -> do
forall (m :: * -> *) r (s :: * -> *) f. Event m r s f -> r -> m ()
addParent Event m r s f'
child forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r f. EventImpl m r f -> r
referenceImpl EventImpl m r f
impl
Event m r s f' -> m a
go Event m r s f'
child
acquireEvent ::
(MonadUnliftIO m) =>
EventBackend m r s ->
forall f.
s f ->
m (Acquire (Event m r s f))
acquireEvent :: forall (m :: * -> *) r (s :: * -> *).
MonadUnliftIO m =>
EventBackend m r s -> forall f. s f -> m (Acquire (Event m r s f))
acquireEvent EventBackend m r s
backend s f
sel = forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
runInIO ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
forall a. IO a -> (a -> ReleaseType -> IO ()) -> Acquire a
mkAcquireType
(forall a. m a -> IO a
runInIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r (s :: * -> *).
Applicative m =>
EventBackend m r s -> forall f. s f -> m (Event m r s f)
newEvent EventBackend m r s
backend s f
sel)
(forall {m :: * -> *} {b} {r} {s :: * -> *} {f}.
Monad m =>
(m () -> b) -> Event m r s f -> ReleaseType -> b
release forall a. m a -> IO a
runInIO)
where
release :: (m () -> b) -> Event m r s f -> ReleaseType -> b
release m () -> b
runInIO Event m r s f
ev ReleaseType
ReleaseException = m () -> b
runInIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r (s :: * -> *) f.
Monad m =>
Event m r s f -> Maybe SomeException -> m ()
failEvent Event m r s f
ev forall a. Maybe a
Nothing
release m () -> b
runInIO Event m r s f
ev ReleaseType
_ = m () -> b
runInIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r (s :: * -> *) f.
Monad m =>
Event m r s f -> m ()
finalize Event m r s f
ev
acquireSubEvent ::
(MonadUnliftIO m) =>
Event m r s f ->
forall f'.
s f' ->
m (Acquire (Event m r s f'))
acquireSubEvent :: forall (m :: * -> *) r (s :: * -> *) f.
MonadUnliftIO m =>
Event m r s f -> forall f'. s f' -> m (Acquire (Event m r s f'))
acquireSubEvent (Event {OnceFlag m
EventImpl m r f
EventBackend m r s
finishFlag :: OnceFlag m
impl :: EventImpl m r f
backend :: EventBackend m r s
finishFlag :: forall (m :: * -> *) r (s :: * -> *) f. Event m r s f -> OnceFlag m
impl :: forall (m :: * -> *) r (s :: * -> *) f.
Event m r s f -> EventImpl m r f
backend :: forall (m :: * -> *) r (s :: * -> *) f.
Event m r s f -> EventBackend m r s
..}) s f'
sel = do
Acquire (Event m r s f')
childAcq <- forall (m :: * -> *) r (s :: * -> *).
MonadUnliftIO m =>
EventBackend m r s -> forall f. s f -> m (Acquire (Event m r s f))
acquireEvent EventBackend m r s
backend s f'
sel
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
runInIO -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ do
Event m r s f'
child <- Acquire (Event m r s f')
childAcq
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. m a -> IO a
runInIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) r (s :: * -> *) f. Event m r s f -> r -> m ()
addParent Event m r s f'
child forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r f. EventImpl m r f -> r
referenceImpl EventImpl m r f
impl
pure Event m r s f'
child
subEventBackend ::
(Monad m) =>
Event m r s f ->
EventBackend m r s
subEventBackend :: forall (m :: * -> *) r (s :: * -> *) f.
Monad m =>
Event m r s f -> EventBackend m r s
subEventBackend Event {OnceFlag m
EventImpl m r f
EventBackend m r s
finishFlag :: OnceFlag m
impl :: EventImpl m r f
backend :: EventBackend m r s
finishFlag :: forall (m :: * -> *) r (s :: * -> *) f. Event m r s f -> OnceFlag m
impl :: forall (m :: * -> *) r (s :: * -> *) f.
Event m r s f -> EventImpl m r f
backend :: forall (m :: * -> *) r (s :: * -> *) f.
Event m r s f -> EventBackend m r s
..} = forall (m :: * -> *) r r' (s :: * -> *).
Monad m =>
EventBackendModifiers r r'
-> EventBackend m r s -> EventBackend m r' s
modifyEventBackend (forall r. r -> EventBackendModifiers r r
setAncestor forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r f. EventImpl m r f -> r
referenceImpl EventImpl m r f
impl) EventBackend m r s
backend
causedEventBackend ::
(Monad m) =>
Event m r s f ->
EventBackend m r s
causedEventBackend :: forall (m :: * -> *) r (s :: * -> *) f.
Monad m =>
Event m r s f -> EventBackend m r s
causedEventBackend Event {OnceFlag m
EventImpl m r f
EventBackend m r s
finishFlag :: OnceFlag m
impl :: EventImpl m r f
backend :: EventBackend m r s
finishFlag :: forall (m :: * -> *) r (s :: * -> *) f. Event m r s f -> OnceFlag m
impl :: forall (m :: * -> *) r (s :: * -> *) f.
Event m r s f -> EventImpl m r f
backend :: forall (m :: * -> *) r (s :: * -> *) f.
Event m r s f -> EventBackend m r s
..} = forall (m :: * -> *) r r' (s :: * -> *).
Monad m =>
EventBackendModifiers r r'
-> EventBackend m r s -> EventBackend m r' s
modifyEventBackend (forall r. r -> EventBackendModifiers r r
setInitialCause forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r f. EventImpl m r f -> r
referenceImpl EventImpl m r f
impl) EventBackend m r s
backend