{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
module Observe.Event.Backend
  ( 
    EventBackend (..),
    Event (..),
    NewEventArgs (..),
    simpleNewEventArgs,
    
    unitEventBackend,
    pairEventBackend,
    noopEventBackend,
    
    hoistEventBackend,
    hoistEvent,
    InjectSelector,
    injectSelector,
    idInjectSelector,
    narrowEventBackend,
    setAncestorEventBackend,
    setInitialCauseEventBackend,
  )
where
import Control.Applicative
import Control.Exception
import Control.Monad.Zip
import Data.Functor
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 -> 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,
      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 EventBackend m r s = EventBackend
  { 
    
    
    
    forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s
-> forall f. NewEventArgs r s f -> m (Event m r f)
newEvent :: forall f. NewEventArgs r s f -> m (Event m r f),
    
    
    
    
    forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> forall f. NewEventArgs r s f -> m r
emitImmediateEvent :: forall f. NewEventArgs r s f -> m r
  }
data NewEventArgs r s f = NewEventArgs
  { 
    
    
    
    
    
    forall r (s :: * -> *) f. NewEventArgs r s f -> s f
newEventSelector :: !(s f),
    
    
    
    forall r (s :: * -> *) f. NewEventArgs r s f -> Maybe r
newEventParent :: !(Maybe r),
    
    forall r (s :: * -> *) f. NewEventArgs r s f -> [r]
newEventCauses :: ![r],
    
    
    
    forall r (s :: * -> *) f. NewEventArgs r s f -> [f]
newEventInitialFields :: ![f]
  }
simpleNewEventArgs :: s f -> NewEventArgs r s f
simpleNewEventArgs :: forall (s :: * -> *) f r. s f -> NewEventArgs r s f
simpleNewEventArgs s f
sel =
  NewEventArgs
    { newEventSelector :: s f
newEventSelector = s f
sel,
      newEventParent :: Maybe r
newEventParent = forall a. Maybe a
Nothing,
      newEventCauses :: [r]
newEventCauses = [],
      newEventInitialFields :: [f]
newEventInitialFields = []
    }
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. NewEventArgs (a, b) s f -> m (Event m (a, b) f)
newEvent = \NewEventArgs (a, b) s f
args -> do
        let (NewEventArgs a s f
xArgs, NewEventArgs b s f
yArgs) = forall {r} {r} {s :: * -> *} {f}.
NewEventArgs (r, r) s f -> (NewEventArgs r s f, NewEventArgs r s f)
unzipArgs NewEventArgs (a, b) s f
args
        Event m a f
xEv <- forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s
-> forall f. NewEventArgs r s f -> m (Event m r f)
newEvent EventBackend m a s
x NewEventArgs a s f
xArgs
        Event m b f
yEv <- forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s
-> forall f. NewEventArgs r s f -> m (Event m r f)
newEvent EventBackend m b s
y NewEventArgs b s f
yArgs
        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,
              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
            },
      emitImmediateEvent :: forall f. NewEventArgs (a, b) s f -> m (a, b)
emitImmediateEvent = \NewEventArgs (a, b) s f
args -> do
        let (NewEventArgs a s f
xArgs, NewEventArgs b s f
yArgs) = forall {r} {r} {s :: * -> *} {f}.
NewEventArgs (r, r) s f -> (NewEventArgs r s f, NewEventArgs r s f)
unzipArgs NewEventArgs (a, b) s f
args
        a
xRef <- forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> forall f. NewEventArgs r s f -> m r
emitImmediateEvent EventBackend m a s
x NewEventArgs a s f
xArgs
        b
yRef <- forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> forall f. NewEventArgs r s f -> m r
emitImmediateEvent EventBackend m b s
y NewEventArgs b s f
yArgs
        pure $ (a
xRef, b
yRef)
    }
  where
    unzipArgs :: NewEventArgs (r, r) s f -> (NewEventArgs r s f, NewEventArgs r s f)
unzipArgs NewEventArgs (r, r) s f
args =
      ( NewEventArgs (r, r) s f
args
          { newEventParent :: Maybe r
newEventParent = Maybe r
xParent,
            newEventCauses :: [r]
newEventCauses = [r]
xCauses
          },
        NewEventArgs (r, r) s f
args
          { newEventParent :: Maybe r
newEventParent = Maybe r
yParent,
            newEventCauses :: [r]
newEventCauses = [r]
yCauses
          }
      )
      where
        (Maybe r
xParent, Maybe r
yParent) = forall (m :: * -> *) a b. MonadZip m => m (a, b) -> (m a, m b)
munzip forall a b. (a -> b) -> a -> b
$ forall r (s :: * -> *) f. NewEventArgs r s f -> Maybe r
newEventParent NewEventArgs (r, r) s f
args
        ([r]
xCauses, [r]
yCauses) = forall (m :: * -> *) a b. MonadZip m => m (a, b) -> (m a, m b)
munzip forall a b. (a -> b) -> a -> b
$ forall r (s :: * -> *) f. NewEventArgs r s f -> [r]
newEventCauses NewEventArgs (r, r) s f
args
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. NewEventArgs r s f -> m (Event m r f)
newEvent = \NewEventArgs r 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 (),
              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 ()
            },
      emitImmediateEvent :: forall f. NewEventArgs r s f -> m r
