{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

-- |
-- Copyright: © 2018-2020 IOHK
-- License: Apache-2.0
--
-- This module contains utility functions for logging and mapping trace data.

module Cardano.Wallet.Logging
    ( -- * Conversions from BM framework
      trMessage
    , trMessageText

      -- * Formatting typed messages as plain text
    , transformTextTrace
    , stdoutTextTracer

      -- * Logging helpers
    , traceWithExceptT
    , traceResult
    , formatResultMsg
    , formatResultMsgWith
    , resultSeverity

      -- * Logging and timing IO actions
    , BracketLog
    , BracketLog' (..)
    , LoggedException (..)
    , bracketTracer
    , bracketTracer'
    , produceTimings

      -- * Tracer conversions
    , unliftIOTracer
    , flatContramapTracer
    ) where

import Prelude

import Cardano.BM.Data.LogItem
    ( LOContent (..), LogObject (..), LoggerName, mkLOMeta )
import Cardano.BM.Data.Severity
    ( Severity (..) )
import Cardano.BM.Data.Tracer
    ( HasPrivacyAnnotation (..)
    , HasSeverityAnnotation (..)
    , Transformable (..)
    )
import Cardano.BM.Trace
    ( Trace )
import Control.DeepSeq
    ( NFData (..) )
import Control.Monad
    ( when )
import Control.Monad.Catch
    ( MonadMask )
import Control.Monad.IO.Unlift
    ( MonadIO (..), MonadUnliftIO )
import Control.Monad.Trans.Except
    ( ExceptT (..), runExceptT )
import Control.Tracer
    ( Tracer (..), contramap, natTracer, nullTracer, traceWith )
import Control.Tracer.Transformers.ObserveOutcome
    ( Outcome (..)
    , OutcomeFidelity (..)
    , OutcomeProgressionStatus (..)
    , mkOutcomeExtractor
    )
import Data.Aeson
    ( ToJSON (..), Value (Null), object, (.=) )
import Data.Functor
    ( ($>) )
import Data.Text
    ( Text )
import Data.Text.Class
    ( ToText (..) )
import Data.Time.Clock
    ( DiffTime )
import Data.Time.Clock.System
    ( getSystemTime, systemToTAITime )
import Data.Time.Clock.TAI
    ( AbsoluteTime, diffAbsoluteTime )
import Fmt
    ( Buildable (..), Builder, blockListF, blockMapF, nameF )
import GHC.Exts
    ( IsList (..) )
import GHC.Generics
    ( Generic )
import UnliftIO.Exception
    ( Exception (..)
    , SomeException (..)
    , displayException
    , isSyncException
    , withException
    )

import qualified Data.ByteString.Char8 as B8
import qualified Data.Text.Encoding as T

-- | Converts a 'Text' trace into any other type of trace that has a 'ToText'
-- instance.
transformTextTrace :: ToText a => Trace IO Text -> Trace IO a
transformTextTrace :: Trace IO Text -> Trace IO a
transformTextTrace = ((Text, LogObject a) -> (Text, LogObject Text))
-> Trace IO Text -> Trace IO a
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap ((LogObject a -> LogObject Text)
-> (Text, LogObject a) -> (Text, LogObject Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((LogObject a -> LogObject Text)
 -> (Text, LogObject a) -> (Text, LogObject Text))
-> ((a -> Text) -> LogObject a -> LogObject Text)
-> (a -> Text)
-> (Text, LogObject a)
-> (Text, LogObject Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Text) -> LogObject a -> LogObject Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> Text) -> (Text, LogObject a) -> (Text, LogObject Text))
-> (a -> Text) -> (Text, LogObject a) -> (Text, LogObject Text)
forall a b. (a -> b) -> a -> b
$ a -> Text
forall a. ToText a => a -> Text
toText) (Trace IO Text -> Trace IO a)
-> (Trace IO Text -> Trace IO Text) -> Trace IO Text -> Trace IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Trace IO Text -> Trace IO Text
forall (m :: * -> *) a.
(Monad m, Monoid a, Eq a) =>
Trace m a -> Trace m a
filterNonEmpty

-- | Tracer transformer which transforms traced items to their 'ToText'
-- representation and further traces them as a 'LogObject'. If the 'ToText'
-- representation is empty, then no tracing happens.
trMessageText
    :: (MonadIO m, ToText a, HasPrivacyAnnotation a, HasSeverityAnnotation a)
    => Tracer m (LoggerName, LogObject Text)
    -> Tracer m a
trMessageText :: Tracer m (Text, LogObject Text) -> Tracer m a
trMessageText Tracer m (Text, LogObject Text)
tr = (a -> m ()) -> Tracer m a
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer ((a -> m ()) -> Tracer m a) -> (a -> m ()) -> Tracer m a
forall a b. (a -> b) -> a -> b
$ \a
arg -> do
   let msg :: Text
msg = a -> Text
forall a. ToText a => a -> Text
toText a
arg
       tracer :: Tracer m (Text, LogObject Text)
tracer = if Text
msg Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
forall a. Monoid a => a
mempty then Tracer m (Text, LogObject Text)
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer else Tracer m (Text, LogObject Text)
tr
   LOMeta
meta <- Severity -> PrivacyAnnotation -> m LOMeta
forall (m :: * -> *).
MonadIO m =>
Severity -> PrivacyAnnotation -> m LOMeta
mkLOMeta (a -> Severity
forall a. HasSeverityAnnotation a => a -> Severity
getSeverityAnnotation a
arg) (a -> PrivacyAnnotation
forall a. HasPrivacyAnnotation a => a -> PrivacyAnnotation
getPrivacyAnnotation a
arg)
   Tracer m (Text, LogObject Text) -> (Text, LogObject Text) -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (Text, LogObject Text)
