{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}

-- |
-- Description : Domain-specific language for modifying the behavior of EventBackends
-- Copyright   : Copyright 2022 Shea Levy.
-- License     : Apache-2.0
-- Maintainer  : shea@shealevy.com
--
-- A domain-specific language for modifying the behavior of t'Observe.Event.EventBackend's, needed when
-- the caller can't specify the t'Observe.Event.EventBackend' to use directly.
--
-- = The instrumented capability problem
--
-- A common approach for polymorphic effect management in Haskell is the "capability pattern",
-- where a function polymorphic in some monad @m@ takes as an argument a value also polymorphic
-- in @m@ that can be used to run a constrained set of effects in @m@. One example of such a
-- "capability" type would be t'Observe.Event.EventBackend', which for example enables running
-- 'Observe.Event.newEvent' in whatever @m@ it's instantiated in. These capabilities are often
-- themselves implemented in terms of other capabilities, and are ultimately concretely
-- instantiated in some base monad (typically `IO`, or perhaps t`Control.Monad.ST.ST` for a pure
-- mock) and then @hoist@ed to the application's monadic context (e.g. 'Observe.Event.hoistEventBackend').
--
-- Normally this compose + hoist approach works fine, since any capabilities that are dependencies of the
-- the capability we're hoisting are hidden in its closure. But if a capability depends on an `EventBackend`
-- for instrumentation, closing over it at creation time causes a problem: at the call-site of the various
-- effects enabled by the capability, we have no way to modify the t'Observe.Event.EventBackend' to e.g. be a noop (because
-- we don't need the details of this effect's actions to instrument the calling function effectively) or to
-- have its t'Observe.Event.Event's descend from some current 'Observe.Event.Event'. Thus, the DSL defined
-- in this module: effects which take some polymorphic capability can *also* take an 'EventBackendModifier'
-- and the capability can modify its captured t'Observe.Event.EventBackend' with 'modifyEventBackend' accordingly.
--
-- An alternative would be to have each effect in the capability take an t'Observe.Event.EventBackend' at the call site.
-- This would foreclose @hoist@ing along an arbitrary natural transformation, since the t'Observe.Event.EventBackend' would
-- be in negative position, but constrained @hoist@ing might be possible with @MonadUnliftIO@ or @MonadUnlift@
-- or @MonadBaseControl@ if we share a base monad, or if we implemented t'Observe.Event.EventBackend's in a separate base monad
-- that appears in the type of our capabilities and ensure it's liftable to both our application monad and the
-- capability's base instantiation.
module Observe.Event.BackendModification
  ( EventBackendModifier (..),
    EventBackendModifiers,
    modifyEventBackend,

    -- * Simple EventBackendModifiers
    unmodified,
    silence,
    setAncestor,
    setInitialCause,
  )
where

import Control.Category
import Observe.Event.Backend
import Prelude hiding (id, (.))

-- | Modify an t'Observe.Event.EventBackend', chaging its reference type from @r@ to @r'@
data EventBackendModifier r r' where
  -- | Ignore all instrumentation using the t'Observe.Event.EventBackend'
  Silence :: forall r. EventBackendModifier r ()
  -- | Mark every parentless event as the child of a known t'Observe.Event.Event'.
  SetAncestor ::
    forall r.
    -- | A 'Observe.Event.reference' to the parent t'Observe.Event.Event'.
    r ->
    EventBackendModifier r r
  -- | Mark every causeless event as proximately caused by a known t'Observe.Event.Event'.
  SetInitialCause ::
    forall r.
    -- | A 'Observe.Event.reference' to the causing t'Observe.Event.Event'.
    r ->
    EventBackendModifier r r

-- | A sequence of 'EventBackendModifier's
--
-- The free 'Category' over 'EventBackendModifier'
data EventBackendModifiers r r' where
  Nil :: forall r. EventBackendModifiers r r
  Cons :: forall r r' r''. EventBackendModifier r' r'' -> EventBackendModifiers r r' -> EventBackendModifiers r r''

instance Category EventBackendModifiers where
  id :: forall a. EventBackendModifiers a a
id = forall a. EventBackendModifiers a a
Nil
  EventBackendModifiers b c
Nil . :: forall b c a.
EventBackendModifiers b c
-> EventBackendModifiers a b -> EventBackendModifiers a c
. EventBackendModifiers a b
f = EventBackendModifiers a b
f
  (Cons EventBackendModifier r' c
hd EventBackendModifiers b r'
tl) . EventBackendModifiers a b
f = forall r r' r''.
EventBackendModifier r' r''
-> EventBackendModifiers r r' -> EventBackendModifiers r r''
Cons EventBackendModifier r' c
hd (EventBackendModifiers b r'
tl forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. EventBackendModifiers a b
f)