emitImmediateEvent = \NewEventArgs r s f
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure r
r
    }
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. NewEventArgs r 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. NewEventArgs r s f -> m (Event m r f)
newEvent EventBackend m r s
backend,
      emitImmediateEvent :: forall f. NewEventArgs r s f -> n r
emitImmediateEvent = 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. NewEventArgs r s f -> m r
emitImmediateEvent 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. NewEventArgs r s f -> m (Event m r f)
newEvent = \NewEventArgs r s f
args -> InjectSelector s t
inj (forall r (s :: * -> *) f. NewEventArgs r s f -> s f
newEventSelector NewEventArgs r s f
args) \t g
sel' f -> g
injField ->
        forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s
-> forall f. NewEventArgs r s f -> m (Event m r f)
newEvent EventBackend m r t
backend (forall {r} {s :: * -> *} {a} {s :: * -> *} {f}.
NewEventArgs r s a -> s f -> (a -> f) -> NewEventArgs r s f
transformArgs NewEventArgs r s f
args t g
sel' f -> g
injField) 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
            },
      emitImmediateEvent :: forall f. NewEventArgs r s f -> m r
emitImmediateEvent = \NewEventArgs r s f
args -> InjectSelector s t
inj (forall r (s :: * -> *) f. NewEventArgs r s f -> s f
newEventSelector NewEventArgs r s f
args) \t g
sel' f -> g
injField ->
        forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> forall f. NewEventArgs r s f -> m r
emitImmediateEvent EventBackend m r t
backend forall a b. (a -> b) -> a -> b
$ forall {r} {s :: * -> *} {a} {s :: * -> *} {f}.
NewEventArgs r s a -> s f -> (a -> f) -> NewEventArgs r s f
transformArgs NewEventArgs r s f
args t g
sel' f -> g
injField
    }
  where
    transformArgs :: NewEventArgs r s a -> s f -> (a -> f) -> NewEventArgs r s f
transformArgs NewEventArgs r s a
args s f
sel' a -> f
injField =
      NewEventArgs r s a
args
        { newEventSelector :: s f
newEventSelector = s f
sel',
          newEventInitialFields :: [f]
newEventInitialFields = a -> f
injField forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (s :: * -> *) f. NewEventArgs r s f -> [f]
newEventInitialFields NewEventArgs r s a
args
        }
setAncestorEventBackend :: r -> EventBackend m r s -> EventBackend m r s
setAncestorEventBackend :: forall r (m :: * -> *) (s :: * -> *).
r -> EventBackend m r s -> EventBackend m r s
setAncestorEventBackend r
parent EventBackend m r s
backend =
  EventBackend
    { newEvent :: forall f. NewEventArgs r s f -> m (Event m r f)
newEvent = forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s
-> forall f. NewEventArgs r s f -> m (Event m r f)
newEvent EventBackend m r s
backend forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {s :: * -> *} {f}. NewEventArgs r s f -> NewEventArgs r s f
transformArgs,
      emitImmediateEvent :: forall f. NewEventArgs r s f -> m r
emitImmediateEvent = forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> forall f. NewEventArgs r s f -> m r
emitImmediateEvent EventBackend m r s
backend forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {s :: * -> *} {f}. NewEventArgs r s f -> NewEventArgs r s f
transformArgs
    }
  where
    transformArgs :: NewEventArgs r s f -> NewEventArgs r s f
transformArgs NewEventArgs r s f
args =
      NewEventArgs r s f
args
        { newEventParent :: Maybe r
newEventParent = forall r (s :: * -> *) f. NewEventArgs r s f -> Maybe r
newEventParent NewEventArgs r s f
args forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure r
parent
        }
setInitialCauseEventBackend :: [r] -> EventBackend m r s -> EventBackend m r s
setInitialCauseEventBackend :: forall r (m :: * -> *) (s :: * -> *).
[r] -> EventBackend m r s -> EventBackend m r s
setInitialCauseEventBackend [r]
causes EventBackend m r s
backend =
  EventBackend
    { newEvent :: forall f. NewEventArgs r s f -> m (Event m r f)
newEvent = forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s
-> forall f. NewEventArgs r s f -> m (Event m r f)
newEvent EventBackend m r s
backend forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {s :: * -> *} {f}. NewEventArgs r s f -> NewEventArgs r s f
transformArgs,
      emitImmediateEvent :: forall f. NewEventArgs r s f -> m r
emitImmediateEvent = forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> forall f. NewEventArgs r s f -> m r
emitImmediateEvent EventBackend m r s
backend forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {s :: * -> *} {f}. NewEventArgs r s f -> NewEventArgs r s f
transformArgs
    }
  where
    transformArgs :: NewEventArgs r s f -> NewEventArgs r s f
transformArgs NewEventArgs r s f
args =
      NewEventArgs r s f
args
        { newEventCauses :: [r]
newEventCauses = case forall r (s :: * -> *) f. NewEventArgs r s f -> [r]
newEventCauses NewEventArgs r s f
args of
            [] -> [r]
causes
            [r]
l -> [r]
l
        }