{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
module Observe.Event.Backend
(
EventBackend (..),
Event (..),
Reference (..),
ReferenceType (..),
unitEventBackend,
pairEventBackend,
noopEventBackend,
hoistEventBackend,
hoistEvent,
InjectSelector,
injectSelector,
idInjectSelector,
narrowEventBackend,
setDefaultReferenceEventBackend,
setAncestorEventBackend,
setInitialCauseEventBackend,
setReferenceEventBackend,
setParentEventBackend,
setProximateEventBackend,
)
where
import Control.Exception
import Control.Monad
import Control.Monad.Primitive
import Data.Functor
import Data.Primitive.MVar
data Event m r f = Event
{
forall (m :: * -> *) r f. Event m r f -> r
reference :: !r,
forall (m :: * -> *) r f. Event m r f -> f -> m ()
addField :: !(f -> m ()),
forall (m :: * -> *) r f. Event m r f -> Reference r -> m ()
addReference :: !(Reference r -> m ()),
forall (m :: * -> *) r f.
Event m r f -> Maybe SomeException -> m ()
finalize :: !(Maybe SomeException -> m ())
}
hoistEvent :: (forall x. m x -> n x) -> Event m r f -> Event n r f
hoistEvent :: forall (m :: * -> *) (n :: * -> *) r f.
(forall x. m x -> n x) -> Event m r f -> Event n r f
hoistEvent forall x. m x -> n x
nt Event m r f
ev =
Event m r f
ev
{ addField :: f -> n ()
addField = forall x. m x -> n x
nt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) r f. Event m r f -> f -> m ()
addField Event m r f
ev,
addReference :: Reference r -> n ()
addReference = forall x. m x -> n x
nt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) r f. Event m r f -> Reference r -> m ()
addReference Event m r f
ev,
finalize :: Maybe SomeException -> n ()
finalize = forall x. m x -> n x
nt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) r f.
Event m r f -> Maybe SomeException -> m ()
finalize Event m r f
ev
}
data ReferenceType
=
Parent
|
Proximate
deriving stock (ReferenceType -> ReferenceType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ReferenceType -> ReferenceType -> Bool
$c/= :: ReferenceType -> ReferenceType -> Bool
== :: ReferenceType -> ReferenceType -> Bool
$c== :: ReferenceType -> ReferenceType -> Bool
Eq)
data Reference r = Reference !ReferenceType !r
newtype EventBackend m r s = EventBackend
{
forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> forall f. s f -> m (Event m r f)
newEvent ::
forall f.
s f ->
m (Event m r f)
}
unitEventBackend :: Applicative m => EventBackend m () s
unitEventBackend :: forall (m :: * -> *) (s :: * -> *).
Applicative m =>
EventBackend m () s
unitEventBackend = forall (m :: * -> *) r (s :: * -> *).
Applicative m =>
r -> EventBackend m r s
noopEventBackend ()
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
{ newEvent :: forall f. s f -> m (Event m (a, b) f)
newEvent = \s f
sel -> do
Event m a f
xEv <- forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> forall f. s f -> m (Event m r f)
newEvent EventBackend m a s
x s f
sel
Event m b f
yEv <- forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> forall f. s f -> m (Event m r f)
newEvent EventBackend m b s
y s f
sel
pure $
Event
{ reference :: (a, b)
reference = (forall (m :: * -> *) r f. Event m r f -> r
reference Event m a f
xEv, forall (m :: * -> *) r f. Event m r f -> r
reference Event m b f
yEv),
addField :: f -> m ()
addField = \f
f -> forall (m :: * -> *) r f. Event m r f -> f -> m ()
addField Event m a f
xEv f
f forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) r f. Event m r f -> f -> m ()
addField Event m b f
yEv f
f,
addReference :: Reference (a, b) -> m ()
addReference = \(Reference ReferenceType
ty (a
rx, b
ry)) ->
forall (m :: * -> *) r f. Event m r f -> Reference r -> m ()
addReference Event m a f
xEv (forall r. ReferenceType -> r -> Reference r
Reference ReferenceType
ty a
rx) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) r f. Event m r f -> Reference r -> m ()
addReference Event m b f
yEv (forall r. ReferenceType -> r -> Reference r
Reference ReferenceType
ty b
ry),
finalize :: Maybe SomeException -> m ()
finalize = \Maybe SomeException
me -> forall (m :: * -> *) r f.
Event m r f -> Maybe SomeException -> m ()
finalize Event m a f
xEv Maybe SomeException
me forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) r f.
Event m r f -> Maybe SomeException -> m ()
finalize Event m b f
yEv Maybe SomeException
me
}
}
noopEventBackend :: Applicative m => r -> EventBackend m r s
noopEventBackend :: forall (m :: * -> *) r (s :: * -> *).
Applicative m =>
r -> EventBackend m r s
noopEventBackend r
r =
EventBackend
{ newEvent :: forall f. s f -> m (Event m r f)
newEvent = \s f
_ ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
Event
{ reference :: r
reference = r
r,
addField :: f -> m ()
addField = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure (),
addReference :: Reference r -> m ()
addReference = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure (),
finalize :: Maybe SomeException -> m ()
finalize = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
}
}
hoistEventBackend ::
(Functor m) =>
(forall x. m x -> n x) ->
EventBackend m r s ->
EventBackend n r s
hoistEventBackend :: forall (m :: * -> *) (n :: * -> *) r (s :: * -> *).
Functor m =>
(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
{ newEvent :: forall f. s f -> n (Event n r f)
newEvent = 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 (m :: * -> *) (n :: * -> *) r f.
(forall x. m x -> n x) -> Event m r f -> Event n r f
hoistEvent forall x. m x -> n x
nt) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> forall f. s f -> m (Event m r f)
newEvent EventBackend m r s
backend
}
type InjectSelector s t = forall f. s f -> forall a. (forall g. t g -> (f -> g) -> a) -> a
injectSelector :: (forall f. s f -> t f) -> InjectSelector s t
injectSelector :: forall (s :: * -> *) (t :: * -> *).
(forall f. s f -> t f) -> InjectSelector s t
injectSelector forall f. s f -> t f
inj 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
idInjectSelector :: InjectSelector s s
idInjectSelector :: forall (s :: * -> *). InjectSelector s s
idInjectSelector s f
s forall g. s g -> (f -> g) -> a
go = forall g. s g -> (f -> g) -> a
go s f
s forall a. a -> a
id
narrowEventBackend ::
(Functor m) =>
InjectSelector s t ->
EventBackend m r t ->
EventBackend m r s
narrowEventBackend :: forall (m :: * -> *) (s :: * -> *) (t :: * -> *) r.
Functor m =>
InjectSelector s t -> EventBackend m r t -> EventBackend m r s
narrowEventBackend InjectSelector s t
inj EventBackend m r t
backend =
EventBackend
{ newEvent :: forall f. s f -> m (Event m r f)
newEvent = \s f
sel -> InjectSelector s t
inj s f
sel \t g
sel' f -> g
injField ->
forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> forall f. s f -> m (Event m r f)
newEvent EventBackend m r t
backend t g
sel' forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Event m r g
ev ->
Event m r g
ev
{ addField :: f -> m ()
addField = forall (m :: * -> *) r f. Event m r f -> f -> m ()
addField Event m r g
ev forall b c a. (b -> c) -> (a -> b) -> a -> c
. f -> g
injField
}
}
setReferenceEventBackend :: (Monad m) => Reference r -> EventBackend m r s -> EventBackend m r s
setReferenceEventBackend :: forall (m :: * -> *) r (s :: * -> *).
Monad m =>
Reference r -> EventBackend m r s -> EventBackend m r s
setReferenceEventBackend Reference r
r EventBackend m r s
backend =
EventBackend
{ newEvent :: forall f. s f -> m (Event m r f)
newEvent = \s f
sel -> do
Event m r f
ev <- forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> forall f. s f -> m (Event m r f)
newEvent EventBackend m r s
backend s f
sel
forall (m :: * -> *) r f. Event m r f -> Reference r -> m ()
addReference Event m r f
ev Reference r
r
pure Event m r f
ev
}
setParentEventBackend :: (Monad m) => r -> EventBackend m r s -> EventBackend m r s
setParentEventBackend :: forall (m :: * -> *) r (s :: * -> *).
Monad m =>
r -> EventBackend m r s -> EventBackend m r s
setParentEventBackend = forall (m :: * -> *) r (s :: * -> *).
Monad m =>
Reference r -> EventBackend m r s -> EventBackend m r s
setReferenceEventBackend forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r. ReferenceType -> r -> Reference r
Reference ReferenceType
Parent
setProximateEventBackend :: (Monad m) => r -> EventBackend m r s -> EventBackend m r s
setProximateEventBackend :: forall (m :: * -> *) r (s :: * -> *).
Monad m =>
r -> EventBackend m r s -> EventBackend m r s
setProximateEventBackend = forall (m :: * -> *) r (s :: * -> *).
Monad m =>
Reference r -> EventBackend m r s -> EventBackend m r s
setReferenceEventBackend forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r. ReferenceType -> r -> Reference r
Reference ReferenceType
Proximate
setDefaultReferenceEventBackend :: (PrimMonad m) => Reference r -> EventBackend m r s -> EventBackend m r s
setDefaultReferenceEventBackend :: forall (m :: * -> *) r (s :: * -> *).
PrimMonad m =>
Reference r -> EventBackend m r s -> EventBackend m r s
setDefaultReferenceEventBackend ref :: Reference r
ref@(Reference ReferenceType
ty r
_) EventBackend m r s
backend =
EventBackend
{ newEvent :: forall f. s f -> m (Event m r f)
newEvent = \s f
sel -> do
MVar (PrimState m) ()
flag <- forall (m :: * -> *) a. PrimMonad m => m (MVar (PrimState m) a)
newEmptyMVar
Event m r f
ev <- forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> forall f. s f -> m (Event m r f)
newEvent EventBackend m r s
backend s f
sel
pure $
Event m r f
ev
{ addReference :: Reference r -> m ()
addReference = \ref' :: Reference r
ref'@(Reference ReferenceType
ty' r
_) -> do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ReferenceType
ty' forall a. Eq a => a -> a -> Bool
== ReferenceType
ty) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
PrimMonad m =>
MVar (PrimState m) a -> a -> m Bool
tryPutMVar MVar (PrimState m) ()
flag ()
forall (m :: * -> *) r f. Event m r f -> Reference r -> m ()
addReference Event m r f
ev Reference r
ref',
finalize :: Maybe SomeException -> m ()
finalize = \Maybe SomeException
me -> do
forall (m :: * -> *) a.
PrimMonad m =>
MVar (PrimState m) a -> a -> m Bool
tryPutMVar MVar (PrimState m) ()
flag () forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
False -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Bool
True -> forall (m :: * -> *) r f. Event m r f -> Reference r -> m ()
addReference Event m r f
ev Reference r
ref
forall (m :: * -> *) r f.
Event m r f -> Maybe SomeException -> m ()
finalize Event m r f
ev Maybe SomeException
me
}
}
setAncestorEventBackend :: (PrimMonad m) => r -> EventBackend m r s -> EventBackend m r s
setAncestorEventBackend :: forall (m :: * -> *) r (s :: * -> *).
PrimMonad m =>
r -> EventBackend m r s -> EventBackend m r s
setAncestorEventBackend = forall (m :: * -> *) r (s :: * -> *).
PrimMonad m =>
Reference r -> EventBackend m r s -> EventBackend m r s
setDefaultReferenceEventBackend forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r. ReferenceType -> r -> Reference r
Reference ReferenceType
Parent
setInitialCauseEventBackend :: (PrimMonad m) => r -> EventBackend m r s -> EventBackend m r s
setInitialCauseEventBackend :: forall (m :: * -> *) r (s :: * -> *).
PrimMonad m =>
r -> EventBackend m r s -> EventBackend m r s
setInitialCauseEventBackend = forall (m :: * -> *) r (s :: * -> *).
PrimMonad m =>
Reference r -> EventBackend m r s -> EventBackend m r s
setDefaultReferenceEventBackend forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r. ReferenceType -> r -> Reference r
Reference ReferenceType
Proximate