tracer (Text
forall a. Monoid a => a
mempty, Text -> LOMeta -> LOContent Text -> LogObject Text
forall a. Text -> LOMeta -> LOContent a -> LogObject a
LogObject Text
forall a. Monoid a => a
mempty LOMeta
meta (Text -> LOContent Text
forall a. a -> LOContent a
LogMessage Text
msg))

-- | Tracer transformer which converts 'Trace m a' to 'Tracer m a' by wrapping
-- typed log messages into a 'LogObject'.
trMessage
    :: (MonadIO m, HasPrivacyAnnotation a, HasSeverityAnnotation a)
    => Tracer m (LoggerName, LogObject a)
    -> Tracer m a
trMessage :: Tracer m (Text, LogObject a) -> Tracer m a
trMessage Tracer m (Text, LogObject a)
tr = (a -> m ()) -> Tracer m a
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer ((a -> m ()) -> Tracer m a) -> (a -> m ()) -> Tracer m a
forall a b. (a -> b) -> a -> b
$ \a
arg -> do
   LOMeta
meta <- Severity -> PrivacyAnnotation -> m LOMeta
forall (m :: * -> *).
MonadIO m =>
Severity -> PrivacyAnnotation -> m LOMeta
mkLOMeta (a -> Severity
forall a. HasSeverityAnnotation a => a -> Severity
getSeverityAnnotation a
arg) (a -> PrivacyAnnotation
forall a. HasPrivacyAnnotation a => a -> PrivacyAnnotation
getPrivacyAnnotation a
arg)
   Tracer m (Text, LogObject a) -> (Text, LogObject a) -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (Text, LogObject a)
tr (Text
forall a. Monoid a => a
mempty, Text -> LOMeta -> LOContent a -> LogObject a
forall a. Text -> LOMeta -> LOContent a -> LogObject a
LogObject Text
forall a. Monoid a => a
mempty LOMeta
meta (a -> LOContent a
forall a. a -> LOContent a
LogMessage a
arg))

instance forall m a. (MonadIO m, ToText a, HasPrivacyAnnotation a, HasSeverityAnnotation a) => Transformable Text m a where
    trTransformer :: TracingVerbosity -> Trace m Text -> Tracer m a
trTransformer TracingVerbosity
_verb = (a -> m ()) -> Tracer m a
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer ((a -> m ()) -> Tracer m a)
-> (Trace m Text -> a -> m ()) -> Trace m Text -> Tracer m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tracer m a -> a -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (Tracer m a -> a -> m ())
-> (Trace m Text -> Tracer m a) -> Trace m Text -> a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Trace m Text -> Tracer m a
forall (m :: * -> *) a.
(MonadIO m, ToText a, HasPrivacyAnnotation a,
 HasSeverityAnnotation a) =>
Tracer m (Text, LogObject Text) -> Tracer m a
trMessageText

-- | Trace transformer which removes empty traces.
filterNonEmpty
    :: forall m a. (Monad m, Monoid a, Eq a)
    => Trace m a
    -> Trace m a
filterNonEmpty :: Trace m a -> Trace m a
filterNonEmpty Trace m a
tr = ((Text, LogObject a) -> m ()) -> Trace m a
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer (((Text, LogObject a) -> m ()) -> Trace m a)
-> ((Text, LogObject a) -> m ()) -> Trace m a
forall a b. (a -> b) -> a -> b
$ \(Text, LogObject a)
arg -> do
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LOContent a -> Bool
forall a. (Eq a, Monoid a) => LOContent a -> Bool
nonEmptyMessage (LOContent a -> Bool) -> LOContent a -> Bool
forall a b. (a -> b) -> a -> b
$ LogObject a -> LOContent a
forall a. LogObject a -> LOContent a
loContent (LogObject a -> LOContent a) -> LogObject a -> LOContent a
forall a b. (a -> b) -> a -> b
$ (Text, LogObject a) -> LogObject a
forall a b. (a, b) -> b
snd (Text, LogObject a)
arg) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
        Trace m a -> (Text, LogObject a) -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Trace m a
tr (Text, LogObject a)
arg
  where
    nonEmptyMessage :: LOContent a -> Bool
nonEmptyMessage (LogMessage a
msg) = a
msg a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
forall a. Monoid a => a
mempty
    nonEmptyMessage LOContent a
_ = Bool
True

-- | Creates a tracer that prints any 'ToText' log message. This is useful for
-- debugging functions in the REPL, when you need a 'Tracer' object.
stdoutTextTracer :: (MonadIO m, ToText a) => Tracer m a
stdoutTextTracer :: Tracer m a
stdoutTextTracer = (a -> m ()) -> Tracer m a
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer ((a -> m ()) -> Tracer m a) -> (a -> m ()) -> Tracer m a
forall a b. (a -> b) -> a -> b
$ IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (a -> IO ()) -> a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> IO ()
B8.putStrLn (ByteString -> IO ()) -> (a -> ByteString) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> (a -> Text) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Text
forall a. ToText a => a -> Text
toText

{-------------------------------------------------------------------------------
                                Logging helpers
-------------------------------------------------------------------------------}

