{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
module Observe.Event
( Event,
reference,
addField,
addParent,
addProximate,
withEvent,
withSubEvent,
acquireEvent,
acquireSubEvent,
EventBackend,
subEventBackend,
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 Data.Functor
import Observe.Event.Implementation
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 ev :: Event m r s f
ev@(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
..}) =
EventBackend
{ newEventImpl :: forall f. s f -> m (EventImpl m r f)
newEventImpl = \s f
sel -> do
EventImpl {r
m ()
r -> m ()
f -> m ()
Maybe SomeException -> m ()
failImpl :: Maybe SomeException -> m ()
finalizeImpl :: m ()
addProximateImpl :: r -> m ()
addParentImpl :: r -> m ()
addFieldImpl :: f -> m ()
referenceImpl :: r
failImpl :: forall (m :: * -> *) r f.
EventImpl m r f -> Maybe SomeException -> m ()
finalizeImpl :: forall (m :: * -> *) r f. EventImpl m r f -> m ()
addProximateImpl :: forall (m :: * -> *) r f. EventImpl m r f -> r -> m ()
addParentImpl :: forall (m :: * -> *) r f. EventImpl m r f -> r -> m ()
addFieldImpl :: forall (m :: * -> *) r f. EventImpl m r f -> f -> m ()
referenceImpl :: forall (m :: * -> *) r f. EventImpl m r f -> r
..} <- forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> forall f. s f -> m (EventImpl m r f)
newEventImpl EventBackend m r s
backend s f
sel
OnceFlag m
parentAdded <- forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> m (OnceFlag m)
newOnceFlag EventBackend m r s
backend
pure $
EventImpl
{ addParentImpl :: r -> m ()
addParentImpl = \r
r -> do
FlagState
_ <- forall (m :: * -> *). OnceFlag m -> m FlagState
checkAndSet OnceFlag m
parentAdded
r -> m ()
addParentImpl r
r,
finalizeImpl :: m ()
finalizeImpl = do
forall (m :: * -> *). Monad m => OnceFlag m -> m () -> m ()
runOnce OnceFlag m
parentAdded (r -> m ()
addParentImpl forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r (s :: * -> *) f. Event m r s f -> r
reference Event m r s f
ev)
m ()
finalizeImpl,
failImpl :: Maybe SomeException -> m ()
failImpl = \Maybe SomeException
e -> do
forall (m :: * -> *). Monad m => OnceFlag m -> m () -> m ()
runOnce OnceFlag m
parentAdded (r -> m ()
addParentImpl forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r (s :: * -> *) f. Event m r s f -> r
reference Event m r s f
ev)
Maybe SomeException -> m ()
failImpl Maybe SomeException
e,
r
r -> m ()
f -> m ()
addProximateImpl :: r -> m ()
addFieldImpl :: f -> m ()
referenceImpl :: r
addProximateImpl :: r -> m ()
addFieldImpl :: f -> m ()
referenceImpl :: r
..
},
newOnceFlag :: m (OnceFlag m)
newOnceFlag = forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> m (OnceFlag m)
newOnceFlag EventBackend m r s
backend
}
unitEventBackend :: Applicative m => EventBackend m () s
unitEventBackend :: forall (m :: * -> *) (s :: * -> *).
Applicative m =>
EventBackend m () s
unitEventBackend =
EventBackend
{ newEventImpl :: forall f. s f -> m (EventImpl m () f)
newEventImpl = \s f
_ ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
EventImpl
{ referenceImpl :: ()
referenceImpl = (),
addFieldImpl :: f -> m ()
addFieldImpl = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure (),
addParentImpl :: () -> m ()
addParentImpl = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure (),
addProximateImpl :: () -> m ()
addProximateImpl = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure (),
finalizeImpl :: m ()
finalizeImpl = forall (f :: * -> *) a. Applicative f => a -> f a
pure (),
failImpl :: Maybe SomeException -> m ()
failImpl = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
},
newOnceFlag :: m (OnceFlag m)
newOnceFlag = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (m :: * -> *). Applicative m => OnceFlag m
alwaysNewOnceFlag
}
pairEventBackend :: Applicative m => EventBackend m a s -> EventBackend m b s -> EventBackend m (a, b) s
pairEventBackend :: forall (m :: * -> *) a (s :: * -> *) b.
Applicative m =>
EventBackend m a s -> EventBackend m b s -> EventBackend m (a, b) s
pairEventBackend EventBackend m a s
x EventBackend m b s
y =
EventBackend
{ newEventImpl :: forall f. s f -> m (EventImpl m (a, b) f)
newEventImpl = \s f
sel -> do
EventImpl m a f
xImpl <- forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> forall f. s f -> m (EventImpl m r f)
newEventImpl EventBackend m a s
x s f
sel
EventImpl m b f
yImpl <- forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> forall f. s f -> m (EventImpl m r f)
newEventImpl EventBackend m b s
y s f
sel
pure $
EventImpl
{ referenceImpl :: (a, b)
referenceImpl = (forall (m :: * -> *) r f. EventImpl m r f -> r
referenceImpl EventImpl m a f
xImpl, forall (m :: * -> *) r f. EventImpl m r f -> r
referenceImpl EventImpl m b f
yImpl),
addFieldImpl :: f -> m ()
addFieldImpl = \f
f -> forall (m :: * -> *) r f. EventImpl m r f -> f -> m ()
addFieldImpl EventImpl m a f
xImpl f
f forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) r f. EventImpl m r f -> f -> m ()
addFieldImpl EventImpl m b f
yImpl f
f,
addParentImpl :: (a, b) -> m ()
addParentImpl = \(a
px, b
py) -> forall (m :: * -> *) r f. EventImpl m r f -> r -> m ()
addParentImpl EventImpl m a f
xImpl a
px forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) r f. EventImpl m r f -> r -> m ()
addParentImpl EventImpl m b f
yImpl b
py,
addProximateImpl :: (a, b) -> m ()
addProximateImpl = \(a
px, b
py) -> forall (m :: * -> *) r f. EventImpl m r f -> r -> m ()
addProximateImpl EventImpl m a f
xImpl a
px forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) r f. EventImpl m r f -> r -> m ()
addProximateImpl EventImpl m b f
yImpl b
py,
finalizeImpl :: m ()
finalizeImpl = forall (m :: * -> *) r f. EventImpl m r f -> m ()
finalizeImpl EventImpl m a f
xImpl forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) r f. EventImpl m r f -> m ()
finalizeImpl EventImpl m b f
yImpl,
failImpl :: Maybe SomeException -> m ()
failImpl = \Maybe SomeException
e -> forall (m :: * -> *) r f.
EventImpl m r f -> Maybe SomeException -> m ()
failImpl EventImpl m a f
xImpl Maybe SomeException
e forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) r f.
EventImpl m r f -> Maybe SomeException -> m ()
failImpl EventImpl m b f
yImpl Maybe SomeException
e
},
newOnceFlag :: m (OnceFlag m)
newOnceFlag = do
OnceFlag m
xOnce <- forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> m (OnceFlag m)
newOnceFlag EventBackend m a s
x
OnceFlag m
yOnce <- forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> m (OnceFlag m)
newOnceFlag EventBackend m b s
y
pure $
forall (m :: * -> *). m FlagState -> OnceFlag m
OnceFlag forall a b. (a -> b) -> a -> b
$ do
FlagState
xSet <- forall (m :: * -> *). OnceFlag m -> m FlagState
checkAndSet OnceFlag m
xOnce
FlagState
ySet <- forall (m :: * -> *). OnceFlag m -> m FlagState
checkAndSet OnceFlag m
yOnce
pure $ case (FlagState
xSet, FlagState
ySet) of
(FlagState
NewlySet, FlagState
NewlySet) -> FlagState
NewlySet
(FlagState, FlagState)
_ -> FlagState
AlreadySet
}
hoistEventBackend ::
(Functor m, Functor n) =>
(forall x. m x -> n x) ->
EventBackend m r s ->
EventBackend n r s
hoistEventBackend :: 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 =
EventBackend
{ newEventImpl :: forall f. s f -> n (EventImpl n r f)
newEventImpl = forall x. m x -> n x
nt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {r} {f}. EventImpl m r f -> EventImpl n r f
hoistEventImpl forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> forall f. s f -> m (EventImpl m r f)
newEventImpl EventBackend m r s
backend,
newOnceFlag :: n (OnceFlag n)
newOnceFlag = forall (f :: * -> *) (g :: * -> *).
(forall x. f x -> g x) -> OnceFlag f -> OnceFlag g
hoistOnceFlag forall x. m x -> n x
nt forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall x. m x -> n x
nt forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> m (OnceFlag m)
newOnceFlag EventBackend m r s
backend)
}
where
hoistEventImpl :: EventImpl m r f -> EventImpl n r f
hoistEventImpl (EventImpl {r
m ()
r -> m ()
f -> m ()
Maybe SomeException -> m ()
failImpl :: Maybe SomeException -> m ()
finalizeImpl :: m ()
addProximateImpl :: r -> m ()
addParentImpl :: r -> m ()
addFieldImpl :: f -> m ()
referenceImpl :: r
failImpl :: forall (m :: * -> *) r f.
EventImpl m r f -> Maybe SomeException -> m ()
finalizeImpl :: forall (m :: * -> *) r f. EventImpl m r f -> m ()
addProximateImpl :: forall (m :: * -> *) r f. EventImpl m r f -> r -> m ()
addParentImpl :: forall (m :: * -> *) r f. EventImpl m r f -> r -> m ()
addFieldImpl :: forall (m :: * -> *) r f. EventImpl m r f -> f -> m ()
referenceImpl :: forall (m :: * -> *) r f. EventImpl m r f -> r
..}) =
EventImpl
{ r
referenceImpl :: r
referenceImpl :: r
referenceImpl,
addFieldImpl :: f -> n ()
addFieldImpl = forall x. m x -> n x
nt forall b c a. (b -> c) -> (a -> b) -> a -> c
. f -> m ()
addFieldImpl,
addParentImpl :: r -> n ()
addParentImpl = forall x. m x -> n x
nt forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> m ()
addParentImpl,
addProximateImpl :: r -> n ()
addProximateImpl = forall x. m x -> n x
nt forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> m ()
addProximateImpl,
finalizeImpl :: n ()
finalizeImpl = forall x. m x -> n x
nt forall a b. (a -> b) -> a -> b
$ m ()
finalizeImpl,
failImpl :: Maybe SomeException -> n ()
failImpl = forall x. m x -> n x
nt forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe SomeException -> m ()
failImpl
}
narrowEventBackend ::
(Functor m) =>
(forall f. s f -> t f) ->
EventBackend m r t ->
EventBackend m r s
narrowEventBackend :: 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 (m :: * -> *) (s :: * -> *) (t :: * -> *) r.
Functor m =>
(forall f. s f -> forall a. (forall g. t g -> (f -> g) -> a) -> a)
-> EventBackend m r t -> EventBackend m r s
narrowEventBackend'
(\s f
sel forall g. t g -> (f -> g) -> a
withInjField -> forall g. t g -> (f -> g) -> a
withInjField (forall f. s f -> t f
inj s f
sel) forall a. a -> a
id)
narrowEventBackend' ::
(Functor m) =>
(forall f. s f -> forall a. (forall g. t g -> (f -> g) -> a) -> a) ->
EventBackend m r t ->
EventBackend m r s
narrowEventBackend' :: forall (m :: * -> *) (s :: * -> *) (t :: * -> *) r.
Functor m =>
(forall f. s f -> forall a. (forall g. t g -> (f -> g) -> a) -> a)
-> EventBackend m r t -> EventBackend m r s
narrowEventBackend' forall f. s f -> forall a. (forall g. t g -> (f -> g) -> a) -> a
inj EventBackend m r t
backend =
EventBackend
{ newEventImpl :: forall f. s f -> m (EventImpl m r f)
newEventImpl = \s f
sel -> forall f. s f -> forall a. (forall g. t g -> (f -> g) -> a) -> a
inj s f
sel \t g
sel' f -> g
injField ->
forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> forall f. s f -> m (EventImpl m r f)
newEventImpl EventBackend m r t
backend t g
sel' forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
EventImpl {r
m ()
r -> m ()
g -> m ()
Maybe SomeException -> m ()
failImpl :: Maybe SomeException -> m ()
finalizeImpl :: m ()
addProximateImpl :: r -> m ()
addParentImpl :: r -> m ()
addFieldImpl :: g -> m ()
referenceImpl :: r
failImpl :: forall (m :: * -> *) r f.
EventImpl m r f -> Maybe SomeException -> m ()
finalizeImpl :: forall (m :: * -> *) r f. EventImpl m r f -> m ()
addProximateImpl :: forall (m :: * -> *) r f. EventImpl m r f -> r -> m ()
addParentImpl :: forall (m :: * -> *) r f. EventImpl m r f -> r -> m ()
addFieldImpl :: forall (m :: * -> *) r f. EventImpl m r f -> f -> m ()
referenceImpl :: forall (m :: * -> *) r f. EventImpl m r f -> r
..} ->
EventImpl
{ addFieldImpl :: f -> m ()
addFieldImpl = g -> m ()
addFieldImpl forall b c a. (b -> c) -> (a -> b) -> a -> c
. f -> g
injField,
r
m ()
r -> m ()
Maybe SomeException -> m ()
failImpl :: Maybe SomeException -> m ()
finalizeImpl :: m ()
addProximateImpl :: r -> m ()
addParentImpl :: r -> m ()
referenceImpl :: r
failImpl :: Maybe SomeException -> m ()
finalizeImpl :: m ()
addProximateImpl :: r -> m ()
addParentImpl :: r -> m ()
referenceImpl :: r
..
},
newOnceFlag :: m (OnceFlag m)
newOnceFlag = forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> m (OnceFlag m)
newOnceFlag EventBackend m r t
backend
}