{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
module Observe.Event.BackendModification
( EventBackendModifier (..),
EventBackendModifiers,
modifyEventBackend,
unmodified,
silence,
setAncestor,
setInitialCause,
)
where
import Control.Category
import Observe.Event.Backend
import Prelude hiding (id, (.))
data EventBackendModifier r r' where
Silence :: forall r. EventBackendModifier r ()
SetAncestor ::
forall r.
r ->
EventBackendModifier r r
SetInitialCause ::
forall r.
r ->
EventBackendModifier r r
data EventBackendModifiers r r' where
Nil :: forall r. EventBackendModifiers r r
Cons :: forall r r' r''. EventBackendModifier r' r'' -> EventBackendModifiers r r' -> EventBackendModifiers r r''
instance Category EventBackendModifiers where
id :: forall a. EventBackendModifiers a a
id = forall a. EventBackendModifiers a a
Nil
EventBackendModifiers b c
Nil . :: forall b c a.
EventBackendModifiers b c
-> EventBackendModifiers a b -> EventBackendModifiers a c
. EventBackendModifiers a b
f = EventBackendModifiers a b
f
(Cons EventBackendModifier r' c
hd EventBackendModifiers b r'
tl) . EventBackendModifiers a b
f = forall r r' r''.
EventBackendModifier r' r''
-> EventBackendModifiers r r' -> EventBackendModifiers r r''
Cons EventBackendModifier r' c
hd (EventBackendModifiers b r'
tl forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. EventBackendModifiers a b
f)
modifyEventBackend :: Monad m => EventBackendModifiers r r' -> EventBackend m r s -> EventBackend m r' s
modifyEventBackend :: forall (m :: * -> *) r r' (s :: * -> *).
Monad m =>
EventBackendModifiers r r'
-> EventBackend m r s -> EventBackend m r' s
modifyEventBackend EventBackendModifiers r r'
Nil EventBackend m r s
backend = EventBackend m r s
backend
modifyEventBackend (Cons EventBackendModifier r' r'
Silence EventBackendModifiers r r'
_) EventBackend m r s
_ = forall (m :: * -> *) (s :: * -> *).
Applicative m =>
EventBackend m () s
unitEventBackend
modifyEventBackend (Cons (SetAncestor r'
parent) EventBackendModifiers r r'
rest) EventBackend m r s
backend' =
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 :: 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
failImpl :: Maybe SomeException -> m ()
finalizeImpl :: m ()
addProximateImpl :: r' -> m ()
addParentImpl :: r' -> m ()
addFieldImpl :: f -> m ()
referenceImpl :: 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
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
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 r'
parent)
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 r'
parent)
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
}
where
backend :: EventBackend m r' s
backend = forall (m :: * -> *) r r' (s :: * -> *).
Monad m =>
EventBackendModifiers r r'
-> EventBackend m r s -> EventBackend m r' s
modifyEventBackend EventBackendModifiers r r'
rest EventBackend m r s
backend'
modifyEventBackend (Cons (SetInitialCause r'
proximate) EventBackendModifiers r r'
rest) EventBackend m r s
backend' =
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
proximateAdded <- forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> m (OnceFlag m)
newOnceFlag EventBackend m r' s
backend
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
EventImpl
{ addProximateImpl :: r' -> m ()
addProximateImpl = \r'
r -> do
FlagState
_ <- forall (m :: * -> *). OnceFlag m -> m FlagState
checkAndSet OnceFlag m
proximateAdded
r' -> m ()
addParentImpl r'
r,
finalizeImpl :: m ()
finalizeImpl = do
forall (m :: * -> *). Monad m => OnceFlag m -> m () -> m ()
runOnce OnceFlag m
proximateAdded (r' -> m ()
addProximateImpl r'
proximate)
m ()
finalizeImpl,
failImpl :: Maybe SomeException -> m ()
failImpl = \Maybe SomeException
e -> do
forall (m :: * -> *). Monad m => OnceFlag m -> m () -> m ()
runOnce OnceFlag m
proximateAdded (r' -> m ()
addProximateImpl r'
proximate)
Maybe SomeException -> m ()
failImpl Maybe SomeException
e,
r'
r' -> m ()
f -> m ()
addParentImpl :: r' -> m ()
addFieldImpl :: f -> m ()
referenceImpl :: r'
addParentImpl :: 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
}
where
backend :: EventBackend m r' s
backend = forall (m :: * -> *) r r' (s :: * -> *).
Monad m =>
EventBackendModifiers r r'
-> EventBackend m r s -> EventBackend m r' s
modifyEventBackend EventBackendModifiers r r'
rest EventBackend m r s
backend'
singleton :: EventBackendModifier r r' -> EventBackendModifiers r r'
singleton :: forall r r'.
EventBackendModifier r r' -> EventBackendModifiers r r'
singleton = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r r' r''.
EventBackendModifier r' r''
-> EventBackendModifiers r r' -> EventBackendModifiers r r''
Cons forall a. EventBackendModifiers a a
Nil
unmodified :: EventBackendModifiers r r
unmodified :: forall a. EventBackendModifiers a a
unmodified = forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id
silence :: EventBackendModifiers r ()
silence :: forall r. EventBackendModifiers r ()
silence = forall r r'.
EventBackendModifier r r' -> EventBackendModifiers r r'
singleton forall r. EventBackendModifier r ()
Silence
setAncestor :: r -> EventBackendModifiers r r
setAncestor :: forall r. r -> EventBackendModifiers r r
setAncestor = forall r r'.
EventBackendModifier r r' -> EventBackendModifiers r r'
singleton forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall r. r -> EventBackendModifier r r
SetAncestor
setInitialCause :: r -> EventBackendModifiers r r
setInitialCause :: forall r. r -> EventBackendModifiers r r
setInitialCause = forall r r'.
EventBackendModifier r r' -> EventBackendModifiers r r'
singleton forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall r. r -> EventBackendModifier r r
SetInitialCause