{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE UndecidableInstances #-}
module Observe.Event
( Event,
hoistEvent,
addField,
reference,
Explicit.addParent,
Explicit.addProximate,
addReference,
Reference (..),
ReferenceType (..),
MonadEvent,
EnvEvent,
withEvent,
withNarrowingEvent,
InjectSelector,
injectSelector,
idInjectSelector,
MonadWithEvent,
allocateEvent,
EventT,
runEventT,
eventLift,
TransEventMonad (..),
BackendMonad,
EnvBackend,
EventBackend,
liftBackendMonad,
backend,
withModifiedBackend,
finalize,
newEvent',
newSubEvent,
BackendEvent,
hoistBackendEvent,
allocateBackendEvent,
withBackendEvent,
newBackendEvent,
)
where
import Control.Monad.Primitive
import Control.Monad.With
import Data.Exceptable
import Data.GeneralAllocate
import Data.Kind
import Observe.Event.Backend
import Observe.Event.Class
import qualified Observe.Event.Explicit as Explicit
type EnvEvent :: EventMonadKind -> ReferenceKind -> SelectorKind -> Type -> Type
type EnvEvent em r s = Event (em r s) r
withEvent ::
(MonadWithEvent em r s) =>
forall f.
s f ->
(EnvEvent em r s f -> em r s a) ->
em r s a
withEvent :: forall (em :: EventMonadKind) (r :: ReferenceKind)
(s :: SelectorKind) (a :: ReferenceKind) (f :: ReferenceKind).
MonadWithEvent em r s =>
s f -> (EnvEvent em r s f -> em r s a) -> em r s a
withEvent = forall (em :: EventMonadKind) (r :: ReferenceKind)
(t :: SelectorKind) (s :: SelectorKind) (x :: ReferenceKind).
MonadWithEvent em r t =>
InjectSelector s t
-> forall (f :: ReferenceKind).
t f -> (EnvEvent em r s f -> em r s x) -> em r t x
withNarrowingEvent forall (s :: SelectorKind). InjectSelector s s
idInjectSelector
withNarrowingEvent ::
(MonadWithEvent em r t) =>
InjectSelector s t ->
forall f.
t f ->
(EnvEvent em r s f -> em r s x) ->
em r t x
withNarrowingEvent :: forall (em :: EventMonadKind) (r :: ReferenceKind)
(t :: SelectorKind) (s :: SelectorKind) (x :: ReferenceKind).
MonadWithEvent em r t =>
InjectSelector s t
-> forall (f :: ReferenceKind).
t f -> (EnvEvent em r s f -> em r s x) -> em r t x
withNarrowingEvent InjectSelector s t
inj t f
sel EnvEvent em r s f -> em r s x
go = forall (em :: EventMonadKind) (r :: ReferenceKind)
(s :: SelectorKind) (a :: ReferenceKind) (f :: ReferenceKind).
(MonadEvent em, MonadWithExceptable (em r s)) =>
s f -> (BackendEvent em r f -> em r s a) -> em r s a
withBackendEvent t f
sel forall (a :: ReferenceKind) b. (a -> b) -> a -> b
$ \BackendEvent em r f
ev -> do
let ev' :: EnvEvent em r s f
ev' = forall (em :: EventMonadKind) (r :: ReferenceKind)
(f :: ReferenceKind) (s :: SelectorKind).
MonadEvent em =>
BackendEvent em r f -> EnvEvent em r s f
hoistBackendEvent BackendEvent em r f
ev
forall (em :: EventMonadKind) (r :: ReferenceKind)
(s :: SelectorKind) (r' :: ReferenceKind) (s' :: SelectorKind)
(a :: ReferenceKind).
MonadEvent em =>
(EnvBackend em r s -> EnvBackend em r' s')
-> em r' s' a -> em r s a
withModifiedBackend (forall (m :: SelectorKind) (s :: SelectorKind) (t :: SelectorKind)
(r :: ReferenceKind).
Functor m =>
InjectSelector s t -> EventBackend m r t -> EventBackend m r s
narrowEventBackend InjectSelector s t
inj forall (b :: ReferenceKind) (c :: ReferenceKind)
(a :: ReferenceKind).
(b -> c) -> (a -> b) -> a -> c
. forall (m :: SelectorKind) (r :: ReferenceKind)
(s :: SelectorKind).
PrimMonad m =>
r -> EventBackend m r s -> EventBackend m r s
setAncestorEventBackend (forall (m :: SelectorKind) (r :: ReferenceKind)
(f :: ReferenceKind).
Event m r f -> r
reference BackendEvent em r f
ev)) forall (a :: ReferenceKind) b. (a -> b) -> a -> b
$ EnvEvent em r s f -> em r s x
go EnvEvent em r s f
ev'
type MonadWithEvent em r s = (MonadEvent em, PrimMonad (BackendMonad em), MonadWithExceptable (em r s))
allocateEvent ::
(MonadEvent em, Exceptable e) =>
forall f.
s f ->
GeneralAllocate (em r s) e () releaseArg (EnvEvent em r s f)
allocateEvent :: forall (em :: EventMonadKind) (e :: ReferenceKind)
(s :: SelectorKind) (r :: ReferenceKind)
(releaseArg :: ReferenceKind) (f :: ReferenceKind).
(MonadEvent em, Exceptable e) =>
s f -> GeneralAllocate (em r s) e () releaseArg (EnvEvent em r s f)
allocateEvent = forall (f :: SelectorKind) (a :: ReferenceKind)
(b :: ReferenceKind).
Functor f =>
(a -> b) -> f a -> f b
fmap forall (em :: EventMonadKind) (r :: ReferenceKind)
(f :: ReferenceKind) (s :: SelectorKind).
MonadEvent em =>
BackendEvent em r f -> EnvEvent em r s f
hoistBackendEvent forall (b :: ReferenceKind) (c :: ReferenceKind)
(a :: ReferenceKind).
(b -> c) -> (a -> b) -> a -> c
. forall (em :: EventMonadKind) (e :: ReferenceKind)
(s :: SelectorKind) (r :: ReferenceKind)
(releaseArg :: ReferenceKind) (f :: ReferenceKind).
(MonadEvent em, Exceptable e) =>
s f
-> GeneralAllocate (em r s) e () releaseArg (BackendEvent em r f)
allocateBackendEvent
newEvent' :: (MonadEvent em) => forall f. s f -> em r s (EnvEvent em r s f)
newEvent' :: forall (em :: EventMonadKind) (s :: SelectorKind)
(r :: ReferenceKind) (f :: ReferenceKind).
MonadEvent em =>
s f -> em r s (EnvEvent em r s f)
newEvent' = forall (f :: SelectorKind) (a :: ReferenceKind)
(b :: ReferenceKind).
Functor f =>
(a -> b) -> f a -> f b
fmap forall (em :: EventMonadKind) (r :: ReferenceKind)
(f :: ReferenceKind) (s :: SelectorKind).
MonadEvent em =>
BackendEvent em r f -> EnvEvent em r s f
hoistBackendEvent forall (b :: ReferenceKind) (c :: ReferenceKind)
(a :: ReferenceKind).
(b -> c) -> (a -> b) -> a -> c
. forall (em :: EventMonadKind) (s :: SelectorKind)
(r :: ReferenceKind) (f :: ReferenceKind).
MonadEvent em =>
s f -> em r s (BackendEvent em r f)
newBackendEvent
newSubEvent ::
(MonadEvent em) =>
EnvEvent em r s f ->
forall f'.
s f' ->
em r s (EnvEvent em r s f')
newSubEvent :: forall (em :: EventMonadKind) (r :: ReferenceKind)
(s :: SelectorKind) (f :: ReferenceKind).
MonadEvent em =>
EnvEvent em r s f
-> forall (f' :: ReferenceKind).
s f' -> em r s (EnvEvent em r s f')
newSubEvent EnvEvent em r s f
ev s f'
sel = do
EnvEvent em r s f'
child <- forall (em :: EventMonadKind) (s :: SelectorKind)
(r :: ReferenceKind) (f :: ReferenceKind).
MonadEvent em =>
s f -> em r s (EnvEvent em r s f)
newEvent' s f'
sel
forall (m :: SelectorKind) (r :: ReferenceKind)
(f :: ReferenceKind).
Event m r f -> r -> m ()
Explicit.addParent EnvEvent em r s f'
child forall (a :: ReferenceKind) b. (a -> b) -> a -> b
$ forall (m :: SelectorKind) (r :: ReferenceKind)
(f :: ReferenceKind).
Event m r f -> r
reference EnvEvent em r s f
ev
pure EnvEvent em r s f'
child
type BackendEvent :: EventMonadKind -> ReferenceKind -> Type -> Type
type BackendEvent em = Event (BackendMonad em)
hoistBackendEvent :: (MonadEvent em) => BackendEvent em r f -> EnvEvent em r s f
hoistBackendEvent :: forall (em :: EventMonadKind) (r :: ReferenceKind)
(f :: ReferenceKind) (s :: SelectorKind).
MonadEvent em =>
BackendEvent em r f -> EnvEvent em r s f
hoistBackendEvent = forall (m :: SelectorKind) (n :: SelectorKind) (r :: ReferenceKind)
(f :: ReferenceKind).
(forall (x :: ReferenceKind). m x -> n x)
-> Event m r f -> Event n r f
hoistEvent forall (em :: EventMonadKind) (a :: ReferenceKind)
(r :: ReferenceKind) (s :: SelectorKind).
MonadEvent em =>
BackendMonad em a -> em r s a
liftBackendMonad
allocateBackendEvent ::
(MonadEvent em, Exceptable e) =>
forall f.
s f ->
GeneralAllocate (em r s) e () releaseArg (BackendEvent em r f)
allocateBackendEvent :: forall (em :: EventMonadKind) (e :: ReferenceKind)
(s :: SelectorKind) (r :: ReferenceKind)
(releaseArg :: ReferenceKind) (f :: ReferenceKind).
(MonadEvent em, Exceptable e) =>
s f
-> GeneralAllocate (em r s) e () releaseArg (BackendEvent em r f)
allocateBackendEvent s f
sel = forall (m :: SelectorKind) (e :: ReferenceKind)
(releaseReturn :: ReferenceKind) (releaseArg :: ReferenceKind)
(a :: ReferenceKind).
((forall (x :: ReferenceKind). m x -> m x)
-> m (GeneralAllocated m e releaseReturn releaseArg a))
-> GeneralAllocate m e releaseReturn releaseArg a
GeneralAllocate forall (a :: ReferenceKind) b. (a -> b) -> a -> b
$ \forall (x :: ReferenceKind). em r s x -> em r s x
_ -> do
BackendEvent em r f
ev <- forall (em :: EventMonadKind) (s :: SelectorKind)
(r :: ReferenceKind) (f :: ReferenceKind).
MonadEvent em =>
s f -> em r s (BackendEvent em r f)
newBackendEvent s f
sel
let release :: GeneralReleaseType e releaseArg -> em r s ()
release (ReleaseFailure e
e) = forall (em :: EventMonadKind) (a :: ReferenceKind)
(r :: ReferenceKind) (s :: SelectorKind).
MonadEvent em =>
BackendMonad em a -> em r s a
liftBackendMonad forall (b :: ReferenceKind) (c :: ReferenceKind)
(a :: ReferenceKind).
(b -> c) -> (a -> b) -> a -> c
. forall (m :: SelectorKind) (r :: ReferenceKind)
(f :: ReferenceKind).
Event m r f -> Maybe SomeException -> m ()
finalize BackendEvent em r f
ev forall (b :: ReferenceKind) (c :: ReferenceKind)
(a :: ReferenceKind).
(b -> c) -> (a -> b) -> a -> c
. forall (a :: ReferenceKind). a -> Maybe a
Just forall (a :: ReferenceKind) b. (a -> b) -> a -> b
$ forall (e :: ReferenceKind). Exceptable e => e -> SomeException
toSomeException e
e
release (ReleaseSuccess releaseArg
_) = forall (em :: EventMonadKind) (a :: ReferenceKind)
(r :: ReferenceKind) (s :: SelectorKind).
MonadEvent em =>
BackendMonad em a -> em r s a
liftBackendMonad forall (a :: ReferenceKind) b. (a -> b) -> a -> b
$ forall (m :: SelectorKind) (r :: ReferenceKind)
(f :: ReferenceKind).
Event m r f -> Maybe SomeException -> m ()
finalize BackendEvent em r f
ev forall (a :: ReferenceKind). Maybe a
Nothing
forall (f :: SelectorKind) (a :: ReferenceKind).
Applicative f =>
a -> f a
pure forall (a :: ReferenceKind) b. (a -> b) -> a -> b
$ forall (m :: SelectorKind) (e :: ReferenceKind)
(releaseReturn :: ReferenceKind) (releaseArg :: ReferenceKind)
(a :: ReferenceKind).
a
-> (GeneralReleaseType e releaseArg -> m releaseReturn)
-> GeneralAllocated m e releaseReturn releaseArg a
GeneralAllocated BackendEvent em r f
ev GeneralReleaseType e releaseArg -> em r s ()
release
withBackendEvent ::
(MonadEvent em, MonadWithExceptable (em r s)) =>
forall f.
s f ->
(BackendEvent em r f -> em r s a) ->
em r s a
withBackendEvent :: forall (em :: EventMonadKind) (r :: ReferenceKind)
(s :: SelectorKind) (a :: ReferenceKind) (f :: ReferenceKind).
(MonadEvent em, MonadWithExceptable (em r s)) =>
s f -> (BackendEvent em r f -> em r s a) -> em r s a
withBackendEvent = forall (m :: SelectorKind) (b :: ReferenceKind)
(a :: ReferenceKind).
MonadWith m =>
With m b a -> (a -> m b) -> m b
generalWith forall (b :: ReferenceKind) (c :: ReferenceKind)
(a :: ReferenceKind).
(b -> c) -> (a -> b) -> a -> c
. forall (em :: EventMonadKind) (e :: ReferenceKind)
(s :: SelectorKind) (r :: ReferenceKind)
(releaseArg :: ReferenceKind) (f :: ReferenceKind).
(MonadEvent em, Exceptable e) =>
s f
-> GeneralAllocate (em r s) e () releaseArg (BackendEvent em r f)
allocateBackendEvent
newBackendEvent :: (MonadEvent em) => forall f. s f -> em r s (BackendEvent em r f)
newBackendEvent :: forall (em :: EventMonadKind) (s :: SelectorKind)
(r :: ReferenceKind) (f :: ReferenceKind).
MonadEvent em =>
s f -> em r s (BackendEvent em r f)
newBackendEvent s f
sel = do
EventBackend (BackendMonad em) r s
b <- forall (em :: EventMonadKind) (r :: ReferenceKind)
(s :: SelectorKind).
MonadEvent em =>
em r s (EnvBackend em r s)
backend
forall (em :: EventMonadKind) (a :: ReferenceKind)
(r :: ReferenceKind) (s :: SelectorKind).
MonadEvent em =>
BackendMonad em a -> em r s a
liftBackendMonad forall (a :: ReferenceKind) b. (a -> b) -> a -> b
$ forall (m :: SelectorKind) (r :: ReferenceKind)
(s :: SelectorKind).
EventBackend m r s
-> forall (f :: ReferenceKind). s f -> m (Event m r f)
Explicit.newEvent EventBackend (BackendMonad em) r s
b s f
sel