{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}

-- |
-- Description : Core interface for instrumentation with eventuo11y
-- Copyright   : Copyright 2022 Shea Levy.
-- License     : Apache-2.0
-- Maintainer  : shea@shealevy.com
--
-- This is the primary module needed to instrument code with eventuo11y.
--
-- Instrumentors should first define selector types and field types
-- appropriate to the unit of code they're instrumenting:
--
-- Selectors are values which designate the general category of event
-- being created, parameterized by the type of fields that can be added to it.
-- For example, a web service's selector type may have a @ServicingRequest@
-- constructor, whose field type includes a @ResponseCode@ constructor which
-- records the HTTP status code. Selectors are intended to be of a domain-specific
-- type per unit of functionality within an instrumented codebase, implemented as a GADT
-- (but see t'Observe.Event.Dynamic.DynamicEventSelector' for a generic option).
--
-- Fields make up the basic data captured in an event. They should be added
-- to an 'Event' as the code progresses through various phases of work, and can
-- be both milestone markers ("we got this far in the process") or more detailed
-- instrumentation ("we've processed N records"). They are intended to be of a
-- domain-specific type per unit of functionality within an instrumented codebase
-- (but see t'Observe.Event.Dynamic.DynamicField' for a generic option).
--
-- Instrumentation then centers around 'Event's, populated using the
-- <#g:eventmanip event manipulation functions>. 'Event's are initialized
-- with 'EventBackend's, typically via the
-- <#g:resourcesafe resource-safe event allocation functions>.
--
-- Depending on which 'EventBackend's may end up consuming the 'Event's,
-- instrumentors will also need to define renderers for their selectors
-- and fields. For example, they may need to implement values of types
--  t'Observe.Event.Render.JSON.RenderSelectorJSON' and
--  t'Observe.Event.Render.JSON.RenderFieldJSON' to use JSON rendering 'EventBackend's.
module Observe.Event
  ( Event,

    -- * Event manipulation #eventmanip#
    reference,
    addField,
    addParent,
    addProximate,

    -- * Resource-safe event allocation #resourcesafe#
    withEvent,
    withSubEvent,

    -- ** Acquire/MonadResource variants
    acquireEvent,
    acquireSubEvent,

    -- * 'EventBackend's
    EventBackend,
    subEventBackend,
    unitEventBackend,
    pairEventBackend,
    hoistEventBackend,
    narrowEventBackend,
    narrowEventBackend',

    -- * Primitive 'Event' resource management.

    -- | Prefer the [resource-safe event allocation functions](#g:resourcesafe)
    -- to these when possible.
    finalize,
    failEvent,
    newEvent,
    newSubEvent,
  )
where

import Control.Exception
import Control.Monad.Catch
import Control.Monad.IO.Unlift
import Data.Acquire
import Data.Functor
import Observe.Event.Implementation

-- | An instrumentation event.
--
-- 'Event's are the core of the instrumenting user's interface
-- to eventuo11y. Typical usage would be to create an 'Event'
-- from an 'EventBackend' with 'withEvent', or as a child of
-- an another 'Event' with 'withSubEvent', and add fields to
-- the 'Event' at appropriate points in your code with
-- 'addField'.
--
-- [@m@]: The monad we're instrumenting in.
-- [@r@]: The type of event references. See 'reference'.
-- [@s@]: The type of event selectors for child events. See 'EventBackend'.
-- [@f@]: The type of fields on this event. See 'addField'.
data Event m r s f = Event
  { -- | The 'EventBackend' this 'Event' was generated from.
    forall (m :: * -> *) r (s :: * -> *) f.
Event m r s f -> EventBackend m r s
backend :: !(EventBackend m r s),
    -- | The underlying 'EventImpl' implementing the event functionality.
    forall (m :: * -> *) r (s :: * -> *) f.
Event m r s f -> EventImpl m r f
impl :: !(EventImpl m r f),
    -- | A 'OnceFlag' to ensure we only finish ('finalize' or 'failEvent') once.
    forall (m :: * -> *) r (s :: * -> *) f. Event m r s f -> OnceFlag m
finishFlag :: !(OnceFlag m)
  }

-- | Obtain a reference to an 'Event'.
--
-- References are used to link 'Event's together, either in
-- parent-child relationships with 'addParent' or in
-- cause-effect relationships with 'addProximate'.
--
-- References can live past when an event has been 'finalize'd or
-- 'failEvent'ed.
--
-- Code being instrumented should always have @r@ as an unconstrained
-- type parameter, both because it is an implementation concern for
-- 'EventBackend's and because references are backend-specific and it
-- would be an error to reference an event in one backend from an event
-- in a different backend.
reference :: Event m r s f -> r
reference :: forall (m :: * -> *) r (s :: * -> *) f. Event m r s f -> r
reference (Event {OnceFlag m
EventImpl m r f
EventBackend m r s
finishFlag :: OnceFlag m
impl :: EventImpl m r f
backend :: EventBackend m r s
finishFlag :: forall (m :: * -> *) r (s :: * -> *) f. Event m r s f -> OnceFlag m
impl :: forall (m :: * -> *) r (s :: * -> *) f.
Event m r s f -> EventImpl m r f
backend :: forall (m :: * -> *) r (s :: * -> *) f.
Event m r s f -> EventBackend m r s
..}) = forall (m :: * -> *) r f. EventImpl m r f -> r
referenceImpl EventImpl m r f
impl

-- | Add a field to an 'Event'.
--
-- Fields make up the basic data captured in an event. They should be added
-- to an 'Event' as the code progresses through various phases of work, and can
-- be both milestone markers ("we got this far in the process") or more detailed
-- instrumentation ("we've processed N records").
--
-- They are intended to be of a domain specific type per unit of functionality
-- within an instrumented codebase (but see t'Observe.Event.Dynamic.DynamicField'
-- for a generic option).
addField ::
  Event m r s f ->
  -- | The field to add to the event.
  f ->
  m ()
addField :: forall (m :: * -> *) r (s :: * -> *) f. Event m r s f -> f -> m ()
addField (Event {OnceFlag m
EventImpl m r f
EventBackend m r s
finishFlag :: OnceFlag m
impl :: EventImpl m r f
backend :: EventBackend m r s
finishFlag :: forall (m :: * -> *) r (s :: * -> *) f. Event m r s f -> OnceFlag m
impl :: forall (m :: * -> *) r (s :: * -> *) f.
Event m r s f -> EventImpl m r f
backend :: forall (m :: * -> *) r (s :: * -> *) f.
Event m r s f -> EventBackend m r s
..}) = forall (m :: * -> *) r f. EventImpl m r f -> f -> m ()
addFieldImpl EventImpl m r f
impl

-- | Mark another 'Event' as a parent of this 'Event'.
addParent ::
  Event m r s f ->
  -- | A reference to the parent, obtained via 'reference'.
  r ->
  m ()
addParent :: forall (m :: * -> *) r (s :: * -> *) f. Event m r s f -> r -> m ()
addParent (Event {OnceFlag m
EventImpl m r f
EventBackend m r s
finishFlag :: OnceFlag m
impl :: EventImpl m r f
backend :: EventBackend m r s
finishFlag :: forall (m :: * -> *) r (s :: * -> *) f. Event m r s f -> OnceFlag m
impl :: forall (m :: * -> *) r (s :: * -> *) f.
Event m r s f -> EventImpl m r f
backend :: forall (m :: * -> *) r (s :: * -> *) f.
Event m r s f -> EventBackend m r s
..}) = forall (m :: * -> *) r f. EventImpl m r f -> r -> m ()
addParentImpl EventImpl m r f
impl

-- | Mark another 'Event' as a proximate cause of this 'Event'.
addProximate ::
  Event m r s f ->
  -- | A reference to the proximate cause, obtained via 'reference'.
  r ->
  m ()
addProximate :: forall (m :: * -> *) r (s :: * -> *) f. Event m r s f -> r -> m ()
addProximate (Event {OnceFlag m
EventImpl m r f
EventBackend m r s
finishFlag :: OnceFlag m
impl :: EventImpl m r f
backend :: EventBackend m r s
finishFlag :: forall (m :: * -> *) r (s :: * -> *) f. Event m r s f -> OnceFlag m
impl :: forall (m :: * -> *) r (s :: * -> *) f.
Event m r s f -> EventImpl m r f
backend :: forall (m :: * -> *) r (s :: * -> *) f.
Event m r s f -> EventBackend m r s
..}) = forall (m :: * -> *) r f. EventImpl m r f -> r -> m ()
addProximateImpl EventImpl m r f
impl

-- | Mark an 'Event' as finished.
--
-- In normal usage, this should be automatically called via the use of
-- the [resource-safe event allocation functions](#g:resourcesafe).
--
-- This is a no-op if the 'Event' has already been 'finalize'd or
-- 'failEvent'ed. As a result, it is likely pointless to call
-- 'addField', 'addParent', or 'addProximate' after this call,
-- though it still may be reasonable to call 'reference'.
finalize :: (Monad m) => Event m r s f -> m ()
finalize :: forall (m :: * -> *) r (s :: * -> *) f.
Monad m =>
Event m r s f -> m ()
finalize (Event {OnceFlag m
EventImpl m r f
EventBackend m r s
finishFlag :: OnceFlag m
impl :: EventImpl m r f
backend :: EventBackend m r s
finishFlag :: forall (m :: * -> *) r (s :: * -> *) f. Event m r s f -> OnceFlag m
impl :: forall (m :: * -> *) r (s :: * -> *) f.
Event m r s f -> EventImpl m r f
backend :: forall (m :: * -> *) r (s :: * -> *) f.
Event m r s f -> EventBackend m r s
..}) = forall (m :: * -> *). Monad m => OnceFlag m -> m () -> m ()
runOnce OnceFlag m
finishFlag forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r f. EventImpl m r f -> m ()
finalizeImpl EventImpl m r f
impl

-- | Mark an 'Event' as having failed, possibly due to an 'Exception'.
--
-- In normal usage, this should be automatically called via the use of
-- the [resource-safe event allocation functions](#g:resourcesafe).
--
-- This is a no-op if the 'Event' has already been 'finalize'd or
-- 'failEvent'ed. As a result, it is likely pointless to call
-- 'addField', 'addParent', or 'addProximate' after this call,
-- though it still may be reasonable to call 'reference'.
failEvent :: (Monad m) => Event m r s f -> Maybe SomeException -> m ()
failEvent :: forall (m :: * -> *) r (s :: * -> *) f.
Monad m =>
Event m r s f -> Maybe SomeException -> m ()
failEvent (Event {OnceFlag m
EventImpl m r f
EventBackend m r s
finishFlag :: OnceFlag m
impl :: EventImpl m r f
backend :: EventBackend m r s
finishFlag :: forall (m :: * -> *) r (s :: * -> *) f. Event m r s f -> OnceFlag m
impl :: forall (m :: * -> *) r (s :: * -> *) f.
Event m r s f -> EventImpl m r f
backend :: forall (m :: * -> *) r (s :: * -> *) f.
Event m r s f -> EventBackend m r s
..}) = forall (m :: * -> *). Monad m => OnceFlag m -> m () -> m ()
runOnce OnceFlag m
finishFlag forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) r f.
EventImpl m r f -> Maybe SomeException -> m ()
failImpl EventImpl m r f
impl

-- | Create a new 'Event', selected by the given selector.
--
-- The selector specifies the category of new event we're creating, as well
-- as the type of fields that can be added to it (with 'addField').
--
-- Selectors are intended to be of a domain specific type per unit of
-- functionality within an instrumented codebase, implemented as a GADT
-- (but see t'Observe.Event.Dynamic.DynamicEventSelector' for a generic option).
--
-- Consider the [resource-safe event allocation functions](#g:resourcesafe) instead
-- of calling this directly.
newEvent ::
  (Applicative m) =>
  EventBackend m r s ->
  forall f.
  -- | The event selector.
  s f ->
  m (Event m r s f)
newEvent :: forall (m :: * -> *) r (s :: * -> *).
Applicative m =>
EventBackend m r s -> forall f. s f -> m (Event m r s f)
newEvent backend :: EventBackend m r s
backend@(EventBackend {m (OnceFlag m)
forall f. s f -> m (EventImpl m r f)
newOnceFlag :: forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> m (OnceFlag m)
newEventImpl :: forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> forall f. s f -> m (EventImpl m r f)
newOnceFlag :: m (OnceFlag m)
newEventImpl :: forall f. s f -> m (EventImpl m r f)
..}) s f
sel = do
  EventImpl m r f
impl <- forall f. s f -> m (EventImpl m r f)
newEventImpl s f
sel
  OnceFlag m
finishFlag <- m (OnceFlag m)
newOnceFlag
  pure Event {OnceFlag m
EventImpl m r f
EventBackend m r s
finishFlag :: OnceFlag m
impl :: EventImpl m r f
backend :: EventBackend m r s
finishFlag :: OnceFlag m
impl :: EventImpl m r f
backend :: EventBackend m r s
..}

-- | Create a new 'Event' as a child of the given 'Event', selected by the given selector.
--
-- The selector specifies the category of new event we're creating, as well
-- as the type of fields that can be added to it (with 'addField').
--
-- Selectors are intended to be of a domain specific type per unit of
-- functionality within an instrumented codebase, implemented as a GADT
-- (but see t'Observe.Event.Dynamic.DynamicEventSelector' for a generic option).
--
-- Consider the [resource-safe event allocation functions](#g:resourcesafe) instead
-- of calling this directly.
newSubEvent ::
  (Monad m) =>
  -- | The parent event.
  Event m r s f ->
  forall f'.
  -- | The child event selector.
  s f' ->
  m (Event m r s f')
newSubEvent :: forall (m :: * -> *) r (s :: * -> *) f.
Monad m =>
Event m r s f -> forall f'. s f' -> m (Event m r s f')
newSubEvent (Event {OnceFlag m
EventImpl m r f
EventBackend m r s
finishFlag :: OnceFlag m
impl :: EventImpl m r f
backend :: EventBackend m r s
finishFlag :: forall (m :: * -> *) r (s :: * -> *) f. Event m r s f -> OnceFlag m
impl :: forall (m :: * -> *) r (s :: * -> *) f.
Event m r s f -> EventImpl m r f
backend :: forall (m :: * -> *) r (s :: * -> *) f.
Event m r s f -> EventBackend m r s
..}) s f'
sel = do
  Event m r s f'
child <- forall (m :: * -> *) r (s :: * -> *).
Applicative m =>
EventBackend m r s -> forall f. s f -> m (Event m r s f)
newEvent EventBackend m r s
backend s f'
sel
  forall (m :: * -> *) r (s :: * -> *) f. Event m r s f -> r -> m ()
addParent Event m r s f'
child forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r f. EventImpl m r f -> r
referenceImpl EventImpl m r f
impl
  pure Event m r s f'
child

-- | Run an action with a new 'Event', selected by the given selector.
--
-- The selector specifies the category of new event we're creating, as well
-- as the type of fields that can be added to it (with 'addField').
--
-- Selectors are intended to be of a domain specific type per unit of
-- functionality within an instrumented codebase, implemented as a GADT
-- (but see t'Observe.Event.Dynamic.DynamicEventSelector' for a generic option).
--
-- The 'Event' is automatically 'finalize'd (or, if appropriate, 'failEvent'ed)
-- at the end of the function it's passed to.
withEvent ::
  (MonadMask m) =>
  EventBackend m r s ->
  forall f.
  -- | The event selector.
  s f ->
  (Event m r s f -> m a) ->
  m a
withEvent :: forall (m :: * -> *) r (s :: * -> *) a.
MonadMask m =>
EventBackend m r s
-> forall f. s f -> (Event m r s f -> m a) -> m a
withEvent EventBackend m r s
backend s f
sel Event m r s f -> m a
go = do
  (a
res, ()) <- forall (m :: * -> *) a b c.
MonadMask m =>
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)
generalBracket (forall (m :: * -> *) r (s :: * -> *).
Applicative m =>
EventBackend m r s -> forall f. s f -> m (Event m r s f)
newEvent EventBackend m r s
backend s f
sel) forall {m :: * -> *} {r} {s :: * -> *} {f} {a}.
Monad m =>
Event m r s f -> ExitCase a -> m ()
release Event m r s f -> m a
go
  forall (f :: * -> *) a. Applicative f => a -> f a
pure a
res
  where
    release :: Event m r s f -> ExitCase a -> m ()
release Event m r s f
ev (ExitCaseSuccess a
_) = forall (m :: * -> *) r (s :: * -> *) f.
Monad m =>
Event m r s f -> m ()
finalize Event m r s f
ev
    release Event m r s f
ev (ExitCaseException SomeException
e) = forall (m :: * -> *) r (s :: * -> *) f.
Monad m =>
Event m r s f -> Maybe SomeException -> m ()
failEvent Event m r s f
ev forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just SomeException
e
    release Event m r s f
ev ExitCase a
ExitCaseAbort = forall (m :: * -> *) r (s :: * -> *) f.
Monad m =>
Event m r s f -> Maybe SomeException -> m ()
failEvent Event m r s f
ev forall a. Maybe a
Nothing

-- | Run an action with a new 'Event' as a child of the given 'Event', selected by the given selector.
--
-- The selector specifies the category of new event we're creating, as well
-- as the type of fields that can be added to it (with 'addField').
--
-- Selectors are intended to be of a domain specific type per unit of
-- functionality within an instrumented codebase, implemented as a GADT
-- (but see t'Observe.Event.Dynamic.DynamicEventSelector' for a generic option).
--
-- The 'Event' is automatically 'finalize'd (or, if appropriate, 'failEvent'ed)
-- at the end of the function it's passed to.
withSubEvent ::
  (MonadMask m) =>
  -- | The parent 'Event'.
  Event m r s f ->
  forall f'.
  -- | The child event selector.
  s f' ->
  (Event m r s f' -> m a) ->
  m a
withSubEvent :: forall (m :: * -> *) r (s :: * -> *) f a.
MonadMask m =>
Event m r s f -> forall f'. s f' -> (Event m r s f' -> m a) -> m a
withSubEvent (Event {OnceFlag m
EventImpl m r f
EventBackend m r s
finishFlag :: OnceFlag m
impl :: EventImpl m r f
backend :: EventBackend m r s
finishFlag :: forall (m :: * -> *) r (s :: * -> *) f. Event m r s f -> OnceFlag m
impl :: forall (m :: * -> *) r (s :: * -> *) f.
Event m r s f -> EventImpl m r f
backend :: forall (m :: * -> *) r (s :: * -> *) f.
Event m r s f -> EventBackend m r s
..}) s f'
sel Event m r s f' -> m a
go = forall (m :: * -> *) r (s :: * -> *) a.
MonadMask m =>
EventBackend m r s
-> forall f. s f -> (Event m r s f -> m a) -> m a
withEvent EventBackend m r s
backend s f'
sel forall a b. (a -> b) -> a -> b
$ \Event m r s f'
child -> do
  forall (m :: * -> *) r (s :: * -> *) f. Event m r s f -> r -> m ()
addParent Event m r s f'
child forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r f. EventImpl m r f -> r
referenceImpl EventImpl m r f
impl
  Event m r s f' -> m a
go Event m r s f'
child

-- | An 'Acquire' variant of 'withEvent', usable in a t'Control.Monad.Trans.Resource.MonadResource' with 'allocateAcquire'.
--
-- Until [snoyberg/conduit#460](https://github.com/snoyberg/conduit/issues/460) is addressed, exception
-- information will not be captured.
acquireEvent ::
  (MonadUnliftIO m) =>
  EventBackend m r s ->
  forall f.
  -- | The event selector.
  s f ->
  m (Acquire (Event m r s f))
acquireEvent :: forall (m :: * -> *) r (s :: * -> *).
MonadUnliftIO m =>
EventBackend m r s -> forall f. s f -> m (Acquire (Event m r s f))
acquireEvent EventBackend m r s
backend s f
sel = forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
runInIO ->
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    forall a. IO a -> (a -> ReleaseType -> IO ()) -> Acquire a
mkAcquireType
      (forall a. m a -> IO a
runInIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r (s :: * -> *).
Applicative m =>
EventBackend m r s -> forall f. s f -> m (Event m r s f)
newEvent EventBackend m r s
backend s f
sel)
      (forall {m :: * -> *} {b} {r} {s :: * -> *} {f}.
Monad m =>
(m () -> b) -> Event m r s f -> ReleaseType -> b
release forall a. m a -> IO a
runInIO)
  where
    release :: (m () -> b) -> Event m r s f -> ReleaseType -> b
release m () -> b
runInIO Event m r s f
ev ReleaseType
ReleaseException = m () -> b
runInIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r (s :: * -> *) f.
Monad m =>
Event m r s f -> Maybe SomeException -> m ()
failEvent Event m r s f
ev forall a. Maybe a
Nothing
    release m () -> b
runInIO Event m r s f
ev ReleaseType
_ = m () -> b
runInIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r (s :: * -> *) f.
Monad m =>
Event m r s f -> m ()
finalize Event m r s f
ev

-- | An 'Acquire' variant of 'withSubEvent', usable in a t'Control.Monad.Trans.Resource.MonadResource' with 'allocateAcquire'.
--
-- Until [snoyberg/conduit#460](https://github.com/snoyberg/conduit/issues/460) is addressed, exception
-- information will not be captured.
acquireSubEvent ::
  (MonadUnliftIO m) =>
  -- | The parent event.
  Event m r s f ->
  forall f'.
  -- | The child event selector.
  s f' ->
  m (Acquire (Event m r s f'))
acquireSubEvent :: forall (m :: * -> *) r (s :: * -> *) f.
MonadUnliftIO m =>
Event m r s f -> forall f'. s f' -> m (Acquire (Event m r s f'))
acquireSubEvent (Event {OnceFlag m
EventImpl m r f
EventBackend m r s
finishFlag :: OnceFlag m
impl :: EventImpl m r f
backend :: EventBackend m r s
finishFlag :: forall (m :: * -> *) r (s :: * -> *) f. Event m r s f -> OnceFlag m
impl :: forall (m :: * -> *) r (s :: * -> *) f.
Event m r s f -> EventImpl m r f
backend :: forall (m :: * -> *) r (s :: * -> *) f.
Event m r s f -> EventBackend m r s
..}) s f'
sel = do
  Acquire (Event m r s f')
childAcq <- forall (m :: * -> *) r (s :: * -> *).
MonadUnliftIO m =>
EventBackend m r s -> forall f. s f -> m (Acquire (Event m r s f))
acquireEvent EventBackend m r s
backend s f'
sel
  forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
runInIO -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ do
    Event m r s f'
child <- Acquire (Event m r s f')
childAcq
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. m a -> IO a
runInIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) r (s :: * -> *) f. Event m r s f -> r -> m ()
addParent Event m r s f'
child forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r f. EventImpl m r f -> r
referenceImpl EventImpl m r f
impl
    pure Event m r s f'
child

-- | An 'EventBackend' where every otherwise parentless event will be marked
-- as a child of the given 'Event'.
subEventBackend ::
  (Monad m) =>
  -- | The parent event.
  Event m r s f ->
  EventBackend m r s
subEventBackend :: forall (m :: * -> *) r (s :: * -> *) f.
Monad m =>
Event m r s f -> EventBackend m r s
subEventBackend ev :: Event m r s f
ev@(Event {OnceFlag m
EventImpl m r f
EventBackend m r s
finishFlag :: OnceFlag m
impl :: EventImpl m r f
backend :: EventBackend m r s
finishFlag :: forall (m :: * -> *) r (s :: * -> *) f. Event m r s f -> OnceFlag m
impl :: forall (m :: * -> *) r (s :: * -> *) f.
Event m r s f -> EventImpl m r f
backend :: forall (m :: * -> *) r (s :: * -> *) f.
Event m r s f -> EventBackend m r s
..}) =
  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
parentAdded <- forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> m (OnceFlag m)
newOnceFlag EventBackend m r s
backend
        pure $
          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 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r (s :: * -> *) f. Event m r s f -> r
reference Event m r s f
ev)
                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 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r (s :: * -> *) f. Event m r s f -> r
reference Event m r s f
ev)
                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
    }

-- | A no-op 'EventBackend'.
--
-- This can be used if calling instrumented code from an un-instrumented
-- context, or to purposefully ignore instrumentation from some call.
--
-- 'unitEventBackend' is the algebraic unit of 'pairEventBackend'.
unitEventBackend :: Applicative m => EventBackend m () s
unitEventBackend :: forall (m :: * -> *) (s :: * -> *).
Applicative m =>
EventBackend m () s
unitEventBackend =
  EventBackend
    { newEventImpl :: forall f. s f -> m (EventImpl m () f)
newEventImpl = \s f
_ ->
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
          EventImpl
            { referenceImpl :: ()
referenceImpl = (),
              addFieldImpl :: f -> m ()
addFieldImpl = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure (),
              addParentImpl :: () -> m ()
addParentImpl = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure (),
              addProximateImpl :: () -> m ()
addProximateImpl = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure (),
              finalizeImpl :: m ()
finalizeImpl = forall (f :: * -> *) a. Applicative f => a -> f a
pure (),
              failImpl :: Maybe SomeException -> m ()
failImpl = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            },
      newOnceFlag :: m (OnceFlag m)
newOnceFlag = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (m :: * -> *). Applicative m => OnceFlag m
alwaysNewOnceFlag
    }

-- | An 'EventBackend' which sequentially generates 'Event's in the two given 'EventBackend's.
--
-- This can be used to emit instrumentation in multiple ways (e.g. logs to grafana and metrics on
-- a prometheus HTML page).
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
    { newEventImpl :: forall f. s f -> m (EventImpl m (a, b) f)
newEventImpl = \s f
sel -> do
        EventImpl m a f
xImpl <- forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> forall f. s f -> m (EventImpl m r f)
newEventImpl EventBackend m a s
x s f
sel
        EventImpl m b f
yImpl <- forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> forall f. s f -> m (EventImpl m r f)
newEventImpl EventBackend m b s
y s f
sel
        pure $
          EventImpl
            { referenceImpl :: (a, b)
referenceImpl = (forall (m :: * -> *) r f. EventImpl m r f -> r
referenceImpl EventImpl m a f
xImpl, forall (m :: * -> *) r f. EventImpl m r f -> r
referenceImpl EventImpl m b f
yImpl),
              addFieldImpl :: f -> m ()
addFieldImpl = \f
f -> forall (m :: * -> *) r f. EventImpl m r f -> f -> m ()
addFieldImpl EventImpl m a f
xImpl f
f forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) r f. EventImpl m r f -> f -> m ()
addFieldImpl EventImpl m b f
yImpl f
f,
              addParentImpl :: (a, b) -> m ()
addParentImpl = \(a
px, b
py) -> forall (m :: * -> *) r f. EventImpl m r f -> r -> m ()
addParentImpl EventImpl m a f
xImpl a
px forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) r f. EventImpl m r f -> r -> m ()
addParentImpl EventImpl m b f
yImpl b
py,
              addProximateImpl :: (a, b) -> m ()
addProximateImpl = \(a
px, b
py) -> forall (m :: * -> *) r f. EventImpl m r f -> r -> m ()
addProximateImpl EventImpl m a f
xImpl a
px forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) r f. EventImpl m r f -> r -> m ()
addProximateImpl EventImpl m b f
yImpl b
py,
              finalizeImpl :: m ()
finalizeImpl = forall (m :: * -> *) r f. EventImpl m r f -> m ()
finalizeImpl EventImpl m a f
xImpl forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) r f. EventImpl m r f -> m ()
finalizeImpl EventImpl m b f
yImpl,
              failImpl :: Maybe SomeException -> m ()
failImpl = \Maybe SomeException
e -> forall (m :: * -> *) r f.
EventImpl m r f -> Maybe SomeException -> m ()
failImpl EventImpl m a f
xImpl Maybe SomeException
e forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) r f.
EventImpl m r f -> Maybe SomeException -> m ()
failImpl EventImpl m b f
yImpl Maybe SomeException
e
            },
      newOnceFlag :: m (OnceFlag m)
newOnceFlag = do
        OnceFlag m
xOnce <- forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> m (OnceFlag m)
newOnceFlag EventBackend m a s
x
        OnceFlag m
yOnce <- forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> m (OnceFlag m)
newOnceFlag EventBackend m b s
y
        pure $
          forall (m :: * -> *). m FlagState -> OnceFlag m
OnceFlag forall a b. (a -> b) -> a -> b
$ do
            FlagState
xSet <- forall (m :: * -> *). OnceFlag m -> m FlagState
checkAndSet OnceFlag m
xOnce
            FlagState
ySet <- forall (m :: * -> *). OnceFlag m -> m FlagState
checkAndSet OnceFlag m
yOnce
            pure $ case (FlagState
xSet, FlagState
ySet) of
              (FlagState
NewlySet, FlagState
NewlySet) -> FlagState
NewlySet
              (FlagState, FlagState)
_ -> FlagState
AlreadySet
    }

-- | Hoist an 'EventBackend' along a given natural transformation into a new monad.
hoistEventBackend ::
  (Functor m, Functor n) =>
  -- | Natural transformation from @m@ to @n@.
  (forall x. m x -> n x) ->
  EventBackend m r s ->
  EventBackend n r s
hoistEventBackend :: forall (m :: * -> *) (n :: * -> *) r (s :: * -> *).
(Functor m, Functor n) =>
(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
    { newEventImpl :: forall f. s f -> n (EventImpl n r f)
newEventImpl = 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 {r} {f}. EventImpl m r f -> EventImpl n r f
hoistEventImpl forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> forall f. s f -> m (EventImpl m r f)
newEventImpl EventBackend m r s
backend,
      newOnceFlag :: n (OnceFlag n)
newOnceFlag = forall (f :: * -> *) (g :: * -> *).
(forall x. f x -> g x) -> OnceFlag f -> OnceFlag g
hoistOnceFlag forall x. m x -> n x
nt forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall x. m x -> n x
nt forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> m (OnceFlag m)
newOnceFlag EventBackend m r s
backend)
    }
  where
    hoistEventImpl :: EventImpl m r f -> EventImpl n r f
hoistEventImpl (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
..}) =
      EventImpl
        { r
referenceImpl :: r
referenceImpl :: r
referenceImpl,
          addFieldImpl :: f -> n ()
addFieldImpl = forall x. m x -> n x
nt forall b c a. (b -> c) -> (a -> b) -> a -> c
. f -> m ()
addFieldImpl,
          addParentImpl :: r -> n ()
addParentImpl = forall x. m x -> n x
nt forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> m ()
addParentImpl,
          addProximateImpl :: r -> n ()
addProximateImpl = forall x. m x -> n x
nt forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> m ()
addProximateImpl,
          finalizeImpl :: n ()
finalizeImpl = forall x. m x -> n x
nt forall a b. (a -> b) -> a -> b
$ m ()
finalizeImpl,
          failImpl :: Maybe SomeException -> n ()
failImpl = forall x. m x -> n x
nt forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe SomeException -> m ()
failImpl
        }

-- | Narrow an 'EventBackend' to a new selector type via a given injection function.
--
-- A typical usage, where component A calls component B, would be to have A's selector
-- type have a constructor to take any value of B's selector type (and preserve the field)
-- and then call 'narrowEventBackend' with that constructor when invoking functions in B.
--
-- See 'narrowEventBackend'' for a more general, if unweildy, variant.
narrowEventBackend ::
  (Functor m) =>
  -- | Inject a narrow selector into the wider selector type.
  (forall f. s f -> t f) ->
  EventBackend m r t ->
  EventBackend m r s
narrowEventBackend :: forall (m :: * -> *) (s :: * -> *) (t :: * -> *) r.
Functor m =>
(forall f. s f -> t f) -> EventBackend m r t -> EventBackend m r s
narrowEventBackend forall f. s f -> t f
inj =
  forall (m :: * -> *) (s :: * -> *) (t :: * -> *) r.
Functor m =>
(forall f. s f -> forall a. (forall g. t g -> (f -> g) -> a) -> a)
-> EventBackend m r t -> EventBackend m r s
narrowEventBackend'
    (\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)

-- | Narrow an 'EventBackend' to a new selector type via a given injection function.
--
-- See 'narrowEventBackend' for a simpler, if less general, variant.
narrowEventBackend' ::
  (Functor m) =>
  -- | Simultaneously inject a narrow selector into the wider selector type
  -- and the narrow selector's field into the wider selector's field type.
  (forall f. s f -> forall a. (forall g. t g -> (f -> g) -> a) -> a) ->
  EventBackend m r t ->
  EventBackend m r s
narrowEventBackend' :: forall (m :: * -> *) (s :: * -> *) (t :: * -> *) r.
Functor m =>
(forall f. s f -> forall a. (forall g. t g -> (f -> g) -> a) -> a)
-> EventBackend m r t -> EventBackend m r s
narrowEventBackend' forall f. s f -> forall a. (forall g. t g -> (f -> g) -> a) -> a
inj EventBackend m r t
backend =
  EventBackend
    { newEventImpl :: forall f. s f -> m (EventImpl m r f)
newEventImpl = \s f
sel -> forall f. s f -> forall a. (forall g. t g -> (f -> g) -> a) -> a
inj s f
sel \t g
sel' f -> g
injField ->
        forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> forall f. s f -> m (EventImpl m r f)
newEventImpl EventBackend m r t
backend t g
sel' forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
          EventImpl {r
m ()
r -> m ()
g -> m ()
Maybe SomeException -> m ()
failImpl :: Maybe SomeException -> m ()
finalizeImpl :: m ()
addProximateImpl :: r -> m ()
addParentImpl :: r -> m ()
addFieldImpl :: g -> 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
..} ->
            EventImpl
              { addFieldImpl :: f -> m ()
addFieldImpl = g -> m ()
addFieldImpl forall b c a. (b -> c) -> (a -> b) -> a -> c
. f -> g
injField,
                r
m ()
r -> m ()
Maybe SomeException -> m ()
failImpl :: Maybe SomeException -> m ()
finalizeImpl :: m ()
addProximateImpl :: r -> m ()
addParentImpl :: r -> m ()
referenceImpl :: r
failImpl :: Maybe SomeException -> m ()
finalizeImpl :: m ()
addProximateImpl :: r -> m ()
addParentImpl :: r -> m ()
referenceImpl :: r
..
              },
      newOnceFlag :: m (OnceFlag m)
newOnceFlag = forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> m (OnceFlag m)
newOnceFlag EventBackend m r t
backend
    }