eventuo11y 0.5.0.0 → 0.6.0.0

raw patch · 10 files changed

+918/−1054 lines, 10 filesdep +general-allocatedep +monad-controldep +mtldep −resourcetdep −safe-exceptionsdep ~basedep ~transformersPVP ok

version bump matches the API change (PVP)

Dependencies added: general-allocate, monad-control, mtl, transformers-base

Dependencies removed: resourcet, safe-exceptions

Dependency ranges changed: base, transformers

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• Example.hs +0/−138
• eventuo11y.cabal +15/−13
• src/Control/Monad/Cleanup.hs +0/−296
• src/Control/Natural/Control.hs +72/−0
• src/Observe/Event.hs +163/−291
• src/Observe/Event/Backend.hs +213/−158
• src/Observe/Event/BackendModification.hs +0/−158
• src/Observe/Event/Class.hs +248/−0
• src/Observe/Event/Explicit.hs +201/−0

@@ -1,5 +1,11 @@ # Revision history for eventuo11y +## 0.6.0.0 -- 2022-12-23++- Add `MonadEvent` for implicit backend management+- Simplify `EventBackend` and move to backend-modifying functions instead of `BackendModification`+- Move from `MonadCleanup` to `general-allocate`+ ## 0.5.0.0 -- 2022-10-23  - Add MonadCleanup

@@ -1,138 +0,0 @@--- Search for comments to find commentary of interest-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE OverloadedLists #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeSynonymInstances #-}--module Main where--import Control.Exception-import Control.Monad-import Data.Aeson-import Data.ByteString.Internal-import Data.Void-import Foreign.C.Error-import Foreign.C.Types-import Foreign.ForeignPtr-import Foreign.Ptr-import GHC.Generics-import Observe.Event-import Observe.Event.DSL-import Observe.Event.Render.JSON-import Observe.Event.Render.JSON.DSL.Compile-import Observe.Event.Render.JSON.Handle-import System.FilePath-import System.IO.Temp-import System.Posix.Files-import System.Posix.IO-import System.Posix.Types---- Pretend this is in a separate module File where--deriving instance Show Errno--deriving instance ToJSON Errno--deriving instance Generic Errno--deriving instance ToJSON CInt--deriving instance Generic CInt--deriving instance ToJSON Fd--deriving instance Generic Fd--deriving instance ToJSON ByteCount--deriving instance Generic ByteCount---- Define our selector type and give it instances to render as JSON-compile $-  SelectorSpec-    "file" -- Creates a type FileSelector-    [ ["open", "file"] -- Creates a constructor OpenFile :: FileSelector OpenField-        ≔ FieldSpec-          "open" -- Creates a type OpenField-          [ "filename" ≔ ''FilePath, -- creates a constructor Filename :: !FilePath -> OpenField-            ["file", "fd"] ≔ ''Fd -- creates a constructor FileFd :: !Fd -> OpenField-          ],-      "write"-        ≔ FieldSpec-          "write"-          [ ["bytes", "asked"] ≔ ''ByteCount,-            ["bytes", "actual"] ≔ ''ByteCount-          ]-    ]---- We take an EventBackend, polymorphic in r, supporting our domain-specific selector type-writeToFile :: EventBackend IO r FileSelector -> FilePath -> ByteString -> IO ()-writeToFile backend path bs = do-  let (fptr, base_off, sz) = toForeignPtr bs-  -- We start an event, selected by OpenFile-  fd <- withEvent backend OpenFile $ \ev -> do-    -- We add a Filename field to our current active event-    addField ev $ Filename path--    fd <- openFd path WriteOnly (Just regularFileMode) defaultFileFlags-    when (fd == -1) $ do-      errno <- getErrno-      -- Throw an exception which we can render as JSON-      throw $ BadOpen path errno--    addField ev $ FileFd fd-    pure fd-  withForeignPtr fptr $ \ptr -> do-    let bcSz = fromIntegral sz-        go :: ByteCount -> IO ()-        go offset = do-          newOffset <- withEvent backend Write $ \ev -> do-            let ct = bcSz - offset-            addField ev $ BytesAsked ct-            written <- fdWriteBuf fd (plusPtr ptr (base_off + fromIntegral offset)) ct-            addField ev $ BytesActual written-            pure $ offset + written-          when (newOffset < bcSz) $-            go newOffset-    go 0-  closeFd fd-  pure ()---- Define a new exception that can be used with simpleJsonStderrBackend-data BadOpen = BadOpen-  { path :: !FilePath,-    errno :: !Errno-  }-  deriving (Show, ToJSON, Generic)---- Our exception is beneath SomeJSONException in the hierarchy-instance Exception BadOpen where-  toException = jsonExceptionToException-  fromException = jsonExceptionFromException---- end module File--compile $-  SelectorSpec-    "main"-    [ ["using", "temp", "dir"] ≔ ''FilePath, -- Creates a constructor UsingTempDir :: MainSelector FilePath-      "writing" ≔ Inject ''FileSelector -- Creates a constructor Writing :: FileSelector x -> MainSelector x-    ]---- Note a different selector type than writeToFile-instrumentedMain :: EventBackend IO r MainSelector -> IO ()-instrumentedMain backend = do-  withEvent backend UsingTempDir $ \ev -> do-    withSystemTempDirectory "example" $ \dir -> do-      addField ev dir-      -- Pass a new EventBackend where all parentless events are made children of our current event-      writeToFile (subEventBackend Writing ev) (dir </> "example.txt") "example"--main :: IO ()-main =-  -- Initialize a backend to write JSON to stderr and use it.-  simpleJsonStderrBackend defaultRenderSelectorJSON >>= instrumentedMain