-- | Run an 'ExceptT' action, then trace its result, all in one step.
-- This is a more basic version of 'resultTracer'.
traceWithExceptT :: Monad m => Tracer m (Either e a) -> ExceptT e m a -> ExceptT e m a
traceWithExceptT :: Tracer m (Either e a) -> ExceptT e m a -> ExceptT e m a
traceWithExceptT Tracer m (Either e a)
tr (ExceptT m (Either e a)
action) = m (Either e a) -> ExceptT e m a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either e a) -> ExceptT e m a)
-> m (Either e a) -> ExceptT e m a
forall a b. (a -> b) -> a -> b
$ do
    Either e a
res <- m (Either e a)
action
    Tracer m (Either e a) -> Either e a -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (Either e a)
tr Either e a
res
    Either e a -> m (Either e a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either e a
res

-- | Log around an 'ExceptT' action. The result of the action is captured as an
-- 'Either' in the log message. Other unexpected exceptions are captured in the
-- 'BracketLog''.
traceResult
    :: MonadUnliftIO m
    => Tracer m (BracketLog' (Either e r))
    -> ExceptT e m r
    -> ExceptT e m r
traceResult :: Tracer m (BracketLog' (Either e r))
-> ExceptT e m r -> ExceptT e m r
traceResult Tracer m (BracketLog' (Either e r))
tr = m (Either e r) -> ExceptT e m r
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either e r) -> ExceptT e m r)
-> (ExceptT e m r -> m (Either e r))
-> ExceptT e m r
-> ExceptT e m r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either e r -> Either e r)
-> Tracer m (BracketLog' (Either e r))
-> m (Either e r)
-> m (Either e r)
forall (m :: * -> *) r a.
MonadUnliftIO m =>
(r -> a) -> Tracer m (BracketLog' a) -> m r -> m r
bracketTracer' Either e r -> Either e r
forall a. a -> a
id Tracer m (BracketLog' (Either e r))
tr (m (Either e r) -> m (Either e r))
-> (ExceptT e m r -> m (Either e r))
-> ExceptT e m r
-> m (Either e r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT e m r -> m (Either e r)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT

-- | Format a tracer message from 'traceResult' as multiline text.
formatResultMsg
    :: (Show e, IsList t, Item t ~ (Text, v), Buildable v, Buildable r)
    => Text
    -- ^ Function name.
    -> t
    -- ^ Input parameters.
    -> BracketLog' (Either e r)
    -- ^ Logging around function.
    -> Builder
formatResultMsg :: Text -> t -> BracketLog' (Either e r) -> Builder
formatResultMsg = (e -> Builder)
-> (r -> Builder)
-> Text
-> t
-> BracketLog' (Either e r)
-> Builder
forall t v e r.
(IsList t, Item t ~ (Text, v), Buildable v) =>
(e -> Builder)
-> (r -> Builder)
-> Text
-> t
-> BracketLog' (Either e r)
-> Builder
formatResultMsgWith (Builder -> Builder -> Builder
nameF Builder
"ERROR" (Builder -> Builder) -> (e -> Builder) -> e -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Builder
forall p. Buildable p => p -> Builder
build (String -> Builder) -> (e -> String) -> e -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> String
forall a. Show a => a -> String
show) r -> Builder
forall p. Buildable p => p -> Builder
build

-- | Same as 'formatResultMsg', but accepts result formatters as parameters.
formatResultMsgWith
    :: (IsList t, Item t ~ (Text, v), Buildable v)
    => (e -> Builder)
    -- ^ Error message formatter
    -> (r -> Builder)
    -- ^ Result formatter
    -> Text
    -- ^ Function name.
    -> t
    -- ^ Input parameters.
    -> BracketLog' (Either e r)
    -- ^ Logging around function.
    -> Builder
formatResultMsgWith :: (e -> Builder)
-> (r -> Builder)
-> Text
-> t
-> BracketLog' (Either e r)
-> Builder
formatResultMsgWith e -> Builder
err r -> Builder
fmt Text
title t
params BracketLog' (Either e r)
b = Builder -> Builder -> Builder
nameF (Text -> Builder
forall p. Buildable p => p -> Builder
build Text
title) (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ [Builder] -> Builder
forall (f :: * -> *) a. (Foldable f, Buildable a) => f a -> Builder
blockListF
    [ Builder -> Builder -> Builder
nameF Builder
"inputs" (t -> Builder
forall t k v.
(IsList t, Item t ~ (k, v), Buildable k, Buildable v) =>
t -> Builder
blockMapF t
params)
    , (Either e r -> Builder) -> BracketLog' (Either e r) -> Builder
forall t. (t -> Builder) -> BracketLog' t -> Builder
buildBracketLog ((e -> Builder) -> (r -> Builder) -> Either e r -> Builder
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either e -> Builder
err r -> Builder
fmt) BracketLog' (Either e r)
b
    ]

-- | A good default mapping of message severities for 'traceResult'.
resultSeverity :: Severity -> BracketLog' (Either e r) -> Severity
resultSeverity :: Severity -> BracketLog' (Either e r) -> Severity
resultSeverity Severity
base = \case
    BracketLog' (Either e r)
BracketStart -> Severity
base
    BracketFinish (Left e
_) -> Severity
Error
    BracketFinish (Right r
_) -> Severity
base
    BracketException LoggedException SomeException
_ -> Severity
Error
    BracketAsyncException LoggedException SomeException
_ -> Severity
base

{-------------------------------------------------------------------------------
                             Logging of Exceptions
-------------------------------------------------------------------------------}

-- | Exception wrapper with typeclass instances that exception types often don't
-- have.
newtype LoggedException e = LoggedException e
    deriving ((forall x. LoggedException e -> Rep (LoggedException e) x)
-> (forall x. Rep (LoggedException e) x -> LoggedException e)
-> Generic (LoggedException e)
forall x. Rep (LoggedException e) x -> LoggedException e
forall x. LoggedException e -> Rep (LoggedException e) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall e x. Rep (LoggedException e) x -> LoggedException e
forall e x. LoggedException e -> Rep (LoggedException e) x
$cto :: forall e x. Rep (LoggedException e) x -> LoggedException e
$cfrom :: forall e x. LoggedException e -> Rep (LoggedException e) x
Generic, Int -> LoggedException e -> ShowS
[LoggedException e] -> ShowS
LoggedException e -> String
(Int -> LoggedException e -> ShowS)
-> (LoggedException e -> String)
-> ([LoggedException e] -> ShowS)
-> Show (LoggedException e)
forall e. Show e => Int -> LoggedException e -> ShowS
forall e. Show e => [LoggedException e] -> ShowS
forall e. Show e => LoggedException e -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LoggedException e] -> ShowS
$cshowList :: forall e. Show e => [LoggedException e] -> ShowS
show :: LoggedException e -> String
$cshow :: forall e. Show e => LoggedException e -> String
showsPrec :: Int -> LoggedException e -> ShowS
$cshowsPrec :: forall e. Show e => Int -> LoggedException e -> ShowS
Show, Eq (LoggedException e)
Eq (LoggedException e)
-> (LoggedException e -> LoggedException e -> Ordering)
-> (LoggedException e -> LoggedException e -> Bool)
-> (LoggedException e -> LoggedException e -> Bool)
-> (LoggedException e -> LoggedException e -> Bool)
-> (LoggedException e -> LoggedException e -> Bool)
-> (LoggedException e -> LoggedException e -> LoggedException e)
-> (LoggedException e -> LoggedException e -> LoggedException e)
-> Ord (LoggedException e)
LoggedException e -> LoggedException e -> Bool
LoggedException e -> LoggedException e -> Ordering
LoggedException e -> LoggedException e -> LoggedException e
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall e. (Show e, Ord e) => Eq (LoggedException e)
forall e.
(Show e, Ord e) =>
LoggedException e -> LoggedException e -> Bool
forall e.
(Show e, Ord e) =>
LoggedException e -> LoggedException e -> Ordering
forall e.
(Show e, Ord e) =>
LoggedException e -> LoggedException e -> LoggedException e
min :: LoggedException e -> LoggedException e -> LoggedException e
$cmin :: forall e.
(Show e, Ord e) =>
LoggedException e -> LoggedException e -> LoggedException e
max :: LoggedException e -> LoggedException e -> LoggedException e
$cmax :: forall e.
(Show e, Ord e) =>
LoggedException e -> LoggedException e -> LoggedException e
>= :: LoggedException e -> LoggedException e -> Bool
$c>= :: forall e.
(Show e, Ord e) =>
LoggedException e -> LoggedException e -> Bool
> :: LoggedException e -> LoggedException e -> Bool
$c> :: forall e.
(Show e, Ord e) =>
LoggedException e -> LoggedException e -> Bool
<= :: LoggedException e -> LoggedException e -> Bool
$c<= :: forall e.
(Show e, Ord e) =>
LoggedException e -> LoggedException e -> Bool
< :: LoggedException e -> LoggedException e -> Bool
$c< :: forall e.
(Show e, Ord e) =>
LoggedException e -> LoggedException e -> Bool
compare :: LoggedException e -> LoggedException e -> Ordering
$ccompare :: forall e.
(Show e, Ord e) =>
LoggedException e -> LoggedException e -> Ordering
$cp1Ord :: forall e. (Show e, Ord e) => Eq (LoggedException e)
Ord)

instance NFData e => NFData (LoggedException e)

instance NFData (LoggedException SomeException) where
    rnf :: LoggedException SomeException -> ()
rnf (LoggedException SomeException
e) = String -> ()
forall a. NFData a => a -> ()
rnf (SomeException -> String
forall a. Show a => a -> String
show SomeException
e)

instance Exception e => ToText (LoggedException e)

instance Exception e => Buildable (LoggedException e) where
    build :: LoggedException e -> Builder
build (LoggedException e
e) = String -> Builder
forall p. Buildable p => p -> Builder
build (String -> Builder) -> String -> Builder
forall a b. (a -> b) -> a -> b
$ e -> String
forall e. Exception e => e -> String
displayException e
e

instance Show e => Eq (LoggedException e) where
    LoggedException e
a == :: LoggedException e -> LoggedException e -> Bool
== LoggedException e
b = LoggedException e -> String
forall a. Show a => a -> String
show LoggedException e
a String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== LoggedException e -> String
forall a. Show a => a -> String
show LoggedException e
b

instance Exception e => ToJSON (LoggedException e) where
    toJSON :: LoggedException e -> Value
toJSON LoggedException e
e = [Pair] -> Value
object [Key
"exception" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= LoggedException e -> Text
forall a. ToText a => a -> Text
toText LoggedException e
e]

exceptionMsg :: SomeException -> (BracketLog' r)
exceptionMsg :: SomeException -> BracketLog' r
exceptionMsg SomeException
e = if SomeException -> Bool
forall e. Exception e => e -> Bool
isSyncException SomeException
e
    then LoggedException SomeException -> BracketLog' r
forall r. LoggedException SomeException -> BracketLog' r
BracketException (LoggedException SomeException -> BracketLog' r)
-> LoggedException SomeException -> BracketLog' r
forall a b. (a -> b) -> a -> b
$ SomeException -> LoggedException SomeException
forall e. e -> LoggedException e
LoggedException SomeException
e
    else LoggedException SomeException -> BracketLog' r
forall r. LoggedException SomeException -> BracketLog' r
BracketAsyncException (LoggedException SomeException -> BracketLog' r)
-> LoggedException SomeException -> BracketLog' r
forall a b. (a -> b) -> a -> b
$ SomeException -> LoggedException SomeException
forall e. e -> LoggedException e
LoggedException SomeException
e

{-------------------------------------------------------------------------------
                                Bracketed logging
-------------------------------------------------------------------------------}

-- | Used for tracing around an action.
data BracketLog' r
    = BracketStart
    -- ^ Logged before the action starts.
    | BracketFinish r
    -- ^ Logged after the action finishes.
    | BracketException (LoggedException SomeException)
    -- ^ Logged when the action throws an exception.
    | BracketAsyncException (LoggedException SomeException)
    -- ^ Logged when the action receives an async exception.
    deriving ((forall x. BracketLog' r -> Rep (BracketLog' r) x)
-> (forall x. Rep (BracketLog' r) x -> BracketLog' r)
-> Generic (BracketLog' r)
forall x. Rep (BracketLog' r) x -> BracketLog' r
forall x. BracketLog' r -> Rep (BracketLog' r) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall r x. Rep (BracketLog' r) x -> BracketLog' r
forall r x. BracketLog' r -> Rep (BracketLog' r) x
$cto :: forall r x. Rep (BracketLog' r) x -> BracketLog' r
$cfrom :: forall r x. BracketLog' r -> Rep (BracketLog' r) x
Generic, Int -> BracketLog' r -> ShowS
[BracketLog' r] -> ShowS
BracketLog' r -> String
(Int -> BracketLog' r -> ShowS)
-> (BracketLog' r -> String)
-> ([BracketLog' r] -> ShowS)
-> Show (BracketLog' r)
forall r. Show r => Int -> BracketLog' r -> ShowS
forall r. Show r => [BracketLog' r] -> ShowS
forall r. Show r => BracketLog' r -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BracketLog' r] -> ShowS
$cshowList :: forall r. Show r => [BracketLog' r] -> ShowS
show :: BracketLog' r -> String
$cshow :: forall r. Show r => BracketLog' r -> String
showsPrec :: Int -> BracketLog' r -> ShowS
$cshowsPrec :: forall r. Show r => Int -> BracketLog' r -> ShowS
Show, BracketLog' r -> BracketLog' r -> Bool
(BracketLog' r -> BracketLog' r -> Bool)
-> (BracketLog' r -> BracketLog' r -> Bool) -> Eq (BracketLog' r)
forall r. Eq r => BracketLog' r -> BracketLog' r -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BracketLog' r -> BracketLog' r -> Bool
$c/= :: forall r. Eq r => BracketLog' r -> BracketLog' r -> Bool
== :: BracketLog' r -> BracketLog' r -> Bool
$c== :: forall r. Eq r => BracketLog' r -> BracketLog' r -> Bool
Eq, [BracketLog' r] -> Encoding
[BracketLog' r] -> Value
BracketLog' r -> Encoding
BracketLog' r -> Value
(BracketLog' r -> Value)
-> (BracketLog' r -> Encoding)
-> ([BracketLog' r] -> Value)
-> ([BracketLog' r] -> Encoding)
-> ToJSON (BracketLog' r)
forall r. ToJSON r => [BracketLog' r] -> Encoding
forall r. ToJSON r => [BracketLog' r] -> Value
forall r. ToJSON r => BracketLog' r -> Encoding
forall r. ToJSON r => BracketLog' r -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [BracketLog' r] -> Encoding
$ctoEncodingList :: forall r. ToJSON r => [BracketLog' r] -> Encoding
toJSONList :: [BracketLog' r] -> Value
$ctoJSONList :: forall r. ToJSON r => [BracketLog' r] -> Value
toEncoding :: BracketLog' r -> Encoding
$ctoEncoding :: forall r. ToJSON r => BracketLog' r -> Encoding
toJSON :: BracketLog' r -> Value
$ctoJSON :: forall r. ToJSON r => BracketLog' r -> Value
ToJSON, a -> BracketLog' b -> BracketLog' a
(a -> b) -> BracketLog' a -> BracketLog' b
(forall a b. (a -> b) -> BracketLog' a -> BracketLog' b)
-> (forall a b. a -> BracketLog' b -> BracketLog' a)
-> Functor BracketLog'
forall a b. a -> BracketLog' b -> BracketLog' a
forall a b. (a -> b) -> BracketLog' a -> BracketLog' b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> BracketLog' b -> BracketLog' a
$c<$ :: forall a b. a -> BracketLog' b -> BracketLog' a
fmap :: (a -> b) -> BracketLog' a -> BracketLog' b
$cfmap :: forall a b. (a -> b) -> BracketLog' a -> BracketLog' b
Functor)

instance Buildable r => ToText (BracketLog' r)

instance Buildable r => Buildable (BracketLog' r) where
    build :: BracketLog' r -> Builder
build = (r -> Builder) -> BracketLog' r -> Builder
forall t. (t -> Builder) -> BracketLog' t -> Builder
buildBracketLog r -> Builder
forall p. Buildable p => p -> Builder
build

buildBracketLog :: (t -> Builder) -> BracketLog' t -> Builder
buildBracketLog :: (t -> Builder) -> BracketLog' t -> Builder
buildBracketLog t -> Builder
toBuilder = \case
    BracketLog' t
BracketStart -> Builder
"start"
    BracketFinish (t -> Builder
toBuilder -> Builder
r)
        | Builder
r Builder -> Builder -> Bool
forall a. Eq a => a -> a -> Bool
== Builder
forall a. Monoid a => a
mempty -> Builder
"finish"
        | Bool
otherwise -> Builder
"finish: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
r
    BracketException LoggedException SomeException
e -> Builder
"exception: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> LoggedException SomeException -> Builder
forall p. Buildable p => p -> Builder
build LoggedException SomeException
e
    BracketAsyncException LoggedException SomeException
e -> Builder
"cancelled: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> LoggedException SomeException -> Builder
forall p. Buildable p => p -> Builder
build LoggedException SomeException
e

instance HasPrivacyAnnotation (BracketLog' r)
instance HasSeverityAnnotation (BracketLog' r) where
    -- | Default severities for 'BracketLog' - the enclosing log message may of
    -- course use different values.
    getSeverityAnnotation :: BracketLog' r -> Severity
getSeverityAnnotation = \case
        BracketLog' r
BracketStart -> Severity
Debug
        BracketFinish r
_ -> Severity
Debug
        BracketException LoggedException SomeException
_ -> Severity
Error
        BracketAsyncException LoggedException SomeException
_ -> Severity
Debug

-- | Placeholder for some unspecified result value in 'BracketLog' - it could be
-- @()@, or anything else.
data SomeResult = SomeResult deriving ((forall x. SomeResult -> Rep SomeResult x)
-> (forall x. Rep SomeResult x -> SomeResult) -> Generic SomeResult
forall x. Rep SomeResult x -> SomeResult
forall x. SomeResult -> Rep SomeResult x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep SomeResult x -> SomeResult
$cfrom :: forall x. SomeResult -> Rep SomeResult x
Generic, Int -> SomeResult -> ShowS
[SomeResult] -> ShowS
SomeResult -> String
(Int -> SomeResult -> ShowS)
-> (SomeResult -> String)
-> ([SomeResult] -> ShowS)
-> Show SomeResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SomeResult] -> ShowS
$cshowList :: [SomeResult] -> ShowS
show :: SomeResult -> String
$cshow :: SomeResult -> String
showsPrec :: Int -> SomeResult -> ShowS
$cshowsPrec :: Int -> SomeResult -> ShowS
Show, SomeResult -> SomeResult -> Bool
(SomeResult -> SomeResult -> Bool)
-> (SomeResult -> SomeResult -> Bool) -> Eq SomeResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SomeResult -> SomeResult -> Bool
$c/= :: SomeResult -> SomeResult -> Bool
== :: SomeResult -> SomeResult -> Bool
$c== :: SomeResult -> SomeResult -> Bool
Eq)

instance Buildable SomeResult where
    build :: SomeResult -> Builder
build SomeResult
SomeResult = Builder
forall a. Monoid a => a
mempty

instance ToJSON SomeResult where
    toJSON :: SomeResult -> Value
toJSON SomeResult
SomeResult = Value
Null

-- | Trace around an action, where the result doesn't matter.
type BracketLog = BracketLog' SomeResult

-- | Run a monadic action with 'BracketLog' traced around it.
bracketTracer :: MonadUnliftIO m => Tracer m BracketLog -> m a -> m a
bracketTracer :: Tracer m BracketLog -> m a -> m a
bracketTracer = (a -> a) -> (a -> SomeResult) -> Tracer m BracketLog -> m a -> m a
forall (m :: * -> *) b r a.
MonadUnliftIO m =>
(b -> r) -> (b -> a) -> Tracer m (BracketLog' a) -> m b -> m r
bracketTracer'' a -> a
forall a. a -> a
id (SomeResult -> a -> SomeResult
forall a b. a -> b -> a
const SomeResult
SomeResult)

-- | Run a monadic action with 'BracketLog' traced around it.
bracketTracer'
    :: MonadUnliftIO m
    => (r -> a)
    -- ^ Transform value into log message.
    -> Tracer m (BracketLog' a)
    -- ^ Tracer.
    -> m r
    -- ^ Action.
    -> m r
bracketTracer' :: (r -> a) -> Tracer m (BracketLog' a) -> m r -> m r
bracketTracer' = (r -> r) -> (r -> a) -> Tracer m (BracketLog' a) -> m r -> m r
forall (m :: * -> *) b r a.
MonadUnliftIO m =>
(b -> r) -> (b -> a) -> Tracer m (BracketLog' a) -> m b -> m r
bracketTracer'' r -> r
forall a. a -> a
id

-- | Run a monadic action with 'BracketLog' traced around it.
bracketTracer''
    :: MonadUnliftIO m
    => (b -> r)
    -- ^ Transform value into result.
    -> (b -> a)
    -- ^ Transform value into log message.
    -> Tracer m (BracketLog' a)
    -- ^ Tracer.
    -> m b
    -- ^ Action to produce value.
    -> m r
bracketTracer'' :: (b -> r) -> (b -> a) -> Tracer m (BracketLog' a) -> m b -> m r
bracketTracer'' b -> r
res b -> a
msg Tracer m (BracketLog' a)
tr m b
action = do
    Tracer m (BracketLog' a) -> BracketLog' a -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (BracketLog' a)
tr BracketLog' a
forall r. BracketLog' r
BracketStart
    m r -> (SomeException -> m ()) -> m r
forall (m :: * -> *) e a b.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m b) -> m a
withException
        (m b
action m b -> (b -> m r) -> m r
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \b
val -> Tracer m (BracketLog' a) -> BracketLog' a -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (BracketLog' a)
tr (a -> BracketLog' a
forall r. r -> BracketLog' r
BracketFinish (b -> a
msg b
val)) m () -> r -> m r
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> b -> r
res b
val)
        (Tracer m (BracketLog' a) -> BracketLog' a -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (BracketLog' a)
tr (BracketLog' a -> m ())
-> (SomeException -> BracketLog' a) -> SomeException -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> BracketLog' a
forall r. SomeException -> BracketLog' r
exceptionMsg)

instance MonadIO m => Outcome m (BracketLog' r) where
  type IntermediateValue (BracketLog' r) = AbsoluteTime
  type OutcomeMetric (BracketLog' r)     = DiffTime

  classifyObservable :: BracketLog' r -> m OutcomeProgressionStatus
classifyObservable = OutcomeProgressionStatus -> m OutcomeProgressionStatus
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OutcomeProgressionStatus -> m OutcomeProgressionStatus)
-> (BracketLog' r -> OutcomeProgressionStatus)
-> BracketLog' r
-> m OutcomeProgressionStatus
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
      BracketLog' r
BracketStart -> OutcomeProgressionStatus
OutcomeStarts
      BracketFinish r
_ -> OutcomeProgressionStatus
OutcomeEnds
      BracketException LoggedException SomeException
_ -> OutcomeProgressionStatus
OutcomeEnds
      BracketAsyncException LoggedException SomeException
_ -> OutcomeProgressionStatus
OutcomeEnds

  -- NOTE: The AbsoluteTime functions are required so that measurements are
  -- correct at times when leap seconds are applied. This is following the
  -- tracer-transformers example.
  captureObservableValue :: BracketLog' r -> m (IntermediateValue (BracketLog' r))
captureObservableValue BracketLog' r
_   = SystemTime -> AbsoluteTime
systemToTAITime (SystemTime -> AbsoluteTime) -> m SystemTime -> m AbsoluteTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO SystemTime -> m SystemTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO SystemTime
getSystemTime
  computeOutcomeMetric :: BracketLog' r
-> IntermediateValue (BracketLog' r)
-> IntermediateValue (BracketLog' r)
-> m (OutcomeMetric (BracketLog' r))
computeOutcomeMetric BracketLog' r
_ IntermediateValue (BracketLog' r)
x IntermediateValue (BracketLog' r)
y = DiffTime -> m DiffTime
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DiffTime -> m DiffTime) -> DiffTime -> m DiffTime
forall a b. (a -> b) -> a -> b
$ AbsoluteTime -> AbsoluteTime -> DiffTime
diffAbsoluteTime AbsoluteTime
IntermediateValue (BracketLog' r)
y AbsoluteTime
IntermediateValue (BracketLog' r)
x

-- Pair up bracketlogs with some context information
instance MonadIO m => Outcome m (ctx, BracketLog) where
  type IntermediateValue (ctx, BracketLog) = (ctx, IntermediateValue BracketLog)
  type OutcomeMetric (ctx, BracketLog) = (ctx, OutcomeMetric BracketLog)
  classifyObservable :: (ctx, BracketLog) -> m OutcomeProgressionStatus
classifyObservable (ctx
_ctx, BracketLog
b) = BracketLog -> m OutcomeProgressionStatus
forall (m :: * -> *) a.
Outcome m a =>
a -> m OutcomeProgressionStatus
classifyObservable BracketLog
b
  captureObservableValue :: (ctx, BracketLog) -> m (IntermediateValue (ctx, BracketLog))
captureObservableValue (ctx
ctx, BracketLog
b) =
      (ctx
ctx,) (AbsoluteTime -> (ctx, AbsoluteTime))
-> m AbsoluteTime -> m (ctx, AbsoluteTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BracketLog -> m (IntermediateValue BracketLog)
forall (m :: * -> *) a. Outcome m a => a -> m (IntermediateValue a)
captureObservableValue BracketLog
b
  computeOutcomeMetric :: (ctx, BracketLog)
-> IntermediateValue (ctx, BracketLog)
-> IntermediateValue (ctx, BracketLog)
-> m (OutcomeMetric (ctx, BracketLog))
computeOutcomeMetric (ctx
ctx, BracketLog
b) (_, x) (_, y) =
      (ctx
ctx,) (DiffTime -> (ctx, DiffTime)) -> m DiffTime -> m (ctx, DiffTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BracketLog
-> IntermediateValue BracketLog
-> IntermediateValue BracketLog
-> m (OutcomeMetric BracketLog)
forall (m :: * -> *) a.
Outcome m a =>
a
-> IntermediateValue a
-> IntermediateValue a
-> m (OutcomeMetric a)
computeOutcomeMetric BracketLog
b AbsoluteTime
IntermediateValue BracketLog
x AbsoluteTime
IntermediateValue BracketLog
y

-- | Get metric results from 'mkOutcomeExtractor' and throw away the rest.
fiddleOutcome
    :: Monad m
    => Tracer m (ctx, DiffTime)
    -> Tracer m (Either (ctx, BracketLog) (OutcomeFidelity (ctx, DiffTime)))
fiddleOutcome :: Tracer m (ctx, DiffTime)
-> Tracer
     m (Either (ctx, BracketLog) (OutcomeFidelity (ctx, DiffTime)))
fiddleOutcome Tracer m (ctx, DiffTime)
tr = (Either (ctx, BracketLog) (OutcomeFidelity (ctx, DiffTime))
 -> m ())
-> Tracer
     m (Either (ctx, BracketLog) (OutcomeFidelity (ctx, DiffTime)))
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer ((Either (ctx, BracketLog) (OutcomeFidelity (ctx, DiffTime))
  -> m ())
 -> Tracer
      m (Either (ctx, BracketLog) (OutcomeFidelity (ctx, DiffTime))))
-> (Either (ctx, BracketLog) (OutcomeFidelity (ctx, DiffTime))
    -> m ())
-> Tracer
     m (Either (ctx, BracketLog) (OutcomeFidelity (ctx, DiffTime)))
forall a b. (a -> b) -> a -> b
$ \case
    Right (ProgressedNormally (ctx, DiffTime)
dt) -> Tracer m (ctx, DiffTime) -> (ctx, DiffTime) -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
runTracer Tracer m (ctx, DiffTime)
tr (ctx, DiffTime)
dt
    Either (ctx, BracketLog) (OutcomeFidelity (ctx, DiffTime))
_ -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Simplified wrapper for 'mkOutcomeExtractor'. This produces a timings
-- 'Tracer' from a 'Tracer' of messages @a@, and a function which can extract
-- the 'BracketLog' from @a@.
--
-- The extractor function can provide @ctx@, which could be the name of the
-- timed operation for example.
--
-- The produced tracer will make just one trace for each finished bracket.
-- It contains the @ctx@ from the extractor and the time difference.
produceTimings
    :: (MonadUnliftIO m, MonadMask m)
    => (a -> Maybe (ctx, BracketLog))
    -- ^ Function to extract BracketLog messages from @a@, paired with context.
    -> Tracer m (ctx, DiffTime)
    -- ^ The timings tracer, has time deltas for each finished bracket.
    -> m (Tracer m a)
produceTimings :: (a -> Maybe (ctx, BracketLog))
-> Tracer m (ctx, DiffTime) -> m (Tracer m a)
produceTimings a -> Maybe (ctx, BracketLog)
f Tracer m (ctx, DiffTime)
trDiffTime = do
    Tracer
  m (Either (ctx, BracketLog) (OutcomeFidelity (ctx, DiffTime)))
-> Tracer m (ctx, BracketLog)
extractor <- m (Tracer
     m (Either (ctx, BracketLog) (OutcomeFidelity (ctx, DiffTime)))
   -> Tracer m (ctx, BracketLog))
forall (m :: * -> *) a.
(MonadIO m, MonadMask m, Outcome m a) =>
m (OutcomeEnhancedTracer m a -> Tracer m a)
mkOutcomeExtractor
    let trOutcome :: Tracer
  m (Either (ctx, BracketLog) (OutcomeFidelity (ctx, DiffTime)))
trOutcome = Tracer m (ctx, DiffTime)
-> Tracer
     m (Either (ctx, BracketLog) (OutcomeFidelity (ctx, DiffTime)))
forall (m :: * -> *) ctx.
Monad m =>
Tracer m (ctx, DiffTime)
-> Tracer
     m (Either (ctx, BracketLog) (OutcomeFidelity (ctx, DiffTime)))
fiddleOutcome Tracer m (ctx, DiffTime)
trDiffTime
        trBracket :: Tracer m (ctx, BracketLog)
trBracket = Tracer
  m (Either (ctx, BracketLog) (OutcomeFidelity (ctx, DiffTime)))
-> Tracer m (ctx, BracketLog)
extractor Tracer
  m (Either (ctx, BracketLog) (OutcomeFidelity (ctx, DiffTime)))
trOutcome
        tr :: Tracer m a
tr = (a -> Maybe (ctx, BracketLog))
-> Tracer m (ctx, BracketLog) -> Tracer m a
forall (m :: * -> *) a b.
Monad m =>
(a -> Maybe b) -> Tracer m b -> Tracer m a
flatContramapTracer a -> Maybe (ctx, BracketLog)
f Tracer m (ctx, BracketLog)
trBracket
    Tracer m a -> m (Tracer m a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tracer m a
tr

{-------------------------------------------------------------------------------
                               Tracer conversions
-------------------------------------------------------------------------------}

-- | Convert an IO tracer to a 'm' tracer.
unliftIOTracer :: MonadIO m => Tracer IO a -> Tracer m a
unliftIOTracer :: Tracer IO a -> Tracer m a
unliftIOTracer = (forall x. IO x -> m x) -> Tracer IO a -> Tracer m a
forall (m :: * -> *) (n :: * -> *) s.
(forall x. m x -> n x) -> Tracer m s -> Tracer n s
natTracer forall x. IO x -> m x
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO

-- | Conditional mapping of a 'Tracer'.
flatContramapTracer
    :: Monad m
    => (a -> Maybe b)
    -> Tracer m b
    -> Tracer m a
flatContramapTracer :: (a -> Maybe b) -> Tracer m b -> Tracer m a
flatContramapTracer a -> Maybe b
p Tracer m b
tr = (a -> m ()) -> Tracer m a
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer ((a -> m ()) -> Tracer m a) -> (a -> m ()) -> Tracer m a
forall a b. (a -> b) -> a -> b
$ \a
a -> case a -> Maybe b
p a
a of
     Just b
b -> Tracer m b -> b -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
runTracer Tracer m b
tr b
b
     Maybe b
Nothing -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()