diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/Example.hs b/Example.hs deleted file mode 100644 --- a/Example.hs +++ /dev/null @@ -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 diff --git a/eventuo11y.cabal b/eventuo11y.cabal --- a/eventuo11y.cabal +++ b/eventuo11y.cabal @@ -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 diff --git a/src/Control/Monad/Cleanup.hs b/src/Control/Monad/Cleanup.hs deleted file mode 100644 --- a/src/Control/Monad/Cleanup.hs +++ /dev/null @@ -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) diff --git a/src/Control/Natural/Control.hs b/src/Control/Natural/Control.hs new file mode 100644 --- /dev/null +++ b/src/Control/Natural/Control.hs @@ -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) diff --git a/src/Observe/Event.hs b/src/Observe/Event.hs --- a/src/Observe/Event.hs +++ b/src/Observe/Event.hs @@ -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 diff --git a/src/Observe/Event/Backend.hs b/src/Observe/Event/Backend.hs --- a/src/Observe/Event/Backend.hs +++ b/src/Observe/Event/Backend.hs @@ -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 diff --git a/src/Observe/Event/BackendModification.hs b/src/Observe/Event/BackendModification.hs deleted file mode 100644 --- a/src/Observe/Event/BackendModification.hs +++ /dev/null @@ -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 diff --git a/src/Observe/Event/Class.hs b/src/Observe/Event/Class.hs new file mode 100644 --- /dev/null +++ b/src/Observe/Event/Class.hs @@ -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 diff --git a/src/Observe/Event/Explicit.hs b/src/Observe/Event/Explicit.hs new file mode 100644 --- /dev/null +++ b/src/Observe/Event/Explicit.hs @@ -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)