@@ -1,6 +1,6 @@ cabal-version:      3.0 name:               eventuo11y-version:            0.5.0.0+version:            0.6.0.0 synopsis:           An event-oriented observability library description:   Instrument your Haskell codebase with wide, semantically meaningful events.@@ -32,7 +32,7 @@   See [eventuo11y-json](https://hackage.haskell.org/package/eventuo11y-json) for JSON-based rendering   and backends. -  See [Example.hs](https://github.com/shlevy/eventuo11y/tree/v0.5.0.0/Example.hs) for an example.+  See [Example.hs](https://github.com/shlevy/eventuo11y/tree/v0.6.0.0/Example.hs) for an example.    See [eventuo11y-batteries](https://hackage.haskell.org/package/eventuo11y-batteries) for miscellaneous   framework-specific helpers.@@ -46,8 +46,7 @@ category:           Observability extra-source-files:   CHANGELOG.md-  Example.hs-tested-with:        GHC == { 8.10.7, 9.2.4 }+tested-with:        GHC == { 8.10.7, 9.2.4, 9.4.2 }  source-repository head   type:     git@@ -55,19 +54,22 @@  library   exposed-modules:-    Control.Monad.Cleanup+    Control.Natural.Control     Observe.Event     Observe.Event.Backend-    Observe.Event.BackendModification+    Observe.Event.Class+    Observe.Event.Explicit    build-depends:-    , base             ^>= { 4.14, 4.16 }-    , exceptions       ^>= 0.10-    , primitive        ^>= 0.7-    , resourcet        ^>= { 1.2, 1.3 }-    , safe-exceptions  ^>= 0.1-    , transformers     ^>= 0.5-    , unliftio-core    ^>= 0.2+    , base              ^>= { 4.14, 4.16, 4.17 }+    , exceptions        ^>= { 0.10 }+    , general-allocate  ^>= { 0.2 }+    , primitive         ^>= { 0.7 }+    , transformers      ^>= { 0.5, 0.6 }+    , transformers-base ^>= { 0.4 }+    , monad-control     ^>= { 1.0 }+    , mtl               ^>= { 2.2 }+    , unliftio-core     ^>= { 0.2 }    hs-source-dirs:   src   default-language: Haskell2010

@@ -1,296 +0,0 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE DerivingVia #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TypeApplications #-}---- |--- Description : Monads that can cleanup within a single monaadic scope--- Copyright   : Copyright 2022 Shea Levy.--- License     : Apache-2.0--- Maintainer  : shea@shealevy.com-module Control.Monad.Cleanup where--import Control.Exception.Safe-import Control.Monad.Catch (ExitCase (..))-import Control.Monad.ST-import Control.Monad.Trans.Except (ExceptT (..), runExceptT)-import Control.Monad.Trans.Identity-import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)-import qualified Control.Monad.Trans.RWS.Lazy as LazyRWS-import qualified Control.Monad.Trans.RWS.Strict as StrictRWS-import Control.Monad.Trans.Reader (ReaderT (..), runReaderT)-import qualified Control.Monad.Trans.State.Lazy as LazyS-import qualified Control.Monad.Trans.State.Strict as StrictS-import qualified Control.Monad.Trans.Writer.Lazy as LazyW-import qualified Control.Monad.Trans.Writer.Strict as StrictW-import Data.Coerce-import Data.Functor.Identity---- | Monads that can cleanup within a single monadic scope.------ 'MonadCleanup's allow for acquiring some resource and--- guaranteeing that it will be released,--- __if computation might continue within that monad__.------ This is very similar to 'MonadMask', with the following differences:------ 1. 'MonadCleanup's may not be able to throw or catch exceptions (no 'MonadCatch'---    superclass) or mask exceptions.--- 2. The guarantee of 'generalCleanup' is not as absolute as 'generalBracket' (though the latter---    always has the @SIGKILL@/power goes out exception). If we can't handle exceptions---    at all in the monad (at least not without @unsafePerformIO@), then sometimes the cleanup---    function won't be called, but only in cases where the entire computation the monad is---    running is going to be aborted.------ This allows 'MonadCleanup' to be used in pure contexts (see 'CleanupNoException') and still--- provide meaningful semantics.-class (Monad m) => MonadCleanup m where-  -- | Acquire some resource, use it, and clean it up.-  ---  -- cleanup is guaranteed to run-  -- __if computation in the surrounding monadic scope might continue__.-  ---  -- Similar to 'generalBracket', see documentation of 'MonadCleanup' for the differences.-  generalCleanup ::-    -- | Acquire some resource-    m a ->-    -- | Release the resource, observing the outcome of the inner action-    (a -> ExitCase b -> m c) ->-    -- | Inner action to perform with the resource-    (a -> m b) ->-    m (b, c)---- | An 'Exception' corresponding to the 'ExitCaseAbort' exit case.-data AbortException = AbortException-  deriving stock (Show)-  deriving anyclass (Exception)---- | Acquire some resource, use it, and clean it up.------ This is to 'bracketWithError' as 'generalCleanup' is to 'generalBracket', see documentation--- of 'generalCleanup' for more details.-withCleanup ::-  (MonadCleanup m) =>-  m a ->-  (Maybe SomeException -> a -> m b) ->-  (a -> m c) ->-  m c-withCleanup acquire cleanup go = fst <$> generalCleanup acquire release go-  where-    release x (ExitCaseSuccess _) = cleanup Nothing x-    release x ExitCaseAbort = cleanup (Just (toException AbortException)) x-    release x (ExitCaseException e) = cleanup (Just e) x---- | A [DerivingVia](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/deriving_via.html) helper for deriving 'MonadCleanup' from 'MonadMask'.-newtype CleanupFromMask m a = CleanupFromMask (m a) deriving newtype (Functor, Applicative, Monad)--instance (MonadMask m) => MonadCleanup (CleanupFromMask m) where-  generalCleanup :: forall a b c. CleanupFromMask m a -> (a -> ExitCase b -> CleanupFromMask m c) -> (a -> CleanupFromMask m b) -> CleanupFromMask m (b, c)-  generalCleanup = coerce $ generalBracket @m @a @b @c--deriving via CleanupFromMask IO instance MonadCleanup IO---- | A [DerivingVia](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/deriving_via.html) for deriving 'MonadCleanup' in a 'Monad' which--- __can't__ handle exceptions.------ If cleanup runs at all, it will run in 'ExitCaseSuccess'------ __Note that the associated 'MonadCleanup' instance is invalid if it is possible to catch exceptions in the monad!__-newtype CleanupNoException m a = CleanupNoException (m a) deriving newtype (Functor, Applicative, Monad)--instance (Monad m) => MonadCleanup (CleanupNoException m) where-  generalCleanup acquire release go = do-    x <- acquire-    res <- go x-    carry <- release x (ExitCaseSuccess res)-    pure (res, carry)--deriving via CleanupNoException (ST s) instance MonadCleanup (ST s)--deriving via CleanupNoException Identity instance MonadCleanup Identity--instance (MonadCleanup m) => MonadCleanup (IdentityT m) where-  generalCleanup acquire release use =-    IdentityT $-      generalCleanup-        (runIdentityT acquire)-        (\resource exitCase -> runIdentityT (release resource exitCase))-        (\resource -> runIdentityT (use resource))--instance MonadCleanup m => MonadCleanup (LazyS.StateT s m) where-  generalCleanup acquire release use = LazyS.StateT $ \s0 -> do-    ((b, _s2), (c, s3)) <--      generalCleanup-        (LazyS.runStateT acquire s0)-        ( \(resource, s1) exitCase -> case exitCase of-            ExitCaseSuccess (b, s2) -> LazyS.runStateT (release resource (ExitCaseSuccess b)) s2-            -- In the two other cases, the base monad overrides @use@'s state-            -- changes and the state reverts to @s1@.-            ExitCaseException e -> LazyS.runStateT (release resource (ExitCaseException e)) s1-            ExitCaseAbort -> LazyS.runStateT (release resource ExitCaseAbort) s1-        )-        (\(resource, s1) -> LazyS.runStateT (use resource) s1)-    return ((b, c), s3)--instance MonadCleanup m => MonadCleanup (StrictS.StateT s m) where-  generalCleanup acquire release use = StrictS.StateT $ \s0 -> do-    ((b, _s2), (c, s3)) <--      generalCleanup-        (StrictS.runStateT acquire s0)-        ( \(resource, s1) exitCase -> case exitCase of-            ExitCaseSuccess (b, s2) -> StrictS.runStateT (release resource (ExitCaseSuccess b)) s2-            -- In the two other cases, the base monad overrides @use@'s state-            -- changes and the state reverts to @s1@.-            ExitCaseException e -> StrictS.runStateT (release resource (ExitCaseException e)) s1-            ExitCaseAbort -> StrictS.runStateT (release resource ExitCaseAbort) s1-        )-        (\(resource, s1) -> StrictS.runStateT (use resource) s1)-    return ((b, c), s3)--instance MonadCleanup m => MonadCleanup (ReaderT r m) where-  generalCleanup acquire release use = ReaderT $ \r ->-    generalCleanup-      (runReaderT acquire r)-      (\resource exitCase -> runReaderT (release resource exitCase) r)-      (\resource -> runReaderT (use resource) r)--instance (MonadCleanup m, Monoid w) => MonadCleanup (StrictW.WriterT w m) where-  generalCleanup acquire release use = StrictW.WriterT $ do-    ((b, _w12), (c, w123)) <--      generalCleanup-        (StrictW.runWriterT acquire)-        ( \(resource, w1) exitCase -> case exitCase of-            ExitCaseSuccess (b, w12) -> do-              (c, w3) <- StrictW.runWriterT (release resource (ExitCaseSuccess b))-              return (c, mappend w12 w3)-            -- In the two other cases, the base monad overrides @use@'s state-            -- changes and the state reverts to @w1@.-            ExitCaseException e -> do-              (c, w3) <- StrictW.runWriterT (release resource (ExitCaseException e))-              return (c, mappend w1 w3)-            ExitCaseAbort -> do-              (c, w3) <- StrictW.runWriterT (release resource ExitCaseAbort)-              return (c, mappend w1 w3)-        )-        ( \(resource, w1) -> do-            (a, w2) <- StrictW.runWriterT (use resource)-            return (a, mappend w1 w2)-        )-    return ((b, c), w123)--instance (MonadCleanup m, Monoid w) => MonadCleanup (LazyW.WriterT w m) where-  generalCleanup acquire release use = LazyW.WriterT $ do-    ((b, _w12), (c, w123)) <--      generalCleanup-        (LazyW.runWriterT acquire)-        ( \(resource, w1) exitCase -> case exitCase of-            ExitCaseSuccess (b, w12) -> do-              (c, w3) <- LazyW.runWriterT (release resource (ExitCaseSuccess b))-              return (c, mappend w12 w3)-            -- In the two other cases, the base monad overrides @use@'s state-            -- changes and the state reverts to @w1@.-            ExitCaseException e -> do-              (c, w3) <- LazyW.runWriterT (release resource (ExitCaseException e))-              return (c, mappend w1 w3)-            ExitCaseAbort -> do-              (c, w3) <- LazyW.runWriterT (release resource ExitCaseAbort)-              return (c, mappend w1 w3)-        )-        ( \(resource, w1) -> do-            (a, w2) <- LazyW.runWriterT (use resource)-            return (a, mappend w1 w2)-        )-    return ((b, c), w123)--instance (MonadCleanup m, Monoid w) => MonadCleanup (LazyRWS.RWST r w s m) where-  generalCleanup acquire release use = LazyRWS.RWST $ \r s0 -> do-    ((b, _s2, _w12), (c, s3, w123)) <--      generalCleanup-        (LazyRWS.runRWST acquire r s0)-        ( \(resource, s1, w1) exitCase -> case exitCase of-            ExitCaseSuccess (b, s2, w12) -> do-              (c, s3, w3) <- LazyRWS.runRWST (release resource (ExitCaseSuccess b)) r s2-              return (c, s3, mappend w12 w3)-            -- In the two other cases, the base monad overrides @use@'s state-            -- changes and the state reverts to @s1@ and @w1@.-            ExitCaseException e -> do-              (c, s3, w3) <- LazyRWS.runRWST (release resource (ExitCaseException e)) r s1-              return (c, s3, mappend w1 w3)-            ExitCaseAbort -> do-              (c, s3, w3) <- LazyRWS.runRWST (release resource ExitCaseAbort) r s1-              return (c, s3, mappend w1 w3)-        )-        ( \(resource, s1, w1) -> do-            (a, s2, w2) <- LazyRWS.runRWST (use resource) r s1-            return (a, s2, mappend w1 w2)-        )-    return ((b, c), s3, w123)--instance (MonadCleanup m, Monoid w) => MonadCleanup (StrictRWS.RWST r w s m) where-  generalCleanup acquire release use = StrictRWS.RWST $ \r s0 -> do-    ((b, _s2, _w12), (c, s3, w123)) <--      generalCleanup-        (StrictRWS.runRWST acquire r s0)-        ( \(resource, s1, w1) exitCase -> case exitCase of-            ExitCaseSuccess (b, s2, w12) -> do-              (c, s3, w3) <- StrictRWS.runRWST (release resource (ExitCaseSuccess b)) r s2-              return (c, s3, mappend w12 w3)-            -- In the two other cases, the base monad overrides @use@'s state-            -- changes and the state reverts to @s1@ and @w1@.-            ExitCaseException e -> do-              (c, s3, w3) <- StrictRWS.runRWST (release resource (ExitCaseException e)) r s1-              return (c, s3, mappend w1 w3)-            ExitCaseAbort -> do-              (c, s3, w3) <- StrictRWS.runRWST (release resource ExitCaseAbort) r s1-              return (c, s3, mappend w1 w3)-        )-        ( \(resource, s1, w1) -> do-            (a, s2, w2) <- StrictRWS.runRWST (use resource) r s1-            return (a, s2, mappend w1 w2)-        )-    return ((b, c), s3, w123)--instance MonadCleanup m => MonadCleanup (MaybeT m) where-  generalCleanup acquire release use = MaybeT $ do-    (eb, ec) <--      generalCleanup-        (runMaybeT acquire)-        ( \resourceMay exitCase -> case resourceMay of-            Nothing -> return Nothing -- nothing to release, acquire didn't succeed-            Just resource -> case exitCase of-              ExitCaseSuccess (Just b) -> runMaybeT (release resource (ExitCaseSuccess b))-              ExitCaseException e -> runMaybeT (release resource (ExitCaseException e))-              _ -> runMaybeT (release resource ExitCaseAbort)-        )-        ( \resourceMay -> case resourceMay of-            Nothing -> return Nothing-            Just resource -> runMaybeT (use resource)-        )-    -- The order in which we perform those two 'Maybe' effects doesn't matter,-    -- since the error message is the same regardless.-    return ((,) <$> eb <*> ec)--instance MonadCleanup m => MonadCleanup (ExceptT e m) where-  generalCleanup acquire release use = ExceptT $ do-    (eb, ec) <--      generalCleanup-        (runExceptT acquire)-        ( \eresource exitCase -> case eresource of-            Left e -> return (Left e) -- nothing to release, acquire didn't succeed-            Right resource -> case exitCase of-              ExitCaseSuccess (Right b) -> runExceptT (release resource (ExitCaseSuccess b))-              ExitCaseException e -> runExceptT (release resource (ExitCaseException e))-              _ -> runExceptT (release resource ExitCaseAbort)-        )-        (either (return . Left) (runExceptT . use))-    return $ do-      -- The order in which we perform those two 'Either' effects determines-      -- which error will win if they are both 'Left's. We want the error from-      -- 'release' to win.-      c <- ec-      b <- eb-      return (b, c)

@@ -0,0 +1,72 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- |+-- Description : Natural transformations that can lift control operations+-- Copyright   : Copyright 2022 Shea Levy.+-- License     : Apache-2.0+-- Maintainer  : shea@shealevy.com+--+-- Natural transformations can lift monadic actions from the source to the+-- target, but something stronger is needed to lift general higher-order control+-- operations like @catch@.+--+-- This module relates to [Control.Natural](https://hackage.haskell.org/package/natural-transformation/docs/Control-Natural.html)+-- in a similar way to how [Control.Monad.Trans.Control](https://hackage.haskell.org/package/monad-control/docs/Control-Monad-Trans-Control.html)+-- relates to "Control.Monad.Trans.Class".+module Control.Natural.Control where++import Data.Coerce+import Data.Functor.Compose+import Data.Functor.Identity++-- | A transformation from @m@ to @n@ that can lift control operations.+--+-- The @st@ functor is needed to track the higher monad's state+-- in the lower monad. See 'StatelessControlTransformation' for the case+-- where no state tracking is needed.+data ControlTransformation st m n = ControlTransformation+  { -- | Lift an action in @m@, defined in a context where @n@ actions+    -- can be lowered into @m@ with state tracking, into @n@.+    transWith :: !(forall a. ((forall x. n x -> Compose m st x) -> m a) -> n a),+    -- | Restore the state captured by 'transWith'+    restoreState :: !(forall a. st a -> n a)+  }++-- | Extract a natural transformation from a 'ControlTransformation'+toNatural :: ControlTransformation st m n -> (forall x. m x -> n x)+toNatural ct mx = transWith ct $ const mx++-- | A transformation from @m@ to @n@ that can lift control operations.+--+-- This type is only appropriate for the case where the higher monad+-- does not have any additional state that must be accounted for when+-- running within the lower monad. For the more general case, see+-- 'ControlTransformation'.+--+-- I'm told this is a right kan extension.+type StatelessControlTransformation = ControlTransformation Identity++-- | Create a 'StatelessControlTransformation'+statelessControlTransformation ::+  forall m n.+  (Functor m, Applicative n) =>+  -- | Lift an action in @m@, defined in a context where @n@+  -- actions can be lowered into @m@, into @n@.+  (forall a. ((forall x. n x -> m x) -> m a) -> n a) ->+  StatelessControlTransformation m n+statelessControlTransformation transWith' = ControlTransformation {..}+  where+    transWith :: forall a. ((forall x. n x -> Compose m Identity x) -> m a) -> n a+    transWith useRunInM = transWith' $ \runInM -> useRunInM (Compose . fmap Identity . runInM)+    restoreState :: forall a. Identity a -> n a+    restoreState = pure . coerce++-- | Lift an action in @m@, defined in a context where @n@+-- actions can be lowered into @m@, into @n@.+statelessTransWith ::+  (Functor m) =>+  StatelessControlTransformation m n ->+  (((forall x. n x -> m x) -> m a) -> n a)+statelessTransWith (ControlTransformation {..}) useRunInM = transWith $ \runInM -> useRunInM (fmap runIdentity . getCompose . runInM)

@@ -1,10 +1,21 @@ {-# LANGUAGE ApplicativeDo #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE StandaloneKindSignatures #-} {-# LANGUAGE TypeApplications #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE UndecidableInstances #-}+ -- | -- Description : Core interface for instrumentation with eventuo11y -- Copyright   : Copyright 2022 Shea Levy.@@ -29,371 +40,232 @@ -- 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).+-- (but see [DynamicField](https://hackage.haskell.org/package/eventuo11y-json/docs/Observe-Event-Dynamic.html#t: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>.+-- with 'MonadEvent' functions, typically via the+-- <#g:resourcesafe resource-safe event allocation functions>. For an+-- explicit alternative to 'MonadEvent', see "Observe.Event.Explicit". -- -- 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.+-- [RenderSelectorJSON](https://hackage.haskell.org/package/eventuo11y-json/docs/Observe-Event-Render-JSON.html#t:RenderSelectorJSON)+-- to use JSON rendering 'EventBackend's. module Observe.Event   ( Event,     hoistEvent,      -- * Event manipulation #eventmanip#-    reference,     addField,-    addParent,-    addProximate,+    reference,+    Explicit.addParent,+    Explicit.addProximate,+    addReference,+    Reference (..),+    ReferenceType (..), -    -- * Resource-safe event allocation #resourcesafe#+    -- * MonadEvent+    MonadEvent,+    EnvEvent,++    -- ** Resource-safe event allocation #resourcesafe#     withEvent,-    withSubEvent,+    withNarrowingEvent,+    InjectSelector,+    injectSelector,+    idInjectSelector,+    MonadWithEvent,+    allocateEvent, -    -- ** MonadMask variants-    withEventMask,-    withSubEventMask,+    -- ** EventT+    EventT,+    runEventT,+    eventLift, -    -- ** Acquire/MonadResource variants-    acquireEvent,-    acquireSubEvent,+    -- ** TransEventMonad+    TransEventMonad (..), -    -- * 'EventBackend's+    -- ** Primitives+    BackendMonad,+    EnvBackend,     EventBackend,-    subEventBackend,-    causedEventBackend,-    unitEventBackend,-    pairEventBackend,-    hoistEventBackend,-    narrowEventBackend,-    narrowEventBackend',+    liftBackendMonad,+    backend,+    withModifiedBackend,      -- * Primitive 'Event' resource management.      -- | Prefer the [resource-safe event allocation functions](#g:resourcesafe)     -- to these when possible.     finalize,-    failEvent,-    newEvent,+    newEvent',     newSubEvent,++    -- * Backend Events++    -- | 'Event's within the 'BackendMonad' of a 'MonadEvent'+    --+    -- These are low-level primitives that can be used if the+    -- existing higher-level event allocation/backend modification+    -- combinators are insufficient+    BackendEvent,+    hoistBackendEvent,+    allocateBackendEvent,+    withBackendEvent,+    newBackendEvent,   ) where -import Control.Exception.Safe-import Control.Monad.Cleanup-import Control.Monad.IO.Unlift-import Data.Acquire+import Control.Monad.Primitive+import Control.Monad.With+import Data.Exceptable+import Data.GeneralAllocate+import Data.Kind import Observe.Event.Backend-import Observe.Event.BackendModification---- | 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.-    backend :: !(EventBackend m r s),-    -- | The underlying 'EventImpl' implementing the event functionality.-    impl :: !(EventImpl m r f),-    -- | A 'OnceFlag' to ensure we only finish ('finalize' or 'failEvent') once.-    finishFlag :: !(OnceFlag m)-  }---- | Hoist an 'Event' along a given natural transformation into a new monad.-hoistEvent :: (Functor m, Functor n) => (forall x. m x -> n x) -> Event m r s f -> Event n r s f-hoistEvent nt Event {..} =-  Event-    { backend = hoistEventBackend nt backend,-      impl = hoistEventImpl nt impl,-      finishFlag = hoistOnceFlag nt finishFlag-    }---- | 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 (Event {..}) = referenceImpl 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 (Event {..}) = addFieldImpl 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 (Event {..}) = addParentImpl impl+import Observe.Event.Class+import qualified Observe.Event.Explicit as Explicit --- | 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 (Event {..}) = addProximateImpl impl+-- | An 'Event' in a 'MonadEvent'+type EnvEvent :: EventMonadKind -> ReferenceKind -> SelectorKind -> Type -> Type+type EnvEvent em r s = Event (em r s) r --- | Mark an 'Event' as finished.+-- | Run an action with a new 'Event', selected by the given selector. ----- In normal usage, this should be automatically called via the use of--- the [resource-safe event allocation functions](#g:resourcesafe).+-- 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'). ----- 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 (Event {..}) = runOnce finishFlag $ finalizeImpl impl---- | Mark an 'Event' as having failed due to an 'Exception'.+-- Selectors are intended to be of a domain specific type per unit of+-- functionality within an instrumented codebase, implemented as a GADT+-- (but see [DynamicEventSelector](https://hackage.haskell.org/package/eventuo11y-json/docs/Observe-Event-Dynamic.html#t:DynamicEventSelector) for a generic option). ----- In normal usage, this should be automatically called via the use of--- the [resource-safe event allocation functions](#g:resourcesafe).+-- Within the nested action, all new parentless 'Event's will be+-- made children of the new 'Event'. ----- 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 -> SomeException -> m ()-failEvent (Event {..}) = runOnce finishFlag . failImpl impl+-- The 'Event' will be 'finalize'd at the end of the nested action.+withEvent ::+  (MonadWithEvent em r s) =>+  forall f.+  s f ->+  (EnvEvent em r s f -> em r s a) ->+  em r s a+withEvent = withNarrowingEvent idInjectSelector --- | Create a new 'Event', selected by the given selector.+-- | Run an action with a new 'Event' , selected by a given selector, with a narrower sub-selector type. -- -- 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).+-- (but see [DynamicEventSelector](https://hackage.haskell.org/package/eventuo11y-json/docs/Observe-Event-Dynamic.html#t: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 ->+-- Within the nested action, all new parentless 'Event's will be+-- made children of the new 'Event', and all new 'Event's will+-- be selected by the narrower selector type.+--+-- The 'Event' will be 'finalize'd at the end of the nested action.+withNarrowingEvent ::+  (MonadWithEvent em r t) =>+  InjectSelector s t ->   forall f.-  -- | The event selector.-  s f ->-  m (Event m r s f)-newEvent backend@(EventBackend {..}) sel = do-  impl <- newEventImpl sel-  finishFlag <- newOnceFlag-  pure Event {..}+  t f ->+  (EnvEvent em r s f -> em r s x) ->+  em r t x+withNarrowingEvent inj sel go = withBackendEvent sel $ \ev -> do+  let ev' = hoistBackendEvent ev+  withModifiedBackend (narrowEventBackend inj . setAncestorEventBackend (reference ev)) $ go ev' --- | Create a new 'Event' as a child of the given 'Event', selected by the given selector.+-- | A 'MonadEvent' suitable for running the 'withEvent' family of functions+type MonadWithEvent em r s = (MonadEvent em, PrimMonad (BackendMonad em), MonadWithExceptable (em r s))++-- | Allocate 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).+-- (but see [DynamicEventSelector](https://hackage.haskell.org/package/eventuo11y-json/docs/Observe-Event-Dynamic.html#t: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 (Event {..}) sel = do-  child <- newEvent backend sel-  addParent child $ referenceImpl impl-  pure child+-- The 'Event' will be automatically 'finalize'd on release.+allocateEvent ::+  (MonadEvent em, Exceptable e) =>+  forall f.+  s f ->+  GeneralAllocate (em r s) e () releaseArg (EnvEvent em r s f)+allocateEvent = fmap hoistBackendEvent . allocateBackendEvent --- | Run an action with a new 'Event', selected by the given selector.+-- | 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).+-- (but see [DynamicEventSelector](https://hackage.haskell.org/package/eventuo11y-json/docs/Observe-Event-Dynamic.html#t: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 ::-  (MonadCleanup m) =>-  EventBackend m r s ->-  forall f.-  -- | The event selector.-  s f ->-  (Event m r s f -> m a) ->-  m a-withEvent backend sel go = withCleanup (newEvent backend sel) cleanup go-  where-    cleanup Nothing = finalize-    cleanup (Just e) = flip failEvent e+-- Consider the [resource-safe event allocation functions](#g:resourcesafe) instead+-- of calling this directly.+newEvent' :: (MonadEvent em) => forall f. s f -> em r s (EnvEvent em r s f)+newEvent' = fmap hoistBackendEvent . newBackendEvent --- | Run an action with a new 'Event' as a child of the given 'Event', selected by the given selector.+-- | 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).+-- (but see [DynamicEventSelector](https://hackage.haskell.org/package/eventuo11y-json/docs/Observe-Event-Dynamic.html#t: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 ::-  (MonadCleanup m) =>-  -- | The parent 'Event'.-  Event m r s f ->+-- Consider the [resource-safe event allocation functions](#g:resourcesafe) instead+-- of calling this directly.+newSubEvent ::+  (MonadEvent em) =>+  EnvEvent em r s f ->   forall f'.-  -- | The child event selector.   s f' ->-  (Event m r s f' -> m a) ->-  m a-withSubEvent (Event {..}) sel go = withEvent backend sel $ \child -> do-  addParent child $ referenceImpl impl-  go child+  em r s (EnvEvent em r s f')+newSubEvent ev sel = do+  child <- newEvent' sel+  Explicit.addParent child $ reference ev+  pure child --- TODO Implement in terms of withEvent + CleanupFromMask+-- | An 'Event' in the 'BackendMonad' of a 'MonadEvent'+type BackendEvent :: EventMonadKind -> ReferenceKind -> Type -> Type+type BackendEvent em = Event (BackendMonad em) --- | 'withEvent' in 'MonadMask'-withEventMask ::-  forall m r s.-  (MonadMask m) =>-  EventBackend m r s ->+-- | Bring a 'BackendEvent' into the 'MonadEvent'+hoistBackendEvent :: (MonadEvent em) => BackendEvent em r f -> EnvEvent em r s f+hoistBackendEvent = hoistEvent liftBackendMonad++-- | A 'BackendMonad' variant of 'allocateEvent'.+allocateBackendEvent ::+  (MonadEvent em, Exceptable e) =>   forall f.-  -- | The event selector.   s f ->-  forall a.-  (Event m r s f -> m a) ->-  m a-withEventMask backend sel go = bracketWithError (newEvent backend sel) release go-  where-    release Nothing = finalize-    release (Just e) = flip failEvent e---- TODO implement in terms of withSubEvent + CleanupFromMask---- | 'withSubEvent' in 'MonadMask'-withSubEventMask ::-  (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-withSubEventMask (Event {..}) sel go = withEventMask backend sel $ \child -> do-  addParent child $ referenceImpl impl-  go child+  GeneralAllocate (em r s) e () releaseArg (BackendEvent em r f)+allocateBackendEvent sel = GeneralAllocate $ \_ -> do+  ev <- newBackendEvent sel+  let release (ReleaseFailure e) = liftBackendMonad . finalize ev . Just $ toSomeException e+      release (ReleaseSuccess _) = liftBackendMonad $ finalize ev Nothing+  pure $ GeneralAllocated ev release --- | An 'Acquire' variant of 'withEvent', usable in a t'Control.Monad.Trans.Resource.MonadResource' with 'allocateAcquire'.+-- | Run an action with a new 'BackendEvent'. ----- Prior to @resourcet@ version @1.3.0@, exceptional exit will 'failEvent' with 'AbortException'.-acquireEvent ::-  (MonadUnliftIO m) =>-  EventBackend m r s ->+-- The 'Event' will be 'finalize'd upon completion.+withBackendEvent ::+  (MonadEvent em, MonadWithExceptable (em r s)) =>   forall f.-  -- | The event selector.   s f ->-  m (Acquire (Event m r s f))-acquireEvent backend sel = withRunInIO $ \runInIO ->-  pure $-    mkAcquireType-      (runInIO $ newEvent backend sel)-      (release runInIO)-  where-#if MIN_VERSION_resourcet(1,3,0)-    release runInIO ev (ReleaseExceptionWith e) = runInIO $ failEvent ev e-#else-    release runInIO ev ReleaseException = runInIO . failEvent ev $ toException AbortException-#endif-    release runInIO ev _ = runInIO $ finalize ev---- | An 'Acquire' variant of 'withSubEvent', usable in a t'Control.Monad.Trans.Resource.MonadResource' with 'allocateAcquire'.------ Prior to @resourcet@ version @1.3.0@, exceptional exit will 'failEvent' with 'AbortException'.-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 (Event {..}) sel = do-  childAcq <- acquireEvent backend sel-  withRunInIO $ \runInIO -> pure $ do-    child <- childAcq-    liftIO . runInIO . addParent child $ referenceImpl impl-    pure child---- | An 'EventBackend' where every otherwise parentless event will be marked--- as a child of the given 'Event'.-subEventBackend ::-  (Monad m) =>-  -- | Bring selectors from the new backend into the parent event's backend.-  ---  -- Use 'id' here plus 'narrowEventBackend'' if you need a more general mapping-  -- between selector types.-  (forall f'. s f' -> t f') ->-  -- | The parent event.-  Event m r t f ->-  EventBackend m r s-subEventBackend inj Event {..} =-  narrowEventBackend inj $-    modifyEventBackend (setAncestor $ referenceImpl impl) backend+  (BackendEvent em r f -> em r s a) ->+  em r s a+withBackendEvent = generalWith . allocateBackendEvent --- | An 'EventBackend' where every otherwise causeless event will be marked--- as caused by the given 'Event'.-causedEventBackend ::-  (Monad m) =>-  -- | Bring selectors from the new backend into the causing event's backend.-  ---  -- Use 'id' here plus 'narrowEventBackend'' if you need a more general mapping-  -- between selector types.-  (forall f'. s f' -> t f') ->-  -- | The causing event.-  Event m r t f ->-  EventBackend m r s-causedEventBackend inj Event {..} =-  narrowEventBackend inj $-    modifyEventBackend (setInitialCause $ referenceImpl impl) backend+-- | A 'BackendMonad' variant of 'newEvent''+newBackendEvent :: (MonadEvent em) => forall f. s f -> em r s (BackendEvent em r f)+newBackendEvent sel = do+  b <- backend+  liftBackendMonad $ Explicit.newEvent b sel

@@ -1,9 +1,8 @@ {-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-}  -- | -- Description : Interface for implementing EventBackends@@ -13,34 +12,109 @@ -- -- This is the primary module needed to write new 'EventBackend's. module Observe.Event.Backend-  ( EventBackend (..),-    EventImpl (..),+  ( -- * Core interface+    EventBackend (..),+    Event (..),+    Reference (..),+    ReferenceType (..),++    -- * Backend composition     unitEventBackend,     pairEventBackend,+    noopEventBackend,++    -- * Backend transformation     hoistEventBackend,-    hoistEventImpl,+    hoistEvent,+    InjectSelector,+    injectSelector,+    idInjectSelector,     narrowEventBackend,-    narrowEventBackend',--    -- * OnceFlags--    -- | Generic helper to make operations idempotent.-    OnceFlag (..),-    FlagState (..),-    runOnce,-    hoistOnceFlag,-    alwaysNewOnceFlag,-    newOnceFlagMVar,+    setDefaultReferenceEventBackend,+    setAncestorEventBackend,+    setInitialCauseEventBackend,+    setReferenceEventBackend,+    setParentEventBackend,+    setProximateEventBackend,   ) where  import Control.Exception+import Control.Monad import Control.Monad.Primitive import Data.Functor import Data.Primitive.MVar --- | A backend for creating t'Observe.Event.Event's.+-- | An instrumentation event. --+-- 'Event's are the core of the instrumenting user's interface+-- to eventuo11y. Typical usage would be to create an 'Event'+-- using v'Observe.Event.withEvent' 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'.+-- [@f@]: The type of fields on this event. See 'addField'.+data Event m r f = Event+  { -- | Obtain a reference to an 'Event'.+    --+    -- References are used to link 'Event's together, via 'addReference'.+    --+    -- References can live past when an event has been 'finalize'd.+    --+    -- 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 :: !r,+    -- | 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 [DynamicField](https://hackage.haskell.org/package/eventuo11y-json/docs/Observe-Event-Dynamic.html#t:DynamicField)+    -- for a generic option).+    addField :: !(f -> m ()),+    -- | Relate another 'Event' to this 'Event' in the specified way+    addReference :: !(Reference r -> m ()),+    -- | Mark an 'Event' as finished, perhaps due to an 'Exception'.+    --+    -- In normal usage, this should be automatically called via the use of+    -- the [resource-safe event allocation functions](Observe-Event.html#g:resourcesafe).+    --+    -- This is a no-op if the 'Event' has already been 'finalize'd.+    -- As a result, it is likely pointless to call+    -- 'addField' or 'addReference' (or v'Observe.Event.addParent' / v'Observe.Event.addProximate')+    -- after this call, though it still may be reasonable to call 'reference'.+    finalize :: !(Maybe SomeException -> m ())+  }++-- | Hoist an 'Event' along a given natural transformation into a new monad.+hoistEvent :: (forall x. m x -> n x) -> Event m r f -> Event n r f+hoistEvent nt ev =+  ev+    { addField = nt . addField ev,+      addReference = nt . addReference ev,+      finalize = nt . finalize ev+    }++-- | Ways in which 'Event's can 'Reference' each other.+data ReferenceType+  = -- | The 'Reference'd 'Event' is a parent of this 'Event'.+    Parent+  | -- | The 'Reference'd 'Event' is a proximate cause of this 'Event'.+    Proximate+  deriving stock (Eq)++-- | A reference to another 'Event'+data Reference r = Reference !ReferenceType !r++-- | A backend for creating t'Event's.+-- -- Different 'EventBackend's will be used to emit instrumentation to -- different systems. Multiple backends can be combined with -- 'Observe.Event.pairEventBackend'.@@ -64,33 +138,31 @@ -- -- 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).+-- (but see [DynamicEventSelector](https://hackage.haskell.org/package/eventuo11y-json/docs/Observe-Event-Dynamic.html#t:DynamicEventSelector) for a generic option). -- -- Implementations must ensure that 'EventBackend's and their underlying t'Observe.Event.Event's -- are safe to use across threads. -- -- [@m@]: The monad we're instrumenting in. -- [@r@]: The type of event references used in this 'EventBackend'. See 'Observe.Event.reference'.--- [@s@]: The type of event selectors.-data EventBackend m r s = EventBackend-  { -- | Create a new 'EventImpl' corresponding to the given selector.-    newEventImpl :: !(forall f. s f -> m (EventImpl m r f)),-    -- | Allocate a new 'OnceFlag' in our monad.-    newOnceFlag :: !(m (OnceFlag m))-  }---- | The internal implementation of an t'Observe.Event.Event'.------ All fields have corresponding [event manipulation functions](Observe-Event.html#g:eventmanip),--- except that 'finalizeImpl' and 'failImpl' can assume that they will only ever be called--- once (i.e., 'EventImpl' implementations do __not__ have to implement locking internally).-data EventImpl m r f = EventImpl-  { referenceImpl :: !r,-    addFieldImpl :: !(f -> m ()),-    addParentImpl :: !(r -> m ()),-    addProximateImpl :: !(r -> m ()),-    finalizeImpl :: !(m ()),-    failImpl :: !(SomeException -> m ())+-- [@s@]: The type of event selectors. See 'newEvent'.+newtype EventBackend m r s = EventBackend+  { -- | 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 [DynamicEventSelector](https://hackage.haskell.org/package/eventuo11y-json/docs/Observe-Event-Dynamic.html#t:DynamicEventSelector) for a generic option).+    --+    -- Consider the [resource-safe event allocation functions](Observe-Event.html#g:resourcesafe) instead+    -- of calling this directly.+    newEvent ::+      forall f.+      -- The event selector.+      s f ->+      m (Event m r f)   }  -- | A no-op 'EventBackend'.@@ -100,20 +172,7 @@ -- -- 'unitEventBackend' is the algebraic unit of 'pairEventBackend'. unitEventBackend :: Applicative m => EventBackend m () s-unitEventBackend =-  EventBackend-    { newEventImpl = \_ ->-        pure $-          EventImpl-            { referenceImpl = (),-              addFieldImpl = const $ pure (),-              addParentImpl = const $ pure (),-              addProximateImpl = const $ pure (),-              finalizeImpl = pure (),-              failImpl = const $ pure ()-            },-      newOnceFlag = pure alwaysNewOnceFlag-    }+unitEventBackend = noopEventBackend ()  -- | An 'EventBackend' which sequentially generates 'Observe.Event.Event's in the two given 'EventBackend's. --@@ -122,143 +181,139 @@ pairEventBackend :: Applicative m => EventBackend m a s -> EventBackend m b s -> EventBackend m (a, b) s pairEventBackend x y =   EventBackend-    { newEventImpl = \sel -> do-        xImpl <- newEventImpl x sel-        yImpl <- newEventImpl y sel+    { newEvent = \sel -> do+        xEv <- newEvent x sel+        yEv <- newEvent y sel         pure $-          EventImpl-            { referenceImpl = (referenceImpl xImpl, referenceImpl yImpl),-              addFieldImpl = \f -> addFieldImpl xImpl f *> addFieldImpl yImpl f,-              addParentImpl = \(px, py) -> addParentImpl xImpl px *> addParentImpl yImpl py,-              addProximateImpl = \(px, py) -> addProximateImpl xImpl px *> addProximateImpl yImpl py,-              finalizeImpl = finalizeImpl xImpl *> finalizeImpl yImpl,-              failImpl = \e -> failImpl xImpl e *> failImpl yImpl e-            },-      newOnceFlag = do-        xOnce <- newOnceFlag x-        yOnce <- newOnceFlag y+          Event+            { reference = (reference xEv, reference yEv),+              addField = \f -> addField xEv f *> addField yEv f,+              addReference = \(Reference ty (rx, ry)) ->+                addReference xEv (Reference ty rx) *> addReference yEv (Reference ty ry),+              finalize = \me -> finalize xEv me *> finalize yEv me+            }+    }++-- | A no-op 'EventBackend' that can be integrated with other backends.+--+-- This can be used to purposefully ignore instrumentation from some call.+--+-- All events will have the given reference, so can be connected to appropriate+-- events in non-no-op backends, but not in a way that can distinguish between+-- different events from the same no-op backend.+noopEventBackend :: Applicative m => r -> EventBackend m r s+noopEventBackend r =+  EventBackend+    { newEvent = \_ ->         pure $-          OnceFlag $ do-            xSet <- checkAndSet xOnce-            ySet <- checkAndSet yOnce-            pure $ case (xSet, ySet) of-              (NewlySet, NewlySet) -> NewlySet-              _ -> AlreadySet+          Event+            { reference = r,+              addField = const $ pure (),+              addReference = const $ pure (),+              finalize = const $ pure ()+            }     }  -- | Hoist an 'EventBackend' along a given natural transformation into a new monad. hoistEventBackend ::-  (Functor m, Functor n) =>-  -- | Natural transformation from @m@ to @n@.+  (Functor m) =>   (forall x. m x -> n x) ->   EventBackend m r s ->   EventBackend n r s hoistEventBackend nt backend =   EventBackend-    { newEventImpl = nt . fmap (hoistEventImpl nt) . newEventImpl backend,-      newOnceFlag = hoistOnceFlag nt <$> (nt $ newOnceFlag backend)+    { newEvent = nt . fmap (hoistEvent nt) . newEvent backend     } --- | Hoist an 'EventImpl' along a given natural transformation into a new monad.-hoistEventImpl :: (forall x. m x -> n x) -> EventImpl m r f -> EventImpl n r f-hoistEventImpl nt (EventImpl {..}) =-  EventImpl-    { referenceImpl,-      addFieldImpl = nt . addFieldImpl,-      addParentImpl = nt . addParentImpl,-      addProximateImpl = nt . addProximateImpl,-      finalizeImpl = nt finalizeImpl,-      failImpl = nt . failImpl-    }+-- | Inject a narrower selector and its fields into a wider selector.+--+-- See 'injectSelector' for a simple way to construct one of these.+type InjectSelector s t = forall f. s f -> forall a. (forall g. t g -> (f -> g) -> a) -> a +-- | Construct an 'InjectSelector' with a straightforward injection from @s@ to @t@+injectSelector :: (forall f. s f -> t f) -> InjectSelector s t+injectSelector inj sel withInjField = withInjField (inj sel) id++-- | The identity 'InjectSelector'+idInjectSelector :: InjectSelector s s+idInjectSelector s go = go s id+ -- | 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) ->+  InjectSelector s t ->   EventBackend m r t ->   EventBackend m r s-narrowEventBackend inj =-  narrowEventBackend'-    (\sel withInjField -> withInjField (inj sel) id)+narrowEventBackend inj backend =+  EventBackend+    { newEvent = \sel -> inj sel \sel' injField ->+        newEvent backend sel' <&> \ev ->+          ev+            { addField = addField ev . injField+            }+    } --- | Narrow an 'EventBackend' to a new selector type via a given injection function.+-- | Transform an 'EventBackend' so all of its 'Event's have a given 'Reference'. ----- 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' inj backend =+-- You likely want 'setDefaultReferenceEventBackend', if your monad supports it.+setReferenceEventBackend :: (Monad m) => Reference r -> EventBackend m r s -> EventBackend m r s+setReferenceEventBackend r backend =   EventBackend-    { newEventImpl = \sel -> inj sel \sel' injField ->-        newEventImpl backend sel' <&> \case-          EventImpl {..} ->-            EventImpl-              { addFieldImpl = addFieldImpl . injField,-                ..-              },-      newOnceFlag = newOnceFlag backend+    { newEvent = \sel -> do+        ev <- newEvent backend sel+        addReference ev r+        pure ev     } --- | The state of a 'OnceFlag'-data FlagState-  = -- | The flag was not set, but is now-    NewlySet-  | -- | The flag was already set-    AlreadySet---- | A flag to ensure only one operation from some class is performed, once.+-- | Transform an 'EventBackend' so all of its 'Event's have a given parent. ----- Typically consumed via 'runOnce'-newtype OnceFlag m = OnceFlag-  { -- | Get the state of the 'OnceFlag', and set the flag.-    ---    -- This operation should be atomic, and ideally would only-    -- return 'NewlySet' once. In monads that don't support it,-    -- at a minimum it must be monotonic (once one caller gets-    -- 'AlreadySet', all callers will).-    checkAndSet :: m FlagState-  }+-- You likely want 'setAncestorEventBackend', if your monad supports it.+setParentEventBackend :: (Monad m) => r -> EventBackend m r s -> EventBackend m r s+setParentEventBackend = setReferenceEventBackend . Reference Parent --- | Run an operation if no other operations using this--- 'OnceFlag' have run.-runOnce :: (Monad m) => OnceFlag m -> m () -> m ()-runOnce f go =-  checkAndSet f >>= \case-    NewlySet -> go-    AlreadySet -> pure ()+-- | Transform an 'EventBackend' so all of its 'Event's have a given proximate cause.+--+-- You likely want 'setInitialCauseEventBackend', if your monad supports it.+setProximateEventBackend :: (Monad m) => r -> EventBackend m r s -> EventBackend m r s+setProximateEventBackend = setReferenceEventBackend . Reference Proximate --- | A 'OnceFlag' using an 'MVar'.-newOnceFlagMVar :: (PrimMonad m) => m (OnceFlag m)-newOnceFlagMVar = do-  flag <- newEmptyMVar-  pure $-    OnceFlag $-      tryPutMVar flag () <&> \case-        False -> AlreadySet-        True -> NewlySet+-- | Transform an 'EventBackend' so all of its 'Event's have a given 'Reference', if they+-- haven't been given a 'Reference' of the same 'ReferenceType' by the time they are 'finalize'd.+--+-- See 'setReferenceEventBackend' if the 'Reference' should be applied unconditionally.+setDefaultReferenceEventBackend :: (PrimMonad m) => Reference r -> EventBackend m r s -> EventBackend m r s+setDefaultReferenceEventBackend ref@(Reference ty _) backend =+  EventBackend+    { newEvent = \sel -> do+        flag <- newEmptyMVar+        ev <- newEvent backend sel+        pure $+          ev+            { addReference = \ref'@(Reference ty' _) -> do+                when (ty' == ty) . void $ tryPutMVar flag ()+                addReference ev ref',+              finalize = \me -> do+                tryPutMVar flag () >>= \case+                  False -> pure ()+                  True -> addReference ev ref+                finalize ev me+            }+    } --- | A 'OnceFlag' which is always 'NewlySet'.+-- | Transform an 'EventBackend' so all of its 'Event's have a given parent, if they+-- are not given another parent by the time they are 'finalize'd. ----- Only safe to use if the operations to be guarded--- by the flag are already idempotent.-alwaysNewOnceFlag :: (Applicative m) => OnceFlag m-alwaysNewOnceFlag = OnceFlag $ pure NewlySet+-- See 'setParentEventBackend' if the parent should be set unconditionally.+setAncestorEventBackend :: (PrimMonad m) => r -> EventBackend m r s -> EventBackend m r s+setAncestorEventBackend = setDefaultReferenceEventBackend . Reference Parent --- | Hoist a 'OnceFlag' along a given natural transformation into a new monad.-hoistOnceFlag ::-  -- | Natural transformation from @f@ to @g@-  (forall x. f x -> g x) ->-  OnceFlag f ->-  OnceFlag g-hoistOnceFlag nt (OnceFlag cs) = OnceFlag (nt cs)+-- | Transform an 'EventBackend' so all of its 'Event's have a given proximate cause,+-- if they are not given another proximate cause by the time they are 'finalize'd.+--+-- See 'setProximateEventBackend' if the proximate cause should be set unconditionally.+setInitialCauseEventBackend :: (PrimMonad m) => r -> EventBackend m r s -> EventBackend m r s+setInitialCauseEventBackend = setDefaultReferenceEventBackend . Reference Proximate

@@ -1,158 +0,0 @@-{-# 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 = Nil-  Nil . f = f-  (Cons hd tl) . f = Cons hd (tl . 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 Nil backend = backend-modifyEventBackend (Cons Silence _) _ = unitEventBackend-modifyEventBackend (Cons (SetAncestor parent) rest) backend' =-  EventBackend-    { newEventImpl = \sel -> do-        EventImpl {..} <- newEventImpl backend sel-        parentAdded <- newOnceFlag backend-        pure $-          EventImpl-            { addParentImpl = \r -> do-                _ <- checkAndSet parentAdded-                addParentImpl r,-              finalizeImpl = do-                runOnce parentAdded (addParentImpl parent)-                finalizeImpl,-              failImpl = \e -> do-                runOnce parentAdded (addParentImpl parent)-                failImpl e,-              ..-            },-      newOnceFlag = newOnceFlag backend-    }-  where-    backend = modifyEventBackend rest backend'-modifyEventBackend (Cons (SetInitialCause proximate) rest) backend' =-  EventBackend-    { newEventImpl = \sel -> do-        EventImpl {..} <- newEventImpl backend sel-        proximateAdded <- newOnceFlag backend-        pure $-          EventImpl-            { addProximateImpl = \r -> do-                _ <- checkAndSet proximateAdded-                addParentImpl r,-              finalizeImpl = do-                runOnce proximateAdded (addProximateImpl proximate)-                finalizeImpl,-              failImpl = \e -> do-                runOnce proximateAdded (addProximateImpl proximate)-                failImpl e,-              ..-            },-      newOnceFlag = newOnceFlag backend-    }-  where-    backend = modifyEventBackend rest backend'---- | A single-element 'EventBackendModifiers'-singleton :: EventBackendModifier r r' -> EventBackendModifiers r r'-singleton = flip Cons Nil---- | An 'EventBackendModifiers' that does nothing.-unmodified :: EventBackendModifiers r r-unmodified = id---- | An 'EventBackendModifiers' that silences events.-silence :: EventBackendModifiers r ()-silence = singleton Silence---- | An 'EventBackendModifiers' that marks every parentless event as the child--- of a known t'Observe.Event.Event'.-setAncestor :: r -> EventBackendModifiers r r-setAncestor = singleton . SetAncestor---- | An 'EventBackendModifiers' that marks every causeless event as proximately caused--- by a known t'Observe.Event.Event'.-setInitialCause :: r -> EventBackendModifiers r r-setInitialCause = singleton . SetInitialCause

@@ -0,0 +1,248 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneKindSignatures #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Description : Typeclass for implicit 'EventBackend' passing+-- Copyright   : Copyright 2022 Shea Levy.+-- License     : Apache-2.0+-- Maintainer  : shea@shealevy.com+--+-- Core typeclass for an mtl-style handling of 'EventBackend's.+-- See "Observe.Event.Explicit" for an explicit, function-based+-- interface.+module Observe.Event.Class+  ( MonadEvent (..),+    EnvBackend,+    TransEventMonad (..),++    -- * EventT+    EventT (..),+    runEventT,+    eventLift,++    -- * Kind aliases+    EventMonadKind,+    ReferenceKind,+    SelectorKind,+    FunctorKind,+  )+where++import Control.Applicative+import Control.Monad+import Control.Monad.Allocate+import Control.Monad.Base+import Control.Monad.Catch+import Control.Monad.Cont.Class+import Control.Monad.Error.Class+import Control.Monad.IO.Unlift+import Control.Monad.Primitive+import Control.Monad.Reader+import Control.Monad.State.Class+import Control.Monad.Trans.Control+import Control.Monad.With+import Control.Monad.Writer.Class+import Control.Monad.Zip+import Control.Natural.Control+import Data.Coerce+import Data.Functor+import Data.Functor.Contravariant+import Data.GeneralAllocate+import Data.Kind+import Observe.Event.Backend++-- | Monads suitable for 'Event'-based instrumentation, with implicit 'EventBackend' management.+--+-- See "Observe.Event.Explicit" for 'Event'-based instrumentation with explicit 'EventBackend'+-- passing.+--+-- Note that @em@ is an indexed monad of 'EventMonadKind'.+type MonadEvent :: EventMonadKind -> Constraint+class (forall r s. Monad (em r s), Monad (BackendMonad em)) => MonadEvent em where+  -- | The monad of the implicitly carried 'EventBackend'+  type BackendMonad em :: Type -> Type++  -- |+  liftBackendMonad :: BackendMonad em a -> em r s a++  -- | Access the implicitly carried 'EventBackend'+  backend :: em r s (EnvBackend em r s)++  -- | Run an instrumented action with a modified 'EventBackend'+  withModifiedBackend ::+    -- | Modify the 'EventBackend'+    --+    -- Note that the modification may change+    -- the reference and selector types.+    (EnvBackend em r s -> EnvBackend em r' s') ->+    -- | Action to run with the modified backend available.+    em r' s' a ->+    em r s a++-- | The type of the implicit 'EventBackend' of a 'MonadEvent'+type EnvBackend :: EventMonadKind -> ReferenceKind -> SelectorKind -> Type+type EnvBackend em = EventBackend (BackendMonad em)++-- | Make a monad into a 'MonadEvent'.+newtype EventT m r s a = EventT (ReaderT (EventBackend m r s) m a)+  deriving newtype+    ( Functor,+      Applicative,+      Monad,+      MonadError e,+      MonadState s',+      MonadWriter w,+      MonadFail,+      MonadFix,+      MonadIO,+      MonadZip,+      Contravariant,+      Alternative,+      MonadPlus,+      MonadCont,+      MonadUnliftIO,+      MonadBase b,+      MonadBaseControl b,+      MonadAllocate,+      MonadCatch,+      MonadThrow,+      MonadMask,+      PrimMonad+    )++-- | Run an 'EventT' with an initial 'EventBackend'.+runEventT :: (Monad m) => EventT m r s a -> EventBackend m r s -> m a+runEventT = coerce++-- | Lift @m@ into 'EventT' @m@.+eventLift :: forall m r s. Applicative m => StatelessControlTransformation m (EventT m r s)+eventLift = statelessControlTransformation $ \useRunInM ->+  coerce @(EventBackend m r s -> _) $ \b -> useRunInM $ flip coerce b++instance MonadReader r m => MonadReader r (EventT m ref s) where+  ask = toNatural eventLift ask+  local modR go = statelessTransWith eventLift $ \runInM ->+    local modR (runInM go)+  reader = toNatural eventLift . reader++instance (MonadWith m) => MonadWith (EventT m r s) where+  type WithException (EventT m r s) = WithException m+  stateThreadingGeneralWith ::+    forall a b releaseReturn.+    GeneralAllocate (EventT m r s) (WithException m) releaseReturn b a ->+    (a -> EventT m r s b) ->+    EventT m r s (b, releaseReturn)+  stateThreadingGeneralWith (GeneralAllocate allocA) go = coerce $ \b -> do+    let allocA' :: (forall x. m x -> m x) -> m (GeneralAllocated m (WithException m) releaseReturn b a)+        allocA' restore = do+          let restore' :: forall x. EventT m r s x -> EventT m r s x+              restore' mx = coerce @(EventBackend m r s -> m x) $ restore . coerce @_ @(EventBackend m r s -> _) mx+          GeneralAllocated a releaseA <- coerce (allocA restore') b+          let releaseA' relTy = coerce @(EventT m r s releaseReturn) @(EventBackend m r s -> m releaseReturn) (releaseA relTy) b+          pure $ GeneralAllocated a releaseA'+    stateThreadingGeneralWith (GeneralAllocate allocA') (flip coerce b . go)++instance (Monad m) => MonadEvent (EventT m) where+  type BackendMonad (EventT m) = m+  liftBackendMonad :: forall a r s. m a -> EventT m r s a+  liftBackendMonad = coerce @(EventBackend m r s -> _) . const++  backend :: forall r s. EventT m r s (EventBackend m r s)+  backend = coerce @(EventBackend m r s -> m _) pure++  withModifiedBackend :: forall r s r' s' a. (EventBackend m r s -> EventBackend m r' s') -> EventT m r' s' a -> EventT m r s a+  withModifiedBackend modBackend e'ma =+    let e'ma' :: EventBackend m r' s' -> m a+        e'ma' = coerce e'ma+     in coerce (e'ma' . modBackend)++-- | Apply a 'MonadTrans'former to an 'EventMonadKind' to get a transformed 'EventMonadKind'+--+-- When @t@ is 'MonadTransControl' and @em@ is 'MonadEvent', 'TransEventMonad' @t@ @em@ is+-- 'MonadEvent' and has all of the relevant instances conferred by @t@.+type TransEventMonad :: (FunctorKind -> FunctorKind) -> EventMonadKind -> EventMonadKind+newtype TransEventMonad t em r s a = TransEventMonad {unTransEventMonad :: t (em r s) a}+  deriving newtype+    ( Functor,+      Applicative,+      Monad,+      MonadError e,+      MonadState s',+      MonadWriter w,+      MonadFail,+      MonadFix,+      MonadIO,+      MonadZip,+      Contravariant,+      Alternative,+      MonadPlus,+      MonadCont,+      MonadUnliftIO,+      MonadBase b,+      MonadBaseControl b,+      MonadAllocate,+      MonadCatch,+      MonadThrow,+      MonadMask,+      PrimMonad,+      MonadReader r'+    )++instance MonadWith (t (em r s)) => MonadWith (TransEventMonad t em r s) where+  type WithException (TransEventMonad t em r s) = WithException (t (em r s))+  stateThreadingGeneralWith ::+    forall a b releaseReturn.+    GeneralAllocate (TransEventMonad t em r s) (WithException (t (em r s))) releaseReturn b a ->+    (a -> TransEventMonad t em r s b) ->+    TransEventMonad t em r s (b, releaseReturn)+  stateThreadingGeneralWith (GeneralAllocate allocA) go = coerce $ do+    stateThreadingGeneralWith (GeneralAllocate allocA') $ coerce go+    where+      allocA' :: (forall x. t (em r s) x -> t (em r s) x) -> t (em r s) (GeneralAllocated (t (em r s)) (WithException (t (em r s))) releaseReturn b a)+      allocA' restore =+        coerce (allocA restore') <&> \case+          GeneralAllocated a releaseA -> GeneralAllocated a $ coerce @(GeneralReleaseType (WithException (t (em r s))) b -> TransEventMonad t em r s releaseReturn) releaseA+        where+          restore' :: forall x. TransEventMonad t em r s x -> TransEventMonad t em r s x+          restore' = coerce @(t (em r s) x -> t (em r s) x) restore++instance (MonadEvent em, MonadTransControl t, forall r s. Monad (t (em r s))) => MonadEvent (TransEventMonad t em) where+  type BackendMonad (TransEventMonad t em) = BackendMonad em+  liftBackendMonad :: forall a r s. BackendMonad em a -> TransEventMonad t em r s a+  liftBackendMonad = coerce @(_ -> t (em r s) a) $ lift . liftBackendMonad++  backend :: forall r s. TransEventMonad t em r s (EnvBackend em r s)+  backend = coerce @(t (em r s) _) $ lift backend++  withModifiedBackend :: forall r s r' s' a. (EnvBackend em r s -> EnvBackend em r' s') -> TransEventMonad t em r' s' a -> TransEventMonad t em r s a+  withModifiedBackend modBackend go = coerce @(t (em r s) _) $+    controlT @_ @_ @a $ \runInEm ->+      withModifiedBackend modBackend . runInEm $ coerce @_ @(t (em r' s') a) go++-- | The kind of indexed monads aware of 'Event' instrumentation+--+-- See 'MonadEvent'.+type EventMonadKind = ReferenceKind -> SelectorKind -> FunctorKind++-- | The kind of 'Event' references+type ReferenceKind = Type++-- | The kind of 'Event' selectors+type SelectorKind = Type -> Type++-- | The kind of 'Functor's+type FunctorKind = Type -> Type

@@ -0,0 +1,201 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}++-- |+-- Description : Instrumentation with explicit 'EventBackend' passing+-- Copyright   : Copyright 2022 Shea Levy.+-- License     : Apache-2.0+-- Maintainer  : shea@shealevy.com+--+-- t'Observe.Event.MonadEvent' and 'Observe.Event.EventT'-based instrumentation+-- implicitly track the underlying 'EventBackend' for you. This module is for those+-- who would rather pass around 'EventBackend's explicitly.+module Observe.Event.Explicit+  ( Event,+    hoistEvent,++    -- * Event manipulation #eventmanip#+    addField,+    reference,+    addParent,+    addProximate,+    addReference,+    Reference (..),+    ReferenceType (..),++    -- * Resource-safe event allocation #resourcesafe#+    allocateEvent,+    withEvent,+    withSubEvent,++    -- * 'EventBackend's+    EventBackend,++    -- ** Backend transformation+    subEventBackend,+    causedEventBackend,+    hoistEventBackend,+    narrowEventBackend,+    InjectSelector,+    injectSelector,+    idInjectSelector,+    setDefaultReferenceEventBackend,+    setAncestorEventBackend,+    setInitialCauseEventBackend,+    setReferenceEventBackend,+    setParentEventBackend,+    setProximateEventBackend,++    -- ** Backend composition+    unitEventBackend,+    pairEventBackend,+    noopEventBackend,++    -- * Primitive 'Event' resource management.++    -- | Prefer the [resource-safe event allocation functions](#g:resourcesafe)+    -- to these when possible.+    finalize,+    newEvent,+    newSubEvent,+  )+where++import Control.Monad.Primitive+import Control.Monad.With+import Data.Exceptable+import Data.GeneralAllocate+import Observe.Event.Backend++-- | Mark another 'Event' as a parent of this 'Event'.+addParent ::+  Event m r f ->+  r ->+  m ()+addParent ev = addReference ev . Reference Parent++-- | Mark another 'Event' as a proximate cause of this 'Event'.+addProximate ::+  Event m r f ->+  r ->+  m ()+addProximate ev = addReference ev . Reference Proximate++-- | Allocate 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 [DynamicEventSelector](https://hackage.haskell.org/package/eventuo11y-json/docs/Observe-Event-Dynamic.html#t:DynamicEventSelector) for a generic option).+--+-- The 'Event' is automatically 'finalize'd on release.+allocateEvent ::+  (Monad m, Exceptable e) =>+  EventBackend m r s ->+  forall f.+  s f ->+  GeneralAllocate m e () releaseArg (Event m r f)+allocateEvent backend sel = GeneralAllocate $ \restore -> do+  ev <- restore $ newEvent backend sel+  let release (ReleaseFailure e) = finalize ev . Just $ toSomeException e+      release (ReleaseSuccess _) = finalize ev Nothing+  pure $ GeneralAllocated ev release++-- | 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 [DynamicEventSelector](https://hackage.haskell.org/package/eventuo11y-json/docs/Observe-Event-Dynamic.html#t:DynamicEventSelector) for a generic option).+--+-- Consider the [resource-safe event allocation functions](#g:resourcesafe) instead+-- of calling this directly.+newSubEvent ::+  (Monad m) =>+  EventBackend m r s ->+  -- | The parent event.+  Event m r f ->+  forall f'.+  -- | The child event selector.+  s f' ->+  m (Event m r f')+newSubEvent backend ev sel = do+  child <- newEvent backend sel+  addParent child $ reference ev+  pure 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 [DynamicEventSelector](https://hackage.haskell.org/package/eventuo11y-json/docs/Observe-Event-Dynamic.html#t:DynamicEventSelector) for a generic option).+--+-- The 'Event' is automatically 'finalize'd at the end of the function it's passed to.+withEvent ::+  (MonadWithExceptable m) =>+  EventBackend m r s ->+  forall f.+  -- | The event selector.+  s f ->+  (Event m r f -> m a) ->+  m a+withEvent backend = generalWith . allocateEvent backend++-- | 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 [DynamicEventSelector](https://hackage.haskell.org/package/eventuo11y-json/docs/Observe-Event-Dynamic.html#t:DynamicEventSelector) for a generic option).+--+-- The 'Event' is automatically 'finalize'd at the end of the function it's passed to.+withSubEvent ::+  (MonadWithExceptable m) =>+  EventBackend m r s ->+  -- | The parent 'Event'.+  Event m r f ->+  forall f'.+  -- | The child event selector.+  s f' ->+  (Event m r f' -> m a) ->+  m a+withSubEvent backend ev sel go = withEvent backend sel $ \child -> do+  addParent child $ reference ev+  go child++-- | An 'EventBackend' where every otherwise parentless event will be marked+-- as a child of the given 'Event'.+subEventBackend ::+  (PrimMonad m) =>+  -- | Bring selectors from the new backend into the parent event's backend.+  InjectSelector s t ->+  -- | The parent event.+  Event m r f ->+  EventBackend m r t ->+  EventBackend m r s+subEventBackend inj ev =+  narrowEventBackend inj+    . setAncestorEventBackend (reference ev)++-- | An 'EventBackend' where every otherwise causeless event will be marked+-- as caused by the given 'Event'.+causedEventBackend ::+  (PrimMonad m) =>+  -- | Bring selectors from the new backend into the causing event's backend.+  InjectSelector s t ->+  -- | The causing event.+  Event m r f ->+  EventBackend m r t ->+  EventBackend m r s+causedEventBackend inj ev =+  narrowEventBackend inj+    . setInitialCauseEventBackend (reference ev)