{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE CPP #-}
module Observe.Event
( Event,
hoistEvent,
reference,
addField,
addParent,
addProximate,
withEvent,
withSubEvent,
withEventMask,
withSubEventMask,
acquireEvent,
acquireSubEvent,
EventBackend,
subEventBackend,
causedEventBackend,
unitEventBackend,
pairEventBackend,
hoistEventBackend,
narrowEventBackend,
narrowEventBackend',
finalize,
failEvent,
newEvent,
newSubEvent,
)
where
import Control.Exception.Safe
import Control.Monad.Cleanup
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)
}
hoistEvent :: (Functor m, Functor n) => (forall x. m x -> n x) -> Event m r s f -> Event n r s f
hoistEvent :: forall (m :: * -> *) (n :: * -> *) r (s :: * -> *) f.
(Functor m, Functor n) =>
(forall x. m x -> n x) -> Event m r s f -> Event n r s f
hoistEvent forall x. m x -> n x
nt 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
..} =
Event
{ backend :: EventBackend n r s
backend = forall (m :: * -> *) (n :: * -> *) r (s :: * -> *).
(Functor m, Functor n) =>
(forall x. m x -> n x) -> EventBackend m r s -> EventBackend n r s
hoistEventBackend forall x. m x -> n x
nt EventBackend m r s
backend,
impl :: EventImpl n r f
impl = forall (m :: * -> *) (n :: * -> *) r f.
(forall x. m x -> n x) -> EventImpl m r f -> EventImpl n r f
hoistEventImpl forall x. m x -> n x
nt EventImpl m r f
impl,
finishFlag :: OnceFlag n
finishFlag = forall (f :: * -> *) (g :: * -> *).
(forall x. f x -> g x) -> OnceFlag f -> OnceFlag g
hoistOnceFlag forall x. m x -> n x
nt OnceFlag m
finishFlag
}
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 -> SomeException -> m ()
failEvent :: forall (m :: * -> *) r (s :: * -> *) f.
Monad m =>
Event m r s f -> 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 -> 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 ::
(MonadCleanup m) =>
EventBackend m r s ->
forall f.
s f ->
(Event m r s f -> m a) ->
m a
withEvent :: forall (m :: * -> *) r (s :: * -> *) a.
MonadCleanup 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 = forall (m :: * -> *) a b c.
MonadCleanup m =>
m a -> (Maybe SomeException -> a -> m b) -> (a -> m c) -> m c
withCleanup (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}.
Monad m =>
Maybe SomeException -> Event m r s f -> m ()
cleanup Event m r s f -> m a
go
where
cleanup :: Maybe SomeException -> Event m r s f -> m ()
cleanup Maybe SomeException
Nothing = forall (m :: * -> *) r (s :: * -> *) f.
Monad m =>
Event m r s f -> m ()
finalize
cleanup (Just SomeException
e) = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) r (s :: * -> *) f.
Monad m =>
Event m r s f -> SomeException -> m ()
failEvent SomeException
e
withSubEvent ::
(MonadCleanup 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.
MonadCleanup 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.
MonadCleanup 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
withEventMask ::
forall m r s.
(MonadMask m) =>
EventBackend m r s ->
forall f.
s f ->
forall a.
(Event m r s f -> m a) ->
m a
withEventMask :: forall (m :: * -> *) r (s :: * -> *).
MonadMask m =>
EventBackend m r s
-> forall f. s f -> forall a. (Event m r s f -> m a) -> m a
withEventMask EventBackend m r s
backend s f
sel Event m r s f -> m a
go = forall (m :: * -> *) a b c.
MonadMask m =>
m a -> (Maybe SomeException -> a -> m b) -> (a -> m c) -> m c
bracketWithError (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}.
Monad m =>
Maybe SomeException -> Event m r s f -> m ()
release Event m r s f -> m a
go
where
release :: Maybe SomeException -> Event m r s f -> m ()
release Maybe SomeException
Nothing = forall (m :: * -> *) r (s :: * -> *) f.
Monad m =>
Event m r s f -> m ()
finalize
release (Just SomeException
e) = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) r (s :: * -> *) f.
Monad m =>
Event m r s f -> SomeException -> m ()
failEvent SomeException
e
withSubEventMask ::
(MonadMask m) =>
Event m r s f ->
forall f'.
s f' ->
(Event m r s f' -> m a) ->
m a
withSubEventMask :: 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
withSubEventMask (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 :: * -> *).
MonadMask m =>
EventBackend m r s
-> forall f. s f -> forall a. (Event m r s f -> m a) -> m a
withEventMask 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
#if MIN_VERSION_resourcet(1,3,0)
release :: (m () -> b) -> Event m r s f -> ReleaseType -> b
release m () -> b
runInIO Event m r s f
ev (ReleaseExceptionWith SomeException
e) = m () -> b
runInIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r (s :: * -> *) f.
Monad m =>
Event m r s f -> SomeException -> m ()
failEvent Event m r s f
ev SomeException
e
#else
release runInIO ev ReleaseException = runInIO . failEvent ev $ toException AbortException
#endif
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) =>
(forall f'. s f' -> t f') ->
Event m r t f ->
EventBackend m r s
subEventBackend :: forall (m :: * -> *) (s :: * -> *) (t :: * -> *) r f.
Monad m =>
(forall f'. s f' -> t f') -> Event m r t f -> EventBackend m r s
subEventBackend forall f'. s f' -> t f'
inj Event {OnceFlag m
EventImpl m r f
EventBackend m r t
finishFlag :: OnceFlag m
impl :: EventImpl m r f
backend :: EventBackend m r t
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 :: * -> *) (s :: * -> *) (t :: * -> *) r.
Functor m =>
(forall f. s f -> t f) -> EventBackend m r t -> EventBackend m r s
narrowEventBackend forall f'. s f' -> t f'
inj forall a b. (a -> b) -> a -> b
$
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 t
backend
causedEventBackend ::
(Monad m) =>
(forall f'. s f' -> t f') ->
Event m r t f ->
EventBackend m r s
causedEventBackend :: forall (m :: * -> *) (s :: * -> *) (t :: * -> *) r f.
Monad m =>
(forall f'. s f' -> t f') -> Event m r t f -> EventBackend m r s
causedEventBackend forall f'. s f' -> t f'
inj Event {OnceFlag m
EventImpl m r f
EventBackend m r t
finishFlag :: OnceFlag m
impl :: EventImpl m r f
backend :: EventBackend m r t
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 :: * -> *) (s :: * -> *) (t :: * -> *) r.
Functor m =>
(forall f. s f -> t f) -> EventBackend m r t -> EventBackend m r s
narrowEventBackend forall f'. s f' -> t f'
inj forall a b. (a -> b) -> a -> b
$
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 t
backend