-- | Modify an t'Observe.Event.EventBackend' according to the given 'EventBackendModifiers'.
--
-- This is a right fold, e.g. @modifyEventBackend (a . b . id) backend@ first
-- modifies @backend@ with @b@ and then modifies the result with @a@.
modifyEventBackend :: Monad m => EventBackendModifiers r r' -> EventBackend m r s -> EventBackend m r' s
modifyEventBackend :: forall (m :: * -> *) r r' (s :: * -> *).
Monad m =>
EventBackendModifiers r r'
-> EventBackend m r s -> EventBackend m r' s
modifyEventBackend EventBackendModifiers r r'
Nil EventBackend m r s
backend = EventBackend m r s
backend
modifyEventBackend (Cons EventBackendModifier r' r'
Silence EventBackendModifiers r r'
_) EventBackend m r s
_ = forall (m :: * -> *) (s :: * -> *).
Applicative m =>
EventBackend m () s
unitEventBackend
modifyEventBackend (Cons (SetAncestor r'
parent) EventBackendModifiers r r'
rest) EventBackend m r s
backend' =
  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 :: 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
failImpl :: Maybe SomeException -> m ()
finalizeImpl :: m ()
addProximateImpl :: r' -> m ()
addParentImpl :: r' -> m ()
addFieldImpl :: f -> m ()
referenceImpl :: 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
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
          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 r'
parent)
                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 r'
parent)
                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
    }
  where
    backend :: EventBackend m r' s
backend = forall (m :: * -> *) r r' (s :: * -> *).
Monad m =>
EventBackendModifiers r r'
-> EventBackend m r s -> EventBackend m r' s
modifyEventBackend EventBackendModifiers r r'
rest EventBackend m r s
backend'
modifyEventBackend (Cons (SetInitialCause r'
proximate) EventBackendModifiers r r'
rest) EventBackend m r s
backend' =
  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
proximateAdded <- forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> m (OnceFlag m)
newOnceFlag EventBackend m r' s
backend
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
          EventImpl
            { addProximateImpl :: r' -> m ()
addProximateImpl = \r'
r -> do
                FlagState
_ <- forall (m :: * -> *). OnceFlag m -> m FlagState
checkAndSet OnceFlag m
proximateAdded
                r' -> m ()
addParentImpl r'
r,
              finalizeImpl :: m ()
finalizeImpl = do
                forall (m :: * -> *). Monad m => OnceFlag m -> m () -> m ()
runOnce OnceFlag m
proximateAdded (r' -> m ()
addProximateImpl r'
proximate)
                m ()
finalizeImpl,
              failImpl :: Maybe SomeException -> m ()
failImpl = \Maybe SomeException
e -> do
                forall (m :: * -> *). Monad m => OnceFlag m -> m () -> m ()
runOnce OnceFlag m
proximateAdded (r' -> m ()
addProximateImpl r'
proximate)
                Maybe SomeException -> m ()
failImpl Maybe SomeException
e,
              r'
r' -> m ()
f -> m ()
addParentImpl :: r' -> m ()
addFieldImpl :: f -> m ()
referenceImpl :: r'
addParentImpl :: 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
    }
  where
    backend :: EventBackend m r' s
backend = forall (m :: * -> *) r r' (s :: * -> *).
Monad m =>
EventBackendModifiers r r'
-> EventBackend m r s -> EventBackend m r' s
modifyEventBackend EventBackendModifiers r r'
rest EventBackend m r s
backend'

-- | A single-element 'EventBackendModifiers'
singleton :: EventBackendModifier r r' -> EventBackendModifiers r r'
singleton :: forall r r'.
EventBackendModifier r r' -> EventBackendModifiers r r'
singleton = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r r' r''.
EventBackendModifier r' r''
-> EventBackendModifiers r r' -> EventBackendModifiers r r''
Cons forall a. EventBackendModifiers a a
Nil

-- | An 'EventBackendModifiers' that does nothing.
unmodified :: EventBackendModifiers r r
unmodified :: forall a. EventBackendModifiers a a
unmodified = forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id

-- | An 'EventBackendModifiers' that silences events.
silence :: EventBackendModifiers r ()
silence :: forall r. EventBackendModifiers r ()
silence = forall r r'.
EventBackendModifier r r' -> EventBackendModifiers r r'
singleton forall r. EventBackendModifier r ()
Silence

-- | An 'EventBackendModifiers' that marks every parentless event as the child
-- of a known t'Observe.Event.Event'.
setAncestor :: r -> EventBackendModifiers r r
setAncestor :: forall r. r -> EventBackendModifiers r r
setAncestor = forall r r'.
EventBackendModifier r r' -> EventBackendModifiers r r'
singleton forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall r. r -> EventBackendModifier r r
SetAncestor

-- | An 'EventBackendModifiers' that marks every causeless event as proximately caused
-- by a known t'Observe.Event.Event'.
setInitialCause :: r -> EventBackendModifiers r r
setInitialCause :: forall r. r -> EventBackendModifiers r r
setInitialCause = forall r r'.
EventBackendModifier r r' -> EventBackendModifiers r r'
singleton forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall r. r -> EventBackendModifier r r
SetInitialCause