-- Copyright 2024 Shea Levy
--
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
-- You may obtain a copy of the License at
--
--     http://www.apache.org/licenses/LICENSE-2.0
--
-- Unless required by applicable law or agreed to in writing, software
-- distributed under the License is distributed on an "AS IS" BASIS,
-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-- See the License for the specific language governing permissions and
-- limitations under the License.
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UnicodeSyntax #-}

{- |
Description : Event-oriented instrumentation
Copyright   : Copyright 2024 Shea Levy.
License     : Apache-2.0
Maintainer  : shea@shealevy.com

This is the primary module needed to instrument code with @e11y@.

To /consume/ instrumentation, see "Observe.Event.Backend".
-}
module Observe.Event
  ( -- * Selectors and fields #selectorAndField#

    -- | Instrumentors should first define selector and field types appropriate
    -- to the unit of code they're instrumenting:
    --
    -- Selectors are values which designate the general category of event
    -- being [created](#g:init), 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.
    --
    -- Fields make up the basic data captured in an event. They should be added
    -- to an 'Event' (with 'addEventField') 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.
    SubSelector
  , NoEventsSelector

    -- ** Selector rendering

    -- | 'EventBackend's will typically require the user to provide a "rendering function"
    -- to translate 'Event'-based instrumentation into the format required for the backend.
    -- The full type of this will depend on the backend in question, but it will typically
    -- involve a function of the form @Selectors selector field -> T field@ for some @T@
    -- (perhaps a function type taking further arguments). The 'Selectors' type is not
    -- the simplest to work with, but in most cases the 'selectorRendering' function can
    -- be used to write your renderer.
    --
    -- Consider the following selector tree:
    --
    -- > module Parent where
    -- >
    -- > import Child
    -- >
    -- > data ParentSelector field where
    -- >   ParentA :: ParentSelector AField
    -- >   ParentB :: ParentSelector BField
    -- >
    -- > data AField = AField Int
    -- > type instance SubSelector AField = NoEventsSelector
    -- >
    -- > data BField = BYes | BNo
    -- > type instance SubSelector BField = ChildSelector
    --
    -- > module Child where
    -- >
    -- > data ChildSelector field where
    -- >   Child :: ChildSelector CField
    -- >
    -- > data CField = CField
    -- > type instance SubSelector CField = NoEventsSelector
    --
    -- You could write renderers for these as follows:
    --
    -- > module Parent where -- Or it could be in a separate module if you want to keep instrumentation and rendering apart
    -- >
    -- > renderParentSelector :: Selectors ParentSelector field -> Identity field -- Obviously in a real case it wouldn't be Identity
    -- > renderParentSelector = selectorRendering $ \case
    -- >   ParentA -> noSubEventsSelectorRendering (Identity $ AField 0)
    -- >   ParentB -> SelectorRendering
    -- >     { renderTopSelector = Identity BYes
    -- >     , renderSubSelector = renderChildSelector -- You could also modify the T CField after calling the child renderer
    -- >     }
    --
    -- > module Child where
    -- >
    -- > renderChildSelector :: Selectors ChildSelector field -> Identity field
    -- > renderChildSelector = selectorRendering $ \Child ->
    -- >   noSubEventsSelectorRendering $ Identity CField
  , selectorRendering
  , SelectorRendering (..)
  , noSubEventsSelectorRendering
  , Selectors (..)

    -- * Event initialization #init#

    -- | Actual instrumentation centers around t'Event's, which can
    -- be initialized in the appropriate [computational contexts](#g:contexts)
    -- given an appropriate [selector](#g:selectorAndField) value.
  , withEvent
  , instantEvent
  , Event

    -- ** Event relationships #relationships#

    -- | 'Event's can be related to each other in two ways: An 'Event' can have
    -- another 'Event' as a parent, and an 'Event' can have any number of other
    -- 'Event's as proximate causes.
    --
    -- In normal usage, these relationships are handled for you: 'withEvent'
    -- automatically marks new 'Event's created in the scope of the 'Event'
    -- as children.
    --
    -- If you need to specify more complex relationships, you can get a reference
    -- to an 'Event' using 'eventReference'. References are monad-independent data
    -- that can outlive the 'Event' itself, and are used to tell an 'EventBackend'
    -- which other 'Event's are involved in a new one.
  , eventReference
  , withRelatedEvent
  , allocateRelatedEvent
  , instantRelatedEvent

    -- ** 'Event'-supporting computational contexts #contexts#
  , HasEvents
  , HasEvent
  , HasEventIn
  , HasSubEvents

    -- ** Lower-level 'Event' allocation management
  , SubEventBackend (..)
  , allocateEventArgs
  , instantEventArgs

    -- * Event manipulation
  , addEventField
  , finalizeEvent
  )
where

import Control.Applicative
import Control.Exception
import Control.Monad.With
import Data.Coerce
import Data.Exceptable
import Data.Functor.Parametric
import Data.GeneralAllocate
import Data.Kind
import Observe.Event.Backend

-- * Event initialization #initialization#

{- | Run a computation during an 'Event' selected by the [selector](#g:selectorAndField).

Parentless 'Event's created during the computation will be marked as children of the
new 'Event'.

The 'Event' will be 'finalize'd at the end of the computation.

See 'withRelatedEvent' if you need to specify [relationships](#g:relationships).
-}
withEvent
  ∷ (HasEvents m backend selector, MonadWithExceptable m)
  ⇒ selector field
  -- ^ The event [selector](#g:selectorAndField)
  → ((HasSubEvents m backend field) ⇒ m a)
  -- ^ The eventful computation
  → m a
withEvent :: forall (m :: * -> *) backend (selector :: * -> *) field a.
(HasEvents m backend selector, MonadWithExceptable m) =>
selector field -> (HasSubEvents m backend field => m a) -> m a
withEvent selector field
selector = selector field
-> Maybe (EventReference (BackendEvent backend))
-> [EventReference (BackendEvent backend)]
-> ((((?e11yEvent::BackendEvent backend field,
       Event (BackendEvent backend)),
      EventIn m (BackendEvent backend)),
     ?e11yBackend::SubEventBackend backend field) =>
    m a)
-> m a
forall (m :: * -> *) backend (selector :: * -> *) field a.
(HasEvents m backend selector, MonadWithExceptable m) =>
selector field
-> Maybe (EventReference (BackendEvent backend))
-> [EventReference (BackendEvent backend)]
-> (HasSubEvents m backend field => m a)
-> m a
withRelatedEvent selector field
selector Maybe (EventReference (BackendEvent backend))
forall a. Maybe a
Nothing []

{- | Emit an instantaneous 'Event' with the given [selector and fields](#g:selectorAndField).

See 'instantRelatedEvent' if you need to specify [relationships](#g:relationships).
-}
instantEvent
  ∷ (HasEvents m backend selector)
  ⇒ selector field
  -- ^ The event [selector](#g:selectorAndField)
  → [field]
  -- ^ The [fields](#g:selectorAndField) of the event.
  → m (EventReference (BackendEvent backend))
instantEvent :: forall (m :: * -> *) backend (selector :: * -> *) field.
HasEvents m backend selector =>
selector field
-> [field] -> m (EventReference (BackendEvent backend))
instantEvent selector field
selector [field]
fields = selector field
-> [field]
-> Maybe (EventReference (BackendEvent backend))
-> [EventReference (BackendEvent backend)]
-> m (EventReference (BackendEvent backend))
forall (m :: * -> *) backend (selector :: * -> *) field.
HasEvents m backend selector =>
selector field
-> [field]
-> Maybe (EventReference (BackendEvent backend))
-> [EventReference (BackendEvent backend)]
-> m (EventReference (BackendEvent backend))
instantRelatedEvent selector field
selector [field]
fields Maybe (EventReference (BackendEvent backend))
forall a. Maybe a
Nothing []

{- | Emit an instantaneous 'Event' with the given [selector and fields](#g:selectorAndField)
and the given [parent and causes](#g:relationships).

See 'instantEvent' if you don't need to specify any relationships.

See 'instantEventArgs' for full control over 'Event' configuration.
-}
instantRelatedEvent
  ∷ (HasEvents m backend selector)
  ⇒ selector field
  -- ^ The event [selector](#g:selectorAndField)
  → [field]
  -- ^ The [fields](#g:selectorAndField) of the event.
  → Maybe (EventReference (BackendEvent backend))
  -- ^ The [parent](#g:relationships) of this event
  → [EventReference (BackendEvent backend)]
  -- ^ The [causes](#g:relationships) of this event
  → m (EventReference (BackendEvent backend))
instantRelatedEvent :: forall (m :: * -> *) backend (selector :: * -> *) field.
HasEvents m backend selector =>
selector field
-> [field]
-> Maybe (EventReference (BackendEvent backend))
-> [EventReference (BackendEvent backend)]
-> m (EventReference (BackendEvent backend))
instantRelatedEvent selector field
selector [field]
initialFields Maybe (EventReference (BackendEvent backend))
parent [EventReference (BackendEvent backend)]
causes =
  EventParams selector field (EventReference (BackendEvent backend))
-> m (EventReference (BackendEvent backend))
forall (m :: * -> *) backend (selector :: * -> *) field.
HasEvents m backend selector =>
EventParams selector field (EventReference (BackendEvent backend))
-> m (EventReference (BackendEvent backend))
instantEventArgs (EventParams selector field (EventReference (BackendEvent backend))
 -> m (EventReference (BackendEvent backend)))
-> EventParams
     selector field (EventReference (BackendEvent backend))
-> m (EventReference (BackendEvent backend))
forall a b. (a -> b) -> a -> b
$
    EventParams
      { selectors :: Selectors selector field
selectors = selector field -> Selectors selector field
forall (selector :: * -> *) field.
selector field -> Selectors selector field
Leaf selector field
selector
      , Maybe (EventReference (BackendEvent backend))
parent :: Maybe (EventReference (BackendEvent backend))
parent :: Maybe (EventReference (BackendEvent backend))
parent
      , [EventReference (BackendEvent backend)]
causes :: [EventReference (BackendEvent backend)]
causes :: [EventReference (BackendEvent backend)]
causes
      , [field]
initialFields :: [field]
initialFields :: [field]
initialFields
      }

{- | Emit an instantaneous 'Event' described by t'EventParams'

You probably want 'instantEvent' or 'instantRelatedEvent'
-}
instantEventArgs
  ∷ (HasEvents m backend selector)
  ⇒ EventParams selector field (EventReference (BackendEvent backend))
  → m (EventReference (BackendEvent backend))
instantEventArgs :: forall (m :: * -> *) backend (selector :: * -> *) field.
HasEvents m backend selector =>
EventParams selector field (EventReference (BackendEvent backend))
-> m (EventReference (BackendEvent backend))
instantEventArgs = backend
-> EventParams
     (RootSelector backend)
     field
     (EventReference (BackendEvent backend))
-> m (EventReference (BackendEvent backend))
forall field.
backend
-> EventParams
     (RootSelector backend)
     field
     (EventReference (BackendEvent backend))
-> m (EventReference (BackendEvent backend))
forall (m :: * -> *) backend field.
EventBackendIn m backend =>
backend
-> EventParams
     (RootSelector backend)
     field
     (EventReference (BackendEvent backend))
-> m (EventReference (BackendEvent backend))
newInstantEvent backend
?e11yBackend::backend
?e11yBackend

{- | Run a computation during an 'Event' selected by the [selector](#g:selectorAndField) and with the given [parent and causes](#g:relationships).

Parentless 'Event's created during the computation will be marked as children of the
new 'Event'.

The 'Event' will be 'finalize'd at the end of the computation.

See 'withEvent' if you don't need to specify any relationships.

For a more flexible allocation, see 'allocateRelatedEvent'.
-}
withRelatedEvent
  ∷ (HasEvents m backend selector, MonadWithExceptable m)
  ⇒ selector field
  -- ^ The event [selector](#g:selectorAndField)
  → Maybe (EventReference (BackendEvent backend))
  -- ^ The [parent](#g:relationships) of this event
  → [EventReference (BackendEvent backend)]
  -- ^ The [causes](#g:relationships) of this event
  → ((HasSubEvents m backend field) ⇒ m a)
  -- ^ The eventful computation
  → m a
withRelatedEvent :: forall (m :: * -> *) backend (selector :: * -> *) field a.
(HasEvents m backend selector, MonadWithExceptable m) =>
selector field
-> Maybe (EventReference (BackendEvent backend))
-> [EventReference (BackendEvent backend)]
-> (HasSubEvents m backend field => m a)
-> m a
withRelatedEvent selector field
selector Maybe (EventReference (BackendEvent backend))
parent [EventReference (BackendEvent backend)]
causes HasSubEvents m backend field => m a
go = With m a (BackendEvent backend field)
-> (BackendEvent backend field -> m a) -> m a
forall (m :: * -> *) b a.
MonadWith m =>
With m b a -> (a -> m b) -> m b
generalWith (selector field
-> Maybe (EventReference (BackendEvent backend))
-> [EventReference (BackendEvent backend)]
-> With m a (BackendEvent backend field)
forall (m :: * -> *) backend (selector :: * -> *) e field
       releaseArg.
(HasEvents m backend selector, Exceptable e) =>
selector field
-> Maybe (EventReference (BackendEvent backend))
-> [EventReference (BackendEvent backend)]
-> GeneralAllocate m e () releaseArg (BackendEvent backend field)
allocateRelatedEvent selector field
selector Maybe (EventReference (BackendEvent backend))
parent [EventReference (BackendEvent backend)]
causes) ((BackendEvent backend field -> m a) -> m a)
-> (BackendEvent backend field -> m a) -> m a
forall a b. (a -> b) -> a -> b
$
  \BackendEvent backend field
ev →
    let
      ?e11yEvent = ?e11yEvent::BackendEvent backend field
BackendEvent backend field
ev
      ?e11yBackend = RootSelector backend field
-> backend
-> EventReference (BackendEvent backend)
-> SubEventBackend backend field
forall backend field.
RootSelector backend field
-> backend
-> EventReference (BackendEvent backend)
-> SubEventBackend backend field
SubEventBackend selector field
RootSelector backend field
selector backend
?e11yBackend::backend
?e11yBackend (EventReference (BackendEvent backend)
 -> SubEventBackend backend field)
-> EventReference (BackendEvent backend)
-> SubEventBackend backend field
forall a b. (a -> b) -> a -> b
$ BackendEvent backend field -> EventReference (BackendEvent backend)
forall field.
BackendEvent backend field -> EventReference (BackendEvent backend)
forall (event :: * -> *) field.
Event event =>
event field -> EventReference event
reference BackendEvent backend field
ev
     in
      m a
HasSubEvents m backend field => m a
go

{- | A t'GeneralAllocate'-ion of a new 'Event', selected by the [selector](#g:selectorAndField)
and with the given [parent and causes](#g:relationships).

The 'Event' with be 'finalize'd upon release.

See 'allocateEventArgs' for full flexibility in specifying allocation.

You will likely want to construct a t'SubEventBackend' to create a
'HasSubEvents' context when using this 'Event'.
-}
allocateRelatedEvent
  ∷ (HasEvents m backend selector, Exceptable e)
  ⇒ selector field
  -- ^ The event [selector](#g:selectorAndField)
  → Maybe (EventReference (BackendEvent backend))
  -- ^ The [parent](#g:relationships) of this event
  → [EventReference (BackendEvent backend)]
  -- ^ The [causes](#g:relationships) of this event
  → GeneralAllocate m e () releaseArg (BackendEvent backend field)
allocateRelatedEvent :: forall (m :: * -> *) backend (selector :: * -> *) e field
       releaseArg.
(HasEvents m backend selector, Exceptable e) =>
selector field
-> Maybe (EventReference (BackendEvent backend))
-> [EventReference (BackendEvent backend)]
-> GeneralAllocate m e () releaseArg (BackendEvent backend field)
allocateRelatedEvent selector field
selector Maybe (EventReference (BackendEvent backend))
parent [EventReference (BackendEvent backend)]
causes =
  EventParams selector field (EventReference (BackendEvent backend))
-> GeneralAllocate m e () releaseArg (BackendEvent backend field)
forall (m :: * -> *) backend (selector :: * -> *) e field
       releaseArg.
(HasEvents m backend selector, Exceptable e) =>
EventParams selector field (EventReference (BackendEvent backend))
-> GeneralAllocate m e () releaseArg (BackendEvent backend field)
allocateEventArgs (EventParams selector field (EventReference (BackendEvent backend))
 -> GeneralAllocate m e () releaseArg (BackendEvent backend field))
-> EventParams
     selector field (EventReference (BackendEvent backend))
-> GeneralAllocate m e () releaseArg (BackendEvent backend field)
forall a b. (a -> b) -> a -> b
$
    EventParams
      { selectors :: Selectors selector field
selectors = selector field -> Selectors selector field
forall (selector :: * -> *) field.
selector field -> Selectors selector field
Leaf selector field
selector
      , [EventReference (BackendEvent backend)]
causes :: [EventReference (BackendEvent backend)]
causes :: [EventReference (BackendEvent backend)]
causes
      , Maybe (EventReference (BackendEvent backend))
parent :: Maybe (EventReference (BackendEvent backend))
parent :: Maybe (EventReference (BackendEvent backend))
parent
      , initialFields :: [field]
initialFields = []
      }

-- | Get a [reference](#g:relationships) to the current 'Event'.
eventReference ∷ (HasEvent event field) ⇒ EventReference event
eventReference :: forall (event :: * -> *) field.
HasEvent event field =>
EventReference event
eventReference = event field -> EventReference event
forall field. event field -> EventReference event
forall (event :: * -> *) field.
Event event =>
event field -> EventReference event
reference event field
?e11yEvent::event field
?e11yEvent

{- | A t'GeneralAllocate'-ion of a new 'Event' described by t'EventParams'

The 'Event' with be 'finalize'd upon release.

You probably want 'allocateRelatedEvent'.

You will likely want to construct a t'SubEventBackend' to construct a 'HasSubEvents'
context when using this 'Event'.
-}
allocateEventArgs
  ∷ (HasEvents m backend selector, Exceptable e)
  ⇒ EventParams selector field (EventReference (BackendEvent backend))
  -- ^ Specify the event, matching the appropriate [selector](Observe-Event.html#g:selectorAndField)
  -- type for this 'EventBackend'.
  → GeneralAllocate m e () releaseArg (BackendEvent backend field)
allocateEventArgs :: forall (m :: * -> *) backend (selector :: * -> *) e field
       releaseArg.
(HasEvents m backend selector, Exceptable e) =>
EventParams selector field (EventReference (BackendEvent backend))
-> GeneralAllocate m e () releaseArg (BackendEvent backend field)
allocateEventArgs EventParams selector field (EventReference (BackendEvent backend))
params = ((forall x. m x -> m x)
 -> m (GeneralAllocated
         m e () releaseArg (BackendEvent backend field)))
-> GeneralAllocate m e () releaseArg (BackendEvent backend field)
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 x. m x -> m x)
  -> m (GeneralAllocated
          m e () releaseArg (BackendEvent backend field)))
 -> GeneralAllocate m e () releaseArg (BackendEvent backend field))
-> ((forall x. m x -> m x)
    -> m (GeneralAllocated
            m e () releaseArg (BackendEvent backend field)))
-> GeneralAllocate m e () releaseArg (BackendEvent backend field)
forall a b. (a -> b) -> a -> b
$ \forall x. m x -> m x
unmask → do
  BackendEvent backend field
ev ← m (BackendEvent backend field) -> m (BackendEvent backend field)
forall x. m x -> m x
unmask (m (BackendEvent backend field) -> m (BackendEvent backend field))
-> m (BackendEvent backend field) -> m (BackendEvent backend field)
forall a b. (a -> b) -> a -> b
$ backend
-> EventParams
     (RootSelector backend)
     field
     (EventReference (BackendEvent backend))
-> m (BackendEvent backend field)
forall field.
backend
-> EventParams
     (RootSelector backend)
     field
     (EventReference (BackendEvent backend))
-> m (BackendEvent backend field)
forall (m :: * -> *) backend field.
EventBackendIn m backend =>
backend
-> EventParams
     (RootSelector backend)
     field
     (EventReference (BackendEvent backend))
-> m (BackendEvent backend field)
newEvent backend
?e11yBackend::backend
?e11yBackend EventParams selector field (EventReference (BackendEvent backend))
EventParams
  (RootSelector backend)
  field
  (EventReference (BackendEvent backend))
params
  let release :: GeneralReleaseType e releaseArg -> m ()
release (ReleaseFailure e
e) = BackendEvent backend field -> Maybe SomeException -> m ()
forall field.
BackendEvent backend field -> Maybe SomeException -> m ()
forall (m :: * -> *) (event :: * -> *) field.
EventIn m event =>
event field -> Maybe SomeException -> m ()
finalize BackendEvent backend field
ev (Maybe SomeException -> m ())
-> (SomeException -> Maybe SomeException) -> SomeException -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just (SomeException -> m ()) -> SomeException -> m ()
forall a b. (a -> b) -> a -> b
$ e -> SomeException
forall e. Exceptable e => e -> SomeException
toSomeException e
e
      release (ReleaseSuccess releaseArg
_) = BackendEvent backend field -> Maybe SomeException -> m ()
forall field.
BackendEvent backend field -> Maybe SomeException -> m ()
forall (m :: * -> *) (event :: * -> *) field.
EventIn m event =>
event field -> Maybe SomeException -> m ()
finalize BackendEvent backend field
ev Maybe SomeException
forall a. Maybe a
Nothing
  GeneralAllocated m e () releaseArg (BackendEvent backend field)
-> m (GeneralAllocated
        m e () releaseArg (BackendEvent backend field))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GeneralAllocated m e () releaseArg (BackendEvent backend field)
 -> m (GeneralAllocated
         m e () releaseArg (BackendEvent backend field)))
-> GeneralAllocated m e () releaseArg (BackendEvent backend field)
-> m (GeneralAllocated
        m e () releaseArg (BackendEvent backend field))
forall a b. (a -> b) -> a -> b
$ BackendEvent backend field
-> (GeneralReleaseType e releaseArg -> m ())
-> GeneralAllocated m e () releaseArg (BackendEvent backend field)
forall (m :: * -> *) e releaseReturn releaseArg a.
a
-> (GeneralReleaseType e releaseArg -> m releaseReturn)
-> GeneralAllocated m e releaseReturn releaseArg a
GeneralAllocated BackendEvent backend field
ev GeneralReleaseType e releaseArg -> m ()
release

{- | End the running 'Event' manually, perhaps due to an exception.

It is implementation-specific whether 'addEventField' after 'finalizeEvent'
has any effect (but it is not an error).

Subsequent 'finalize'ations, including those that result from leaving the
'withEvent' scope or releasing the 'allocateEventArgs' allocation, will be
no-ops.
-}
finalizeEvent
  ∷ (HasEventIn m event field)
  ⇒ Maybe SomeException
  → m ()
finalizeEvent :: forall (m :: * -> *) (event :: * -> *) field.
HasEventIn m event field =>
Maybe SomeException -> m ()
finalizeEvent = event field -> Maybe SomeException -> m ()
forall field. event field -> Maybe SomeException -> m ()
forall (m :: * -> *) (event :: * -> *) field.
EventIn m event =>
event field -> Maybe SomeException -> m ()
finalize event field
?e11yEvent::event field
?e11yEvent

{- | A computational context supporting creating 'Event's from a given [selector](#g:selectorAndField) family.

In typical usage, @backend@ will be kept as a type parameter, to be determined
at the call site by the dynamically-scoped @?e11yBackend@ parameter.

'HasEvents' can be satisfied by binding the @?e11yBackend@ [implicit parameter](https://downloads.haskell.org/ghc/latest/docs/users_guide/exts/implicit_parameters.html)
to an appropriate value. v'Data.Proxy.Proxy' @selector@ can be used as a no-op 'EventBackend', and a pair of backends with the same 'RootSelector' can be used as a backend as well.
-}
type HasEvents m backend selector = (?e11yBackend ∷ backend, EventBackendIn m backend, selector ~ RootSelector backend)

{- | A scope containing an event of the given @field@ type.

In typical usage, @event@ will be kept as a type parameter,
to be determined at the call site by the dynamically-scoped @?e11yEvent@ parameter.

'HasEvent' can be satisfied by binding the @?e11yEvent@ [implicit parameter](https://downloads.haskell.org/ghc/latest/docs/users_guide/exts/implicit_parameters.html)
to an appropriate value. 'withEvent' handles this for you.
-}
type HasEvent event field = (?e11yEvent ∷ event field, Event event)

{- | A computational context occurring during an event of the given @field@ type.

In typical usage, @event@ will be kept as a type parameter,
to be determined at the call site by the dynamically-scoped @?e11yEvent@ parameter.

'HasEventIn' can be satisfied by binding the @?e11yEvent@ [implicit parameter](https://downloads.haskell.org/ghc/latest/docs/users_guide/exts/implicit_parameters.html)
to an appropriate value. 'withEvent' handles this for you.
-}
type HasEventIn m event field = (HasEvent event field, EventIn m event)

{- | A computational context occurring during an event of the given @field@ type, allowing
the creation of new 'Event's according to its 'SubSelector' which are children of the given
event.

In typical usage, @backend@ will be kept as a type parameter,
to be determined at the call site by the dynamically-scoped @?e11yBackend@ parameter.

'HasSubEvents' can be satisfied by binding the @?e11yEvent@ and @?e11yBackend@ [implicit parameters](https://downloads.haskell.org/ghc/latest/docs/users_guide/exts/implicit_parameters.html)
to appropriate values, the latter via v'SubEventBackend'. 'withEvent' handles this for you.
-}
type HasSubEvents m backend field = (HasEventIn m (BackendEvent backend) field, ?e11yBackend ∷ SubEventBackend backend field)

{- | A selector type with no values.

This results in an 'EventBackend' which cannot create
any 'Event's, which is useful to terminate the tree of
event types generated by 'SubSelector'
-}
type NoEventsSelector ∷ Type → Type
data NoEventsSelector f

-- | Generate a rendering function from a t'SelectorRendering' for each top-level selector.
selectorRendering
  ∷ (∀ field. selector field → SelectorRendering t field)
  → ∀ field
   . Selectors selector field
  → t field
selectorRendering :: forall (selector :: * -> *) (t :: * -> *).
(forall field. selector field -> SelectorRendering t field)
-> forall field. Selectors selector field -> t field
selectorRendering forall field. selector field -> SelectorRendering t field
getRendering (Leaf selector field
s) = (selector field -> SelectorRendering t field
forall field. selector field -> SelectorRendering t field
getRendering selector field
s).renderTopSelector
selectorRendering forall field. selector field -> SelectorRendering t field
getRendering (selector field1
s :/ Selectors (SubSelector field1) field
tl) = SelectorRendering t field1
-> forall field'. Selectors (SubSelector field1) field' -> t field'
forall (t :: * -> *) field.
SelectorRendering t field
-> forall field'. Selectors (SubSelector field) field' -> t field'
renderSubSelector (selector field1 -> SelectorRendering t field1
forall field. selector field -> SelectorRendering t field
getRendering selector field1
s) Selectors (SubSelector field1) field
tl

-- | Generate a t'SelectorRendering' for events with no sub-events.
noSubEventsSelectorRendering ∷ (SubSelector field ~ NoEventsSelector) ⇒ t field → SelectorRendering t field
noSubEventsSelectorRendering :: forall field (t :: * -> *).
(SubSelector field ~ NoEventsSelector) =>
t field -> SelectorRendering t field
noSubEventsSelectorRendering t field
renderTopSelector =
  SelectorRendering
    { t field
renderTopSelector :: t field
renderTopSelector :: t field
renderTopSelector
    , renderSubSelector :: forall field'. Selectors (SubSelector field) field' -> t field'
renderSubSelector = (forall field.
 SubSelector field field -> SelectorRendering t field)
-> forall field'. Selectors (SubSelector field) field' -> t field'
forall (selector :: * -> *) (t :: * -> *).
(forall field. selector field -> SelectorRendering t field)
-> forall field. Selectors selector field -> t field
selectorRendering ((forall field.
  SubSelector field field -> SelectorRendering t field)
 -> forall field'. Selectors (SubSelector field) field' -> t field')
-> (forall field.
    SubSelector field field -> SelectorRendering t field)
-> forall field'. Selectors (SubSelector field) field' -> t field'
forall a b. (a -> b) -> a -> b
$ \case {}
    }

-- | Data needed to define a rendering of 'Selectors' of a given field type.
data SelectorRendering t field = SelectorRendering
  { forall (t :: * -> *) field. SelectorRendering t field -> t field
renderTopSelector ∷ !(t field)
  -- ^ Handle the case where the top of the tree was selected
  , forall (t :: * -> *) field.
SelectorRendering t field
-> forall field'. Selectors (SubSelector field) field' -> t field'
renderSubSelector ∷ !(∀ field'. Selectors (SubSelector field) field' → t field')
  -- ^ Handle a sub-event
  }

{- | An 'EventBackend' to use in the context of a running 'Event'.

It creates events selected by the 'SubSelector' of the event's @field@ type,
and any parentless events created by it are made children of the event.
-}
data SubEventBackend backend field = SubEventBackend
  { forall backend field.
SubEventBackend backend field -> RootSelector backend field
selector ∷ !(RootSelector backend field)
  -- ^ The selector of the @backend@ which 'Event's should be nested under.
  , forall backend field. SubEventBackend backend field -> backend
backend ∷ !backend
  -- ^ The underlying @backend@
  , forall backend field.
SubEventBackend backend field
-> EventReference (BackendEvent backend)
parentReference ∷ !(EventReference (BackendEvent backend))
  -- ^ A [reference](#g:relationships) to the running 'Event'
  }

newtype SubEventBackendEvent backend field = SubEventBackendEvent (BackendEvent backend field)

deriving newtype instance (EventBackend backend) ⇒ Event (SubEventBackendEvent backend)

deriving newtype instance (EventBackendIn m backend, Monad m) ⇒ EventIn m (SubEventBackendEvent backend)

{- | Create 'Event's in the parent 'EventBackend' which are children
of the running 'Event' and are selected by the 'SubSelector' of its
@field@ type.
-}
instance (EventBackend backend) ⇒ EventBackend (SubEventBackend backend field) where
  type BackendEvent (SubEventBackend backend field) = SubEventBackendEvent backend
  type RootSelector (SubEventBackend backend field) = SubSelector field

subEventParams ∷ SubEventBackend backend field → EventParams (SubSelector field) field' (EventReference (BackendEvent backend)) → EventParams (RootSelector backend) field' (EventReference (BackendEvent backend))
subEventParams :: forall backend field field'.
SubEventBackend backend field
-> EventParams
     (SubSelector field) field' (EventReference (BackendEvent backend))
-> EventParams
     (RootSelector backend)
     field'
     (EventReference (BackendEvent backend))
subEventParams SubEventBackend backend field
backend EventParams
  (SubSelector field) field' (EventReference (BackendEvent backend))
params =
  EventParams
  (SubSelector field) field' (EventReference (BackendEvent backend))
params
    { selectors = backend.selector :/ params.selectors
    , parent = params.parent <|> Just backend.parentReference
    }

{- | Create 'Event's in the parent 'EventBackend' which are children
of the running 'Event' and are selected by the 'SubSelector' of its
@field@ type.
-}
instance (EventBackendIn m backend, ParametricFunctor m) ⇒ EventBackendIn m (SubEventBackend backend field) where
  newEvent ∷ ∀ field'. SubEventBackend backend field → EventParams (SubSelector field) field' (EventReference (BackendEvent backend)) → m (SubEventBackendEvent backend field')
  newEvent :: forall field'.
SubEventBackend backend field
-> EventParams
     (SubSelector field) field' (EventReference (BackendEvent backend))
-> m (SubEventBackendEvent backend field')
newEvent SubEventBackend backend field
backend EventParams
  (SubSelector field) field' (EventReference (BackendEvent backend))
params =
    m (BackendEvent backend field')
-> m (SubEventBackendEvent backend field')
forall a b. Coercible a b => a -> b
coerce (m (BackendEvent backend field')
 -> m (SubEventBackendEvent backend field'))
-> m (BackendEvent backend field')
-> m (SubEventBackendEvent backend field')
forall a b. (a -> b) -> a -> b
$
      forall (m :: * -> *) backend field.
EventBackendIn m backend =>
backend
-> EventParams
     (RootSelector backend)
     field
     (EventReference (BackendEvent backend))
-> m (BackendEvent backend field)
newEvent @m @backend @field'
        SubEventBackend backend field
backend.backend
        (SubEventBackend backend field
-> EventParams
     (SubSelector field) field' (EventReference (BackendEvent backend))
-> EventParams
     (RootSelector backend)
     field'
     (EventReference (BackendEvent backend))
forall backend field field'.
SubEventBackend backend field
-> EventParams
     (SubSelector field) field' (EventReference (BackendEvent backend))
-> EventParams
     (RootSelector backend)
     field'
     (EventReference (BackendEvent backend))
subEventParams SubEventBackend backend field
backend EventParams
  (SubSelector field) field' (EventReference (BackendEvent backend))
params)
  newInstantEvent ∷ ∀ field'. SubEventBackend backend field → EventParams (SubSelector field) field' (EventReference (BackendEvent backend)) → m (EventReference (BackendEvent backend))
  newInstantEvent :: forall field'.
SubEventBackend backend field
-> EventParams
     (SubSelector field) field' (EventReference (BackendEvent backend))
-> m (EventReference (BackendEvent backend))
newInstantEvent SubEventBackend backend field
backend EventParams
  (SubSelector field) field' (EventReference (BackendEvent backend))
params =
    m (EventReference (BackendEvent backend))
-> m (EventReference (BackendEvent backend))
forall a b. Coercible a b => a -> b
coerce (m (EventReference (BackendEvent backend))
 -> m (EventReference (BackendEvent backend)))
-> m (EventReference (BackendEvent backend))
-> m (EventReference (BackendEvent backend))
forall a b. (a -> b) -> a -> b
$
      forall (m :: * -> *) backend field.
EventBackendIn m backend =>
backend
-> EventParams
     (RootSelector backend)
     field
     (EventReference (BackendEvent backend))
-> m (EventReference (BackendEvent backend))
newInstantEvent @m @backend @field'
        SubEventBackend backend field
backend.backend
        (SubEventBackend backend field
-> EventParams
     (SubSelector field) field' (EventReference (BackendEvent backend))
-> EventParams
     (RootSelector backend)
     field'
     (EventReference (BackendEvent backend))
forall backend field field'.
SubEventBackend backend field
-> EventParams
     (SubSelector field) field' (EventReference (BackendEvent backend))
-> EventParams
     (RootSelector backend)
     field'
     (EventReference (BackendEvent backend))
subEventParams SubEventBackend backend field
backend EventParams
  (SubSelector field) field' (EventReference (BackendEvent backend))
params)

-- | Add a [field](Observe-Event.html#g:selectorAndField) to the running 'Event'.
addEventField
  ∷ (HasEventIn m event field)
  ⇒ field
  → m ()
addEventField :: forall (m :: * -> *) (event :: * -> *) field.
HasEventIn m event field =>
field -> m ()
addEventField = event field -> field -> m ()
forall field. event field -> field -> m ()
forall (m :: * -> *) (event :: * -> *) field.
EventIn m event =>
event field -> field -> m ()
addField event field
?e11yEvent::event field
?e11yEvent