{-# 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,
MonadEvent,
EnvEvent,
NewEventArgs (..),
emitImmediateEvent',
withEvent,
withEventArgs,
withNarrowingEvent,
withNarrowingEventArgs,
InjectSelector,
injectSelector,
idInjectSelector,
MonadWithEvent,
allocateEvent,
allocateEventArgs,
EventT,
runEventT,
eventLift,
TransEventMonad (..),
BackendMonad,
EnvBackend,
EventBackend,
liftBackendMonad,
backend,
withModifiedBackend,
finalize,
newEvent',
newEventArgs,
BackendEvent,
hoistBackendEvent,
allocateBackendEvent,
withBackendEvent,
newBackendEvent,
)
where
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
emitImmediateEvent' :: (MonadEvent em) => NewEventArgs r s f -> em r s r
emitImmediateEvent' :: forall (em :: EventMonadKind) r (s :: * -> *) f.
MonadEvent em =>
NewEventArgs r s f -> em r s r
emitImmediateEvent' NewEventArgs r s f
args = do
EventBackend (BackendMonad em) r s
b <- forall (em :: EventMonadKind) r (s :: * -> *).
MonadEvent em =>
em r s (EnvBackend em r s)
backend
forall (em :: EventMonadKind) a r (s :: * -> *).
MonadEvent em =>
BackendMonad em a -> em r s a
liftBackendMonad forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> forall f. NewEventArgs r s f -> m r
emitImmediateEvent EventBackend (BackendMonad em) r s
b NewEventArgs r s f
args
withEvent ::
(MonadWithEvent em) =>
forall f.
s f ->
(EnvEvent em r s f -> em r s a) ->
em r s a
withEvent :: forall (em :: EventMonadKind) (s :: * -> *) r a f.
MonadWithEvent em =>
s f -> (EnvEvent em r s f -> em r s a) -> em r s a
withEvent = forall (em :: EventMonadKind) (s :: * -> *) (t :: * -> *) r x.
MonadWithEvent em =>
InjectSelector s t
-> forall f. t f -> (EnvEvent em r s f -> em r s x) -> em r t x
withNarrowingEvent forall (s :: * -> *). InjectSelector s s
idInjectSelector
withEventArgs ::
(MonadWithEvent em) =>
forall f.
NewEventArgs r s f ->
(EnvEvent em r s f -> em r s a) ->
em r s a
withEventArgs :: forall (em :: EventMonadKind) r (s :: * -> *) a f.
MonadWithEvent em =>
NewEventArgs r s f -> (EnvEvent em r s f -> em r s a) -> em r s a
withEventArgs = forall (em :: EventMonadKind) (s :: * -> *) (t :: * -> *) r x.
MonadWithEvent em =>
InjectSelector s t
-> forall f.
NewEventArgs r t f -> (EnvEvent em r s f -> em r s x) -> em r t x
withNarrowingEventArgs forall (s :: * -> *). InjectSelector s s
idInjectSelector
withNarrowingEvent ::
(MonadWithEvent em) =>
InjectSelector s t ->
forall f.
t f ->
(EnvEvent em r s f -> em r s x) ->
em r t x
withNarrowingEvent :: forall (em :: EventMonadKind) (s :: * -> *) (t :: * -> *) r x.
MonadWithEvent em =>
InjectSelector s t
-> forall f. t f -> (EnvEvent em r s f -> em r s x) -> em r t x
withNarrowingEvent InjectSelector s t
inj = forall (em :: EventMonadKind) (s :: * -> *) (t :: * -> *) r x.
MonadWithEvent em =>
InjectSelector s t
-> forall f.
NewEventArgs r t f -> (EnvEvent em r s f -> em r s x) -> em r t x
withNarrowingEventArgs InjectSelector s t
inj forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (s :: * -> *) f r. s f -> NewEventArgs r s f
simpleNewEventArgs
withNarrowingEventArgs ::
(MonadWithEvent em) =>
InjectSelector s t ->
forall f.
NewEventArgs r t f ->
(EnvEvent em r s f -> em r s x) ->
em r t x
withNarrowingEventArgs :: forall (em :: EventMonadKind) (s :: * -> *) (t :: * -> *) r x.
MonadWithEvent em =>
InjectSelector s t
-> forall f.
NewEventArgs r t f -> (EnvEvent em r s f -> em r s x) -> em r t x
withNarrowingEventArgs InjectSelector s t
inj NewEventArgs r t f
args EnvEvent em r s f -> em r s x
go = forall (em :: EventMonadKind) r (s :: * -> *) a f.
(MonadEvent em, MonadWithExceptable (em r s)) =>
NewEventArgs r s f -> (BackendEvent em r f -> em r s a) -> em r s a
withBackendEvent NewEventArgs r t f
args forall a b. (a -> b) -> a -> b
$ \BackendEvent em r f
ev -> do
let ev' :: EnvEvent em r s f
ev' = forall (em :: EventMonadKind) r f (s :: * -> *).
MonadEvent em =>
BackendEvent em r f -> EnvEvent em r s f
hoistBackendEvent BackendEvent em r f
ev
forall (em :: EventMonadKind) r (s :: * -> *) r' (s' :: * -> *) a.
MonadEvent em =>
(EnvBackend em r s -> EnvBackend em r' s')
-> em r' s' a -> em r s a
withModifiedBackend (forall (m :: * -> *) (s :: * -> *) (t :: * -> *) r.
Functor m =>
InjectSelector s t -> EventBackend m r t -> EventBackend m r s
narrowEventBackend InjectSelector s t
inj forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r (m :: * -> *) (s :: * -> *).
r -> EventBackend m r s -> EventBackend m r s
setAncestorEventBackend (forall (m :: * -> *) r f. Event m r f -> r
reference BackendEvent em r f
ev)) forall a b. (a -> b) -> a -> b
$ EnvEvent em r s f -> em r s x
go EnvEvent em r s f
ev'
class (MonadEvent em, forall r s. MonadWithExceptable (em r s)) => MonadWithEvent em
instance (MonadEvent em, forall r s. MonadWithExceptable (em r s)) => MonadWithEvent em
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 (s :: * -> *) r releaseArg f.
(MonadEvent em, Exceptable e) =>
s f -> GeneralAllocate (em r s) e () releaseArg (EnvEvent em r s f)
allocateEvent = forall (em :: EventMonadKind) e r (s :: * -> *) releaseArg f.
(MonadEvent em, Exceptable e) =>
NewEventArgs r s f
-> GeneralAllocate (em r s) e () releaseArg (EnvEvent em r s f)
allocateEventArgs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (s :: * -> *) f r. s f -> NewEventArgs r s f
simpleNewEventArgs
allocateEventArgs ::
(MonadEvent em, Exceptable e) =>
forall f.
NewEventArgs r s f ->
GeneralAllocate (em r s) e () releaseArg (EnvEvent em r s f)
allocateEventArgs :: forall (em :: EventMonadKind) e r (s :: * -> *) releaseArg f.
(MonadEvent em, Exceptable e) =>
NewEventArgs r s f
-> GeneralAllocate (em r s) e () releaseArg (EnvEvent em r s f)
allocateEventArgs = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (em :: EventMonadKind) r f (s :: * -> *).
MonadEvent em =>
BackendEvent em r f -> EnvEvent em r s f
hoistBackendEvent forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (em :: EventMonadKind) e r (s :: * -> *) releaseArg f.
(MonadEvent em, Exceptable e) =>
NewEventArgs r 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 :: * -> *) r f.
MonadEvent em =>
s f -> em r s (EnvEvent em r s f)
newEvent' = forall (em :: EventMonadKind) r (s :: * -> *) f.
MonadEvent em =>
NewEventArgs r s f -> em r s (EnvEvent em r s f)
newEventArgs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (s :: * -> *) f r. s f -> NewEventArgs r s f
simpleNewEventArgs
newEventArgs :: (MonadEvent em) => forall f. NewEventArgs r s f -> em r s (EnvEvent em r s f)
newEventArgs :: forall (em :: EventMonadKind) r (s :: * -> *) f.
MonadEvent em =>
NewEventArgs r s f -> em r s (EnvEvent em r s f)
newEventArgs = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (em :: EventMonadKind) r f (s :: * -> *).
MonadEvent em =>
BackendEvent em r f -> EnvEvent em r s f
hoistBackendEvent forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (em :: EventMonadKind) r (s :: * -> *) f.
MonadEvent em =>
NewEventArgs r s f -> em r s (BackendEvent em r f)
newBackendEvent
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 f (s :: * -> *).
MonadEvent em =>
BackendEvent em r f -> EnvEvent em r s f
hoistBackendEvent = forall (m :: * -> *) (n :: * -> *) r f.
(forall x. m x -> n x) -> Event m r f -> Event n r f
hoistEvent forall (em :: EventMonadKind) a r (s :: * -> *).
MonadEvent em =>
BackendMonad em a -> em r s a
liftBackendMonad
allocateBackendEvent ::
(MonadEvent em, Exceptable e) =>
forall f.
NewEventArgs r s f ->
GeneralAllocate (em r s) e () releaseArg (BackendEvent em r f)
allocateBackendEvent :: forall (em :: EventMonadKind) e r (s :: * -> *) releaseArg f.
(MonadEvent em, Exceptable e) =>
NewEventArgs r s f
-> GeneralAllocate (em r s) e () releaseArg (BackendEvent em r f)
allocateBackendEvent NewEventArgs r s f
args = forall (m :: * -> *) e releaseReturn releaseArg a.
((forall x. m x -> m x)
-> m (GeneralAllocated m e releaseReturn releaseArg a))
-> GeneralAllocate m e releaseReturn releaseArg a
GeneralAllocate forall a b. (a -> b) -> a -> b
$ \forall x. em r s x -> em r s x
_ -> do
BackendEvent em r f
ev <- forall (em :: EventMonadKind) r (s :: * -> *) f.
MonadEvent em =>
NewEventArgs r s f -> em r s (BackendEvent em r f)
newBackendEvent NewEventArgs r s f
args
let release :: GeneralReleaseType e releaseArg -> em r s ()
release (ReleaseFailure e
e) = forall (em :: EventMonadKind) a r (s :: * -> *).
MonadEvent em =>
BackendMonad em a -> em r s a
liftBackendMonad forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) r f.
Event m r f -> Maybe SomeException -> m ()
finalize BackendEvent em r f
ev forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall e. Exceptable e => e -> SomeException
toSomeException e
e
release (ReleaseSuccess releaseArg
_) = forall (em :: EventMonadKind) a r (s :: * -> *).
MonadEvent em =>
BackendMonad em a -> em r s a
liftBackendMonad forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r f.
Event m r f -> Maybe SomeException -> m ()
finalize BackendEvent em r f
ev forall a. Maybe a
Nothing
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e releaseReturn releaseArg a.
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.
NewEventArgs r s f ->
(BackendEvent em r f -> em r s a) ->
em r s a
withBackendEvent :: forall (em :: EventMonadKind) r (s :: * -> *) a f.
(MonadEvent em, MonadWithExceptable (em r s)) =>
NewEventArgs r s f -> (BackendEvent em r f -> em r s a) -> em r s a
withBackendEvent = forall (m :: * -> *) b a.
MonadWith m =>
With m b a -> (a -> m b) -> m b
generalWith forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (em :: EventMonadKind) e r (s :: * -> *) releaseArg f.
(MonadEvent em, Exceptable e) =>
NewEventArgs r s f
-> GeneralAllocate (em r s) e () releaseArg (BackendEvent em r f)
allocateBackendEvent
newBackendEvent :: (MonadEvent em) => forall f. NewEventArgs r s f -> em r s (BackendEvent em r f)
newBackendEvent :: forall (em :: EventMonadKind) r (s :: * -> *) f.
MonadEvent em =>
NewEventArgs r s f -> em r s (BackendEvent em r f)
newBackendEvent NewEventArgs r s f
args = do
EventBackend (BackendMonad em) r s
b <- forall (em :: EventMonadKind) r (s :: * -> *).
MonadEvent em =>
em r s (EnvBackend em r s)
backend
forall (em :: EventMonadKind) a r (s :: * -> *).
MonadEvent em =>
BackendMonad em a -> em r s a
liftBackendMonad forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s
-> forall f. NewEventArgs r s f -> m (Event m r f)
Explicit.newEvent EventBackend (BackendMonad em) r s
b NewEventArgs r s f
args