{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}

module Cardano.Logging.Trace (
    traceWith
  , withLoggingContext

  , filterTrace
  , filterTraceMaybe
  , filterTraceBySeverity
  , filterTraceByPrivacy

  , setSeverity
  , withSeverity
  , privately
  , setPrivacy
  , withPrivacy
  , allPublic
  , allConfidential
  , setDetails
  , withDetails

  , contramapM
  , contramapMCond
  , contramapM'
  , foldTraceM
  , foldCondTraceM
  , routingTrace

  , withNames
  , appendPrefixName
  , appendPrefixNames
  , appendInnerName
  , appendInnerNames
  , withInnerNames
  ) where

import           Cardano.Logging.Types

import           Control.Monad (forM_, join)
import           Control.Monad.IO.Unlift
import qualified Control.Tracer as T
import           Data.Maybe (isJust)
import           Data.Text (Text)

import           UnliftIO.MVar

-- | Adds a message object to a trace
traceWith :: Monad m => Trace m a -> a -> m ()
traceWith :: forall (m :: * -> *) a. Monad m => Trace m a -> a -> m ()
traceWith (Trace Tracer m (LoggingContext, Either TraceControl a)
tr) a
a = Tracer m (LoggingContext, Either TraceControl a)
-> (LoggingContext, Either TraceControl a) -> m ()
forall (m :: * -> *) a. Monad m => Tracer m a -> a -> m ()
T.traceWith Tracer m (LoggingContext, Either TraceControl a)
tr (LoggingContext
emptyLoggingContext, a -> Either TraceControl a
forall a b. b -> Either a b
Right a
a)

--- | Don't process further if the result of the selector function
---   is False.
filterTrace :: (Monad m)
  => ((LoggingContext, a) -> Bool)
  -> Trace m a
  -> Trace m a
filterTrace :: forall (m :: * -> *) a.
Monad m =>
((LoggingContext, a) -> Bool) -> Trace m a -> Trace m a
filterTrace (LoggingContext, a) -> Bool
ff (Trace Tracer m (LoggingContext, Either TraceControl a)
tr) = Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
forall (m :: * -> *) a.
Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
Trace (Tracer m (LoggingContext, Either TraceControl a) -> Trace m a)
-> Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
forall a b. (a -> b) -> a -> b
$ ((LoggingContext, Either TraceControl a) -> Bool)
-> Tracer m (LoggingContext, Either TraceControl a)
-> Tracer m (LoggingContext, Either TraceControl a)
forall (m :: * -> *) a.
Monad m =>
(a -> Bool) -> Tracer m a -> Tracer m a
T.squelchUnless
    (\case
      (LoggingContext
_lc, Left TraceControl
_)     -> Bool
True
      (LoggingContext
lc, Right a
a)     -> (LoggingContext, a) -> Bool
ff (LoggingContext
lc, a
a))
      Tracer m (LoggingContext, Either TraceControl a)
tr

--- | Keep the Just values and forget about the Nothings
filterTraceMaybe :: Monad m
  => Trace m a
  -> Trace m (Maybe a)
filterTraceMaybe :: forall (m :: * -> *) a. Monad m => Trace m a -> Trace m (Maybe a)
filterTraceMaybe (Trace Tracer m (LoggingContext, Either TraceControl a)
tr) = Tracer m (LoggingContext, Either TraceControl (Maybe a))
-> Trace m (Maybe a)
forall (m :: * -> *) a.
Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
Trace (Tracer m (LoggingContext, Either TraceControl (Maybe a))
 -> Trace m (Maybe a))
-> Tracer m (LoggingContext, Either TraceControl (Maybe a))
-> Trace m (Maybe a)
forall a b. (a -> b) -> a -> b
$
    ((LoggingContext, Either TraceControl (Maybe a)) -> Bool)
-> Tracer m (LoggingContext, Either TraceControl (Maybe a))
-> Tracer m (LoggingContext, Either TraceControl (Maybe a))
forall (m :: * -> *) a.
Monad m =>
(a -> Bool) -> Tracer m a -> Tracer m a
T.squelchUnless
      (\case
        (LoggingContext
_lc, Left TraceControl
_ctrl)     -> Bool
True
        (LoggingContext
_lc, Right (Just a
_)) -> Bool
True
        (LoggingContext
_lc, Right Maybe a
Nothing)  -> Bool
False)
      (((LoggingContext, Either TraceControl (Maybe a))
 -> (LoggingContext, Either TraceControl a))
-> Tracer m (LoggingContext, Either TraceControl a)
-> Tracer m (LoggingContext, Either TraceControl (Maybe a))
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
T.contramap
          (\case
            ( LoggingContext
lc, Right (Just a
a))    -> (LoggingContext
lc, a -> Either TraceControl a
forall a b. b -> Either a b
Right a
a)
            (LoggingContext
_lc, Right Maybe a
Nothing)     -> [Char] -> (LoggingContext, Either TraceControl a)
forall a. HasCallStack => [Char] -> a
error [Char]
"filterTraceMaybe: impossible"
            ( LoggingContext
lc, Left TraceControl
ctrl)         -> (LoggingContext
lc, TraceControl -> Either TraceControl a
forall a b. a -> Either a b
Left TraceControl
ctrl))
          Tracer m (LoggingContext, Either TraceControl a)
tr)

--- | Only processes messages further a severity equal or greater as the
--- given one
filterTraceBySeverity :: Monad m
  => Maybe SeverityF
  -> Trace m a
  -> Trace m a
filterTraceBySeverity :: forall (m :: * -> *) a.
Monad m =>
Maybe SeverityF -> Trace m a -> Trace m a
filterTraceBySeverity (Just SeverityF
minSeverity) =
    ((LoggingContext, a) -> Bool) -> Trace m a -> Trace m a
forall (m :: * -> *) a.
Monad m =>
((LoggingContext, a) -> Bool) -> Trace m a -> Trace m a
filterTrace
      (\(LoggingContext
lc, a
_) -> case LoggingContext -> Maybe SeverityS
lcSeverity LoggingContext
lc of
                      Just SeverityS
s  -> case SeverityF
minSeverity of
                                    SeverityF (Just SeverityS
fs) -> SeverityS
s SeverityS -> SeverityS -> Bool
forall a. Ord a => a -> a -> Bool
>= SeverityS
fs
                                    SeverityF Maybe SeverityS
Nothing   -> Bool
False
                      Maybe SeverityS
Nothing -> Bool
True)

filterTraceBySeverity Maybe SeverityF
Nothing = Trace m a -> Trace m a
forall a. a -> a
id

-- | Sets a new logging context for this message
withLoggingContext :: Monad m => LoggingContext -> Trace m a -> Trace m a
withLoggingContext :: forall (m :: * -> *) a.
Monad m =>
LoggingContext -> Trace m a -> Trace m a
withLoggingContext LoggingContext
lc (Trace Tracer m (LoggingContext, Either TraceControl a)
tr) = Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
forall (m :: * -> *) a.
Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
Trace (Tracer m (LoggingContext, Either TraceControl a) -> Trace m a)
-> Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
forall a b. (a -> b) -> a -> b
$
    ((LoggingContext, Either TraceControl a)
 -> (LoggingContext, Either TraceControl a))
-> Tracer m (LoggingContext, Either TraceControl a)
-> Tracer m (LoggingContext, Either TraceControl a)
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
T.contramap
      (\
        (LoggingContext
_lc, Either TraceControl a
cont) -> (LoggingContext
lc, Either TraceControl a
cont))
      Tracer m (LoggingContext, Either TraceControl a)
tr

-- | Appends a name to the context.
-- E.g. appendName "specific" $ appendName "middle" $ appendName "general" tracer
-- give the result: `general.middle.specific`.
appendPrefixName :: Monad m => Text -> Trace m a -> Trace m a
appendPrefixName :: forall (m :: * -> *) a. Monad m => Text -> Trace m a -> Trace m a
appendPrefixName Text
name (Trace Tracer m (LoggingContext, Either TraceControl a)
tr) = Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
forall (m :: * -> *) a.
Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
Trace (Tracer m (LoggingContext, Either TraceControl a) -> Trace m a)
-> Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
forall a b. (a -> b) -> a -> b
$
    ((LoggingContext, Either TraceControl a)
 -> (LoggingContext, Either TraceControl a))
-> Tracer m (LoggingContext, Either TraceControl a)
-> Tracer m (LoggingContext, Either TraceControl a)
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
T.contramap
      (\
        (LoggingContext
lc, Either TraceControl a
cont) -> (LoggingContext
lc {lcNSPrefix = name : lcNSPrefix lc}, Either TraceControl a
cont))
      Tracer m (LoggingContext, Either TraceControl a)
tr

appendInnerName :: Monad m => Text -> Trace m a -> Trace m a
appendInnerName :: forall (m :: * -> *) a. Monad m => Text -> Trace m a -> Trace m a
appendInnerName Text
name (Trace Tracer m (LoggingContext, Either TraceControl a)
tr) = Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
forall (m :: * -> *) a.
Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
Trace (Tracer m (LoggingContext, Either TraceControl a) -> Trace m a)
-> Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
forall a b. (a -> b) -> a -> b
$
    ((LoggingContext, Either TraceControl a)
 -> (LoggingContext, Either TraceControl a))
-> Tracer m (LoggingContext, Either TraceControl a)
-> Tracer m (LoggingContext, Either TraceControl a)
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
T.contramap
      (\
        (LoggingContext
lc, Either TraceControl a
cont) -> (LoggingContext
lc {lcNSInner = name : lcNSInner lc}, Either TraceControl a
cont))
      Tracer m (LoggingContext, Either TraceControl a)
tr

-- | Appends all names to the context.
{-# INLINE appendPrefixNames #-}
appendPrefixNames :: Monad m => [Text] -> Trace m a -> Trace m a
appendPrefixNames :: forall (m :: * -> *) a. Monad m => [Text] -> Trace m a -> Trace m a
appendPrefixNames [Text]
names (Trace Tracer m (LoggingContext, Either TraceControl a)
tr) = Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
forall (m :: * -> *) a.
Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
Trace (Tracer m (LoggingContext, Either TraceControl a) -> Trace m a)
-> Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
forall a b. (a -> b) -> a -> b
$
    ((LoggingContext, Either TraceControl a)
 -> (LoggingContext, Either TraceControl a))
-> Tracer m (LoggingContext, Either TraceControl a)
-> Tracer m (LoggingContext, Either TraceControl a)
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
T.contramap
      (\
        (LoggingContext
lc, Either TraceControl a
cont) -> (LoggingContext
lc {lcNSPrefix = names ++ lcNSPrefix lc}, Either TraceControl a
cont))
      Tracer m (LoggingContext, Either TraceControl a)
tr

-- | Appends all names to the context.
appendInnerNames :: Monad m => [Text] -> Trace m a -> Trace m a
appendInnerNames :: forall (m :: * -> *) a. Monad m => [Text] -> Trace m a -> Trace m a
appendInnerNames [Text]
names (Trace Tracer m (LoggingContext, Either TraceControl a)
tr) = Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
forall (m :: * -> *) a.
Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
Trace (Tracer m (LoggingContext, Either TraceControl a) -> Trace m a)
-> Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
forall a b. (a -> b) -> a -> b
$
    ((LoggingContext, Either TraceControl a)
 -> (LoggingContext, Either TraceControl a))
-> Tracer m (LoggingContext, Either TraceControl a)
-> Tracer m (LoggingContext, Either TraceControl a)
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
T.contramap
      (\
        (LoggingContext
lc, Either TraceControl a
cont) -> (LoggingContext
lc {lcNSInner = names ++ lcNSInner lc}, Either TraceControl a
cont))
      Tracer m (LoggingContext, Either TraceControl a)
tr

-- | Sets names for the messages in this trace based on the selector function
{-# INLINE withInnerNames #-}
withInnerNames :: forall m a. (Monad m, MetaTrace a) => Trace m a -> Trace m a
withInnerNames :: forall (m :: * -> *) a.
(Monad m, MetaTrace a) =>
Trace m a -> Trace m a
withInnerNames (Trace Tracer m (LoggingContext, Either TraceControl a)
tr) = Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
forall (m :: * -> *) a.
Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
Trace (Tracer m (LoggingContext, Either TraceControl a) -> Trace m a)
-> Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
forall a b. (a -> b) -> a -> b
$
    ((LoggingContext, Either TraceControl a)
 -> (LoggingContext, Either TraceControl a))
-> Tracer m (LoggingContext, Either TraceControl a)
-> Tracer m (LoggingContext, Either TraceControl a)
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
T.contramap
      (\case
        (LoggingContext
lc, Right a
a) -> (LoggingContext
lc {lcNSInner = nsInner (namespaceFor a)}, a -> Either TraceControl a
forall a b. b -> Either a b
Right a
a)
        (LoggingContext
lc, Left TraceControl
c)  -> (LoggingContext
lc, TraceControl -> Either TraceControl a
forall a b. a -> Either a b
Left TraceControl
c))
      Tracer m (LoggingContext, Either TraceControl a)
tr

-- | Sets names for the messages in this trace based on the selector function
--   and appends the provided names to the context.
{-# INLINE withNames #-}
withNames :: forall m a. (Monad m, MetaTrace a) => [Text] -> Trace m a -> Trace m a
withNames :: forall (m :: * -> *) a.
(Monad m, MetaTrace a) =>
[Text] -> Trace m a -> Trace m a
withNames [Text]
names (Trace Tracer m (LoggingContext, Either TraceControl a)
tr) = Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
forall (m :: * -> *) a.
Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
Trace (Tracer m (LoggingContext, Either TraceControl a) -> Trace m a)
-> Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
forall a b. (a -> b) -> a -> b
$
    ((LoggingContext, Either TraceControl a)
 -> (LoggingContext, Either TraceControl a))
-> Tracer m (LoggingContext, Either TraceControl a)
-> Tracer m (LoggingContext, Either TraceControl a)
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
T.contramap
      (\case
        (LoggingContext
lc, Right a
a) -> (LoggingContext
lc {lcNSPrefix = names,
                              lcNSInner  = nsInner (namespaceFor a)}, a -> Either TraceControl a
forall a b. b -> Either a b
Right a
a)
        (LoggingContext
lc, Left TraceControl
c)  -> (LoggingContext
lc {lcNSPrefix = names}, TraceControl -> Either TraceControl a
forall a b. a -> Either a b
Left TraceControl
c))
      Tracer m (LoggingContext, Either TraceControl a)
tr


-- | Sets severity for the messages in this trace
setSeverity :: Monad m => SeverityS -> Trace m a -> Trace m a
setSeverity :: forall (m :: * -> *) a.
Monad m =>
SeverityS -> Trace m a -> Trace m a
setSeverity SeverityS
s (Trace Tracer m (LoggingContext, Either TraceControl a)
tr) = Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
forall (m :: * -> *) a.
Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
Trace (Tracer m (LoggingContext, Either TraceControl a) -> Trace m a)
-> Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
forall a b. (a -> b) -> a -> b
$
    ((LoggingContext, Either TraceControl a)
 -> (LoggingContext, Either TraceControl a))
-> Tracer m (LoggingContext, Either TraceControl a)
-> Tracer m (LoggingContext, Either TraceControl a)
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
T.contramap
      (\ (LoggingContext
lc, Either TraceControl a
cont) -> if Maybe SeverityS -> Bool
forall a. Maybe a -> Bool
isJust (LoggingContext -> Maybe SeverityS
lcSeverity LoggingContext
lc)
                            then (LoggingContext
lc, Either TraceControl a
cont)
                            else (LoggingContext
lc {lcSeverity = Just s}, Either TraceControl a
cont))
      Tracer m (LoggingContext, Either TraceControl a)
tr

-- | Sets severities for the messages in this trace based on the MetaTrace class
{-# INLINE withSeverity #-}
withSeverity :: forall m a. (Monad m, MetaTrace a) => Trace m a -> Trace m a
withSeverity :: forall (m :: * -> *) a.
(Monad m, MetaTrace a) =>
Trace m a -> Trace m a
withSeverity (Trace Tracer m (LoggingContext, Either TraceControl a)
tr) = Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
forall (m :: * -> *) a.
Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
Trace (Tracer m (LoggingContext, Either TraceControl a) -> Trace m a)
-> Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
forall a b. (a -> b) -> a -> b
$
    ((LoggingContext, Either TraceControl a)
 -> (LoggingContext, Either TraceControl a))
-> Tracer m (LoggingContext, Either TraceControl a)
-> Tracer m (LoggingContext, Either TraceControl a)
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
T.contramap
      (\case
        (LoggingContext
lc, Right a
e) -> LoggingContext
-> Either TraceControl a -> (LoggingContext, Either TraceControl a)
process LoggingContext
lc (a -> Either TraceControl a
forall a b. b -> Either a b
Right a
e)
        (LoggingContext
lc, Left c :: TraceControl
c@(TCConfig TraceConfig
_)) -> LoggingContext
-> Either TraceControl a -> (LoggingContext, Either TraceControl a)
process LoggingContext
lc (TraceControl -> Either TraceControl a
forall a b. a -> Either a b
Left TraceControl
c)
        (LoggingContext
lc, Left d :: TraceControl
d@(TCDocument Int
_ DocCollector
_)) -> LoggingContext
-> Either TraceControl a -> (LoggingContext, Either TraceControl a)
process LoggingContext
lc (TraceControl -> Either TraceControl a
forall a b. a -> Either a b
Left TraceControl
d)
        (LoggingContext
lc, Left TraceControl
e) -> (LoggingContext
lc, TraceControl -> Either TraceControl a
forall a b. a -> Either a b
Left TraceControl
e))
      Tracer m (LoggingContext, Either TraceControl a)
tr
  where
    process :: LoggingContext
-> Either TraceControl a -> (LoggingContext, Either TraceControl a)
process LoggingContext
lc cont :: Either TraceControl a
cont@(Right a
v) =
      if Maybe SeverityS -> Bool
forall a. Maybe a -> Bool
isJust (LoggingContext -> Maybe SeverityS
lcSeverity LoggingContext
lc)
        then (LoggingContext
lc,Either TraceControl a
cont)
        else (LoggingContext
lc {lcSeverity = severityFor (Namespace [] (lcNSInner lc)
                                              :: Namespace a) (Just v)} , Either TraceControl a
cont)
    process LoggingContext
lc cont :: Either TraceControl a
cont@(Left TraceControl
_) =
      if Maybe SeverityS -> Bool
forall a. Maybe a -> Bool
isJust (LoggingContext -> Maybe SeverityS
lcSeverity LoggingContext
lc)
        then (LoggingContext
lc,Either TraceControl a
cont)
        else (LoggingContext
lc {lcSeverity = severityFor (Namespace [] (lcNSInner lc)
                                              :: Namespace a) Nothing}, Either TraceControl a
cont)

--- | Only processes messages further with a privacy greater then the given one
filterTraceByPrivacy :: (Monad m) =>
     Maybe Privacy
  -> Trace m a
  -> Trace m a
filterTraceByPrivacy :: forall (m :: * -> *) a.
Monad m =>
Maybe Privacy -> Trace m a -> Trace m a
filterTraceByPrivacy (Just Privacy
minPrivacy) = ((LoggingContext, a) -> Bool) -> Trace m a -> Trace m a
forall (m :: * -> *) a.
Monad m =>
((LoggingContext, a) -> Bool) -> Trace m a -> Trace m a
filterTrace (((LoggingContext, a) -> Bool) -> Trace m a -> Trace m a)
-> ((LoggingContext, a) -> Bool) -> Trace m a -> Trace m a
forall a b. (a -> b) -> a -> b
$
    \(LoggingContext
lc, a
_cont) ->
        case LoggingContext -> Maybe Privacy
lcPrivacy LoggingContext
lc of
          Just Privacy
s  -> Privacy -> Int
forall a. Enum a => a -> Int
fromEnum Privacy
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Privacy -> Int
forall a. Enum a => a -> Int
fromEnum Privacy
minPrivacy
          Maybe Privacy
Nothing -> Bool
True
filterTraceByPrivacy Maybe Privacy
Nothing = Trace m a -> Trace m a
forall a. a -> a
id

allPublic :: a -> Privacy
allPublic :: forall a. a -> Privacy
allPublic a
_ = Privacy
Public

allConfidential :: a -> Privacy
allConfidential :: forall a. a -> Privacy
allConfidential a
_ = Privacy
Confidential


-- | Sets privacy Confidential for the messages in this trace
privately :: Monad m => Trace m a -> Trace m a
privately :: forall (m :: * -> *) a. Monad m => Trace m a -> Trace m a
privately = Privacy -> Trace m a -> Trace m a
forall (m :: * -> *) a.
Monad m =>
Privacy -> Trace m a -> Trace m a
setPrivacy Privacy
Confidential

-- | Sets privacy for the messages in this trace
setPrivacy :: Monad m => Privacy -> Trace m a -> Trace m a
setPrivacy :: forall (m :: * -> *) a.
Monad m =>
Privacy -> Trace m a -> Trace m a
setPrivacy Privacy
p (Trace Tracer m (LoggingContext, Either TraceControl a)
tr) = Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
forall (m :: * -> *) a.
Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
Trace (Tracer m (LoggingContext, Either TraceControl a) -> Trace m a)
-> Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
forall a b. (a -> b) -> a -> b
$
  ((LoggingContext, Either TraceControl a)
 -> (LoggingContext, Either TraceControl a))
-> Tracer m (LoggingContext, Either TraceControl a)
-> Tracer m (LoggingContext, Either TraceControl a)
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
T.contramap
    (\ (LoggingContext
lc, Either TraceControl a
cont) -> if Maybe Privacy -> Bool
forall a. Maybe a -> Bool
isJust (LoggingContext -> Maybe Privacy
lcPrivacy LoggingContext
lc)
                      then (LoggingContext
lc, Either TraceControl a
cont)
                      else (LoggingContext
lc {lcPrivacy = Just p}, Either TraceControl a
cont))
    Tracer m (LoggingContext, Either TraceControl a)
tr

-- | Sets privacy for the messages in this trace based on the MetaTrace class
withPrivacy :: forall m a. (Monad m, MetaTrace a) => Trace m a -> Trace m a
withPrivacy :: forall (m :: * -> *) a.
(Monad m, MetaTrace a) =>
Trace m a -> Trace m a
withPrivacy (Trace Tracer m (LoggingContext, Either TraceControl a)
tr) = Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
forall (m :: * -> *) a.
Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
Trace (Tracer m (LoggingContext, Either TraceControl a) -> Trace m a)
-> Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
forall a b. (a -> b) -> a -> b
$
    ((LoggingContext, Either TraceControl a)
 -> (LoggingContext, Either TraceControl a))
-> Tracer m (LoggingContext, Either TraceControl a)
-> Tracer m (LoggingContext, Either TraceControl a)
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
T.contramap
      (\case
        (LoggingContext
lc, Right a
e) -> LoggingContext
-> Either TraceControl a -> (LoggingContext, Either TraceControl a)
process LoggingContext
lc (a -> Either TraceControl a
forall a b. b -> Either a b
Right a
e)
        (LoggingContext
lc, Left c :: TraceControl
c@(TCConfig TraceConfig
_)) -> LoggingContext
-> Either TraceControl a -> (LoggingContext, Either TraceControl a)
process LoggingContext
lc (TraceControl -> Either TraceControl a
forall a b. a -> Either a b
Left TraceControl
c)
        (LoggingContext
lc, Left d :: TraceControl
d@(TCDocument Int
_ DocCollector
_)) -> LoggingContext
-> Either TraceControl a -> (LoggingContext, Either TraceControl a)
process LoggingContext
lc (TraceControl -> Either TraceControl a
forall a b. a -> Either a b
Left TraceControl
d)
        (LoggingContext
lc, Left TraceControl
e) -> (LoggingContext
lc, TraceControl -> Either TraceControl a
forall a b. a -> Either a b
Left TraceControl
e))
      Tracer m (LoggingContext, Either TraceControl a)
tr
  where
    process :: LoggingContext
-> Either TraceControl a -> (LoggingContext, Either TraceControl a)
process LoggingContext
lc cont :: Either TraceControl a
cont@(Right a
v) =
      if Maybe Privacy -> Bool
forall a. Maybe a -> Bool
isJust (LoggingContext -> Maybe Privacy
lcPrivacy LoggingContext
lc)
        then (LoggingContext
lc,Either TraceControl a
cont)
        else (LoggingContext
lc {lcPrivacy = privacyFor (Namespace [] (lcNSInner lc)
                                              :: Namespace a) (Just v)} , Either TraceControl a
cont)
    process LoggingContext
lc cont :: Either TraceControl a
cont@(Left TraceControl
_) =
      if Maybe Privacy -> Bool
forall a. Maybe a -> Bool
isJust (LoggingContext -> Maybe Privacy
lcPrivacy LoggingContext
lc)
        then (LoggingContext
lc,Either TraceControl a
cont)
        else (LoggingContext
lc {lcPrivacy = privacyFor (Namespace [] (lcNSInner lc)
                                              :: Namespace a) Nothing}, Either TraceControl a
cont)

-- | Sets detail level for the messages in this trace
setDetails :: Monad m => DetailLevel -> Trace m a -> Trace m a
setDetails :: forall (m :: * -> *) a.
Monad m =>
DetailLevel -> Trace m a -> Trace m a
setDetails DetailLevel
p (Trace Tracer m (LoggingContext, Either TraceControl a)
tr) = Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
forall (m :: * -> *) a.
Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
Trace (Tracer m (LoggingContext, Either TraceControl a) -> Trace m a)
-> Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
forall a b. (a -> b) -> a -> b
$
    ((LoggingContext, Either TraceControl a)
 -> (LoggingContext, Either TraceControl a))
-> Tracer m (LoggingContext, Either TraceControl a)
-> Tracer m (LoggingContext, Either TraceControl a)
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
T.contramap
      (\ (LoggingContext
lc, Either TraceControl a
cont) -> if Maybe DetailLevel -> Bool
forall a. Maybe a -> Bool
isJust (LoggingContext -> Maybe DetailLevel
lcDetails LoggingContext
lc)
                        then (LoggingContext
lc, Either TraceControl a
cont)
                        else (LoggingContext
lc {lcDetails = Just p}, Either TraceControl a
cont))
      Tracer m (LoggingContext, Either TraceControl a)
tr

-- | Sets detail level for the messages in this trace based on the message
withDetails :: forall m a. (Monad m, MetaTrace a) => Trace m a -> Trace m a
withDetails :: forall (m :: * -> *) a.
(Monad m, MetaTrace a) =>
Trace m a -> Trace m a
withDetails (Trace Tracer m (LoggingContext, Either TraceControl a)
tr) = Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
forall (m :: * -> *) a.
Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
Trace (Tracer m (LoggingContext, Either TraceControl a) -> Trace m a)
-> Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
forall a b. (a -> b) -> a -> b
$
  ((LoggingContext, Either TraceControl a)
 -> (LoggingContext, Either TraceControl a))
-> Tracer m (LoggingContext, Either TraceControl a)
-> Tracer m (LoggingContext, Either TraceControl a)
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
T.contramap
      (\case
        (LoggingContext
lc, Right a
e) -> LoggingContext
-> Either TraceControl a -> (LoggingContext, Either TraceControl a)
process LoggingContext
lc (a -> Either TraceControl a
forall a b. b -> Either a b
Right a
e)
        (LoggingContext
lc, Left c :: TraceControl
c@(TCConfig TraceConfig
_)) -> LoggingContext
-> Either TraceControl a -> (LoggingContext, Either TraceControl a)
process LoggingContext
lc (TraceControl -> Either TraceControl a
forall a b. a -> Either a b
Left TraceControl
c)
        (LoggingContext
lc, Left d :: TraceControl
d@(TCDocument Int
_ DocCollector
_)) -> LoggingContext
-> Either TraceControl a -> (LoggingContext, Either TraceControl a)
process LoggingContext
lc (TraceControl -> Either TraceControl a
forall a b. a -> Either a b
Left TraceControl
d)
        (LoggingContext
lc, Left TraceControl
e) -> (LoggingContext
lc, TraceControl -> Either TraceControl a
forall a b. a -> Either a b
Left TraceControl
e))
      Tracer m (LoggingContext, Either TraceControl a)
tr
  where
    process :: LoggingContext
-> Either TraceControl a -> (LoggingContext, Either TraceControl a)
process LoggingContext
lc cont :: Either TraceControl a
cont@(Right a
v) =
      if Maybe DetailLevel -> Bool
forall a. Maybe a -> Bool
isJust (LoggingContext -> Maybe DetailLevel
lcDetails LoggingContext
lc)
        then (LoggingContext
lc,Either TraceControl a
cont)
        else (LoggingContext
lc {lcDetails = detailsFor (Namespace [] (lcNSInner lc)
                                              :: Namespace a) (Just v)} , Either TraceControl a
cont)
    process LoggingContext
lc cont :: Either TraceControl a
cont@(Left TraceControl
_) =
      if Maybe DetailLevel -> Bool
forall a. Maybe a -> Bool
isJust (LoggingContext -> Maybe DetailLevel
lcDetails LoggingContext
lc)
        then (LoggingContext
lc,Either TraceControl a
cont)
        else (LoggingContext
lc {lcDetails = detailsFor (Namespace [] (lcNSInner lc)
                                              :: Namespace a) Nothing}, Either TraceControl a
cont)

-- | Contramap a monadic function over a trace
{-# INLINE contramapM #-}
contramapM :: Monad m
  => Trace m b
  -> ((LoggingContext, Either TraceControl a)
      -> m (LoggingContext, Either TraceControl b))
  -> m (Trace m a)
contramapM :: forall (m :: * -> *) b a.
Monad m =>
Trace m b
-> ((LoggingContext, Either TraceControl a)
    -> m (LoggingContext, Either TraceControl b))
-> m (Trace m a)
contramapM (Trace Tracer m (LoggingContext, Either TraceControl b)
tr) (LoggingContext, Either TraceControl a)
-> m (LoggingContext, Either TraceControl b)
mFunc =
  Trace m a -> m (Trace m a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Trace m a -> m (Trace m a)) -> Trace m a -> m (Trace m a)
forall a b. (a -> b) -> a -> b
$ Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
forall (m :: * -> *) a.
Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
Trace (Tracer m (LoggingContext, Either TraceControl a) -> Trace m a)
-> Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
forall a b. (a -> b) -> a -> b
$ TracerA m (LoggingContext, Either TraceControl a) ()
-> Tracer m (LoggingContext, Either TraceControl a)
forall (m :: * -> *) a. TracerA m a () -> Tracer m a
T.Tracer (TracerA m (LoggingContext, Either TraceControl a) ()
 -> Tracer m (LoggingContext, Either TraceControl a))
-> TracerA m (LoggingContext, Either TraceControl a) ()
-> Tracer m (LoggingContext, Either TraceControl a)
forall a b. (a -> b) -> a -> b
$ ((LoggingContext, Either TraceControl a) -> m ())
-> TracerA m (LoggingContext, Either TraceControl a) ()
forall (m :: * -> *) a.
Applicative m =>
(a -> m ()) -> TracerA m a ()
T.emit (LoggingContext, Either TraceControl a) -> m ()
rFunc
    where
      rFunc :: (LoggingContext, Either TraceControl a) -> m ()
rFunc (LoggingContext, Either TraceControl a)
arg = do
        (LoggingContext, Either TraceControl b)
res <- (LoggingContext, Either TraceControl a)
-> m (LoggingContext, Either TraceControl b)
mFunc (LoggingContext, Either TraceControl a)
arg
        Tracer m (LoggingContext, Either TraceControl b)
-> (LoggingContext, Either TraceControl b) -> m ()
forall (m :: * -> *) a. Monad m => Tracer m a -> a -> m ()
T.traceWith Tracer m (LoggingContext, Either TraceControl b)
tr (LoggingContext, Either TraceControl b)
res

-- | Contramap a monadic function over a trace
--   Can as well filter out messages
{-# INLINE contramapMCond #-}
contramapMCond :: Monad m
  => Trace m b
  -> ((LoggingContext, Either TraceControl a)
      -> m (Maybe (LoggingContext, Either TraceControl b)))
  -> m (Trace m a)
contramapMCond :: forall (m :: * -> *) b a.
Monad m =>
Trace m b
-> ((LoggingContext, Either TraceControl a)
    -> m (Maybe (LoggingContext, Either TraceControl b)))
-> m (Trace m a)
contramapMCond (Trace Tracer m (LoggingContext, Either TraceControl b)
tr) (LoggingContext, Either TraceControl a)
-> m (Maybe (LoggingContext, Either TraceControl b))
mFunc =
  Trace m a -> m (Trace m a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Trace m a -> m (Trace m a)) -> Trace m a -> m (Trace m a)
forall a b. (a -> b) -> a -> b
$ Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
forall (m :: * -> *) a.
Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
Trace (Tracer m (LoggingContext, Either TraceControl a) -> Trace m a)
-> Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
forall a b. (a -> b) -> a -> b
$ TracerA m (LoggingContext, Either TraceControl a) ()
-> Tracer m (LoggingContext, Either TraceControl a)
forall (m :: * -> *) a. TracerA m a () -> Tracer m a
T.Tracer (TracerA m (LoggingContext, Either TraceControl a) ()
 -> Tracer m (LoggingContext, Either TraceControl a))
-> TracerA m (LoggingContext, Either TraceControl a) ()
-> Tracer m (LoggingContext, Either TraceControl a)
forall a b. (a -> b) -> a -> b
$ ((LoggingContext, Either TraceControl a) -> m ())
-> TracerA m (LoggingContext, Either TraceControl a) ()
forall (m :: * -> *) a.
Applicative m =>
(a -> m ()) -> TracerA m a ()
T.emit (LoggingContext, Either TraceControl a) -> m ()
rFunc
    where
      rFunc :: (LoggingContext, Either TraceControl a) -> m ()
rFunc (LoggingContext, Either TraceControl a)
arg = do
        Maybe (LoggingContext, Either TraceControl b)
condMes <- (LoggingContext, Either TraceControl a)
-> m (Maybe (LoggingContext, Either TraceControl b))
mFunc (LoggingContext, Either TraceControl a)
arg
        Maybe (LoggingContext, Either TraceControl b)
-> ((LoggingContext, Either TraceControl b) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (LoggingContext, Either TraceControl b)
condMes (Tracer m (LoggingContext, Either TraceControl b)
-> (LoggingContext, Either TraceControl b) -> m ()
forall (m :: * -> *) a. Monad m => Tracer m a -> a -> m ()
T.traceWith Tracer m (LoggingContext, Either TraceControl b)
tr)

{-# INLINE contramapM' #-}
contramapM' :: Monad m
  => ((LoggingContext, Either TraceControl a)
      -> m ())
  -> Trace m a
contramapM' :: forall (m :: * -> *) a.
Monad m =>
((LoggingContext, Either TraceControl a) -> m ()) -> Trace m a
contramapM' (LoggingContext, Either TraceControl a) -> m ()
rFunc =
  Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
forall (m :: * -> *) a.
Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
Trace (Tracer m (LoggingContext, Either TraceControl a) -> Trace m a)
-> Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
forall a b. (a -> b) -> a -> b
$ TracerA m (LoggingContext, Either TraceControl a) ()
-> Tracer m (LoggingContext, Either TraceControl a)
forall (m :: * -> *) a. TracerA m a () -> Tracer m a
T.Tracer (TracerA m (LoggingContext, Either TraceControl a) ()
 -> Tracer m (LoggingContext, Either TraceControl a))
-> TracerA m (LoggingContext, Either TraceControl a) ()
-> Tracer m (LoggingContext, Either TraceControl a)
forall a b. (a -> b) -> a -> b
$ ((LoggingContext, Either TraceControl a) -> m ())
-> TracerA m (LoggingContext, Either TraceControl a) ()
forall (m :: * -> *) a.
Applicative m =>
(a -> m ()) -> TracerA m a ()
T.emit (LoggingContext, Either TraceControl a) -> m ()
rFunc

-- | Folds the monadic cata function with acc over a.
-- Uses an MVar to store the state
foldTraceM :: forall a acc m . (MonadUnliftIO m)
  => (acc -> LoggingContext -> a -> m acc)
  -> acc
  -> Trace m (Folding a acc)
  -> m (Trace m a)
foldTraceM :: forall a acc (m :: * -> *).
MonadUnliftIO m =>
(acc -> LoggingContext -> a -> m acc)
-> acc -> Trace m (Folding a acc) -> m (Trace m a)
foldTraceM acc -> LoggingContext -> a -> m acc
cata acc
initial (Trace Tracer m (LoggingContext, Either TraceControl (Folding a acc))
tr) = do
  MVar acc
ref <- IO (MVar acc) -> m (MVar acc)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (acc -> IO (MVar acc)
forall (m :: * -> *) a. MonadIO m => a -> m (MVar a)
newMVar acc
initial)
  Trace m (Folding a acc)
-> ((LoggingContext, Either TraceControl a)
    -> m (LoggingContext, Either TraceControl (Folding a acc)))
-> m (Trace m a)
forall (m :: * -> *) b a.
Monad m =>
Trace m b
-> ((LoggingContext, Either TraceControl a)
    -> m (LoggingContext, Either TraceControl b))
-> m (Trace m a)
contramapM (Tracer m (LoggingContext, Either TraceControl (Folding a acc))
-> Trace m (Folding a acc)
forall (m :: * -> *) a.
Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
Trace Tracer m (LoggingContext, Either TraceControl (Folding a acc))
tr)
      (\case
        (LoggingContext
lc, Right a
v) -> do
          acc
x' <- MVar acc -> (acc -> m (acc, acc)) -> m acc
forall (m :: * -> *) a b.
MonadUnliftIO m =>
MVar a -> (a -> m (a, b)) -> m b
modifyMVar MVar acc
ref ((acc -> m (acc, acc)) -> m acc) -> (acc -> m (acc, acc)) -> m acc
forall a b. (a -> b) -> a -> b
$ \acc
x -> do
            !acc
accu <- acc -> LoggingContext -> a -> m acc
cata acc
x LoggingContext
lc a
v
            (acc, acc) -> m (acc, acc)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((acc, acc) -> m (acc, acc)) -> (acc, acc) -> m (acc, acc)
forall a b. (a -> b) -> a -> b
$ (acc -> acc -> (acc, acc)) -> acc -> (acc, acc)
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (,) acc
accu
          (LoggingContext, Either TraceControl (Folding a acc))
-> m (LoggingContext, Either TraceControl (Folding a acc))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LoggingContext
lc, Folding a acc -> Either TraceControl (Folding a acc)
forall a b. b -> Either a b
Right (acc -> Folding a acc
forall a b. b -> Folding a b
Folding acc
x'))
        (LoggingContext
lc, Left TraceControl
control) -> do
          (LoggingContext, Either TraceControl (Folding a acc))
-> m (LoggingContext, Either TraceControl (Folding a acc))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LoggingContext
lc, TraceControl -> Either TraceControl (Folding a acc)
forall a b. a -> Either a b
Left TraceControl
control))

-- | Like foldTraceM, but filter the trace by a predicate.
foldCondTraceM :: forall a acc m . (MonadUnliftIO m)
  => (acc -> LoggingContext -> a -> m acc)
  -> acc
  -> (a -> Bool)
  -> Trace m (Folding a acc)
  -> m (Trace m a)
foldCondTraceM :: forall a acc (m :: * -> *).
MonadUnliftIO m =>
(acc -> LoggingContext -> a -> m acc)
-> acc -> (a -> Bool) -> Trace m (Folding a acc) -> m (Trace m a)
foldCondTraceM acc -> LoggingContext -> a -> m acc
cata acc
initial a -> Bool
flt (Trace Tracer m (LoggingContext, Either TraceControl (Folding a acc))
tr) = do
  MVar acc
ref <- IO (MVar acc) -> m (MVar acc)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (acc -> IO (MVar acc)
forall (m :: * -> *) a. MonadIO m => a -> m (MVar a)
newMVar acc
initial)
  Trace m (Folding a acc)
-> ((LoggingContext, Either TraceControl a)
    -> m (Maybe (LoggingContext, Either TraceControl (Folding a acc))))
-> m (Trace m a)
forall (m :: * -> *) b a.
Monad m =>
Trace m b
-> ((LoggingContext, Either TraceControl a)
    -> m (Maybe (LoggingContext, Either TraceControl b)))
-> m (Trace m a)
contramapMCond (Tracer m (LoggingContext, Either TraceControl (Folding a acc))
-> Trace m (Folding a acc)
forall (m :: * -> *) a.
Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
Trace Tracer m (LoggingContext, Either TraceControl (Folding a acc))
tr) (MVar acc
-> (LoggingContext, Either TraceControl a)
-> m (Maybe (LoggingContext, Either TraceControl (Folding a acc)))
foldF MVar acc
ref)
 where
    foldF :: MVar acc
-> (LoggingContext, Either TraceControl a)
-> m (Maybe (LoggingContext, Either TraceControl (Folding a acc)))
foldF MVar acc
ref =
      \case
        (LoggingContext
lc, Right a
v) -> do
          acc
x' <- MVar acc -> (acc -> m (acc, acc)) -> m acc
forall (m :: * -> *) a b.
MonadUnliftIO m =>
MVar a -> (a -> m (a, b)) -> m b
modifyMVar MVar acc
ref ((acc -> m (acc, acc)) -> m acc) -> (acc -> m (acc, acc)) -> m acc
forall a b. (a -> b) -> a -> b
$ \acc
x -> do
            !acc
accu <- acc -> LoggingContext -> a -> m acc
cata acc
x LoggingContext
lc a
v
            (acc, acc) -> m (acc, acc)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((acc, acc) -> m (acc, acc)) -> (acc, acc) -> m (acc, acc)
forall a b. (a -> b) -> a -> b
$ (acc -> acc -> (acc, acc)) -> acc -> (acc, acc)
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (,) acc
accu
          if a -> Bool
flt a
v
            then Maybe (LoggingContext, Either TraceControl (Folding a acc))
-> m (Maybe (LoggingContext, Either TraceControl (Folding a acc)))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (LoggingContext, Either TraceControl (Folding a acc))
 -> m (Maybe (LoggingContext, Either TraceControl (Folding a acc))))
-> Maybe (LoggingContext, Either TraceControl (Folding a acc))
-> m (Maybe (LoggingContext, Either TraceControl (Folding a acc)))
forall a b. (a -> b) -> a -> b
$ (LoggingContext, Either TraceControl (Folding a acc))
-> Maybe (LoggingContext, Either TraceControl (Folding a acc))
forall a. a -> Maybe a
Just (LoggingContext
lc, Folding a acc -> Either TraceControl (Folding a acc)
forall a b. b -> Either a b
Right (acc -> Folding a acc
forall a b. b -> Folding a b
Folding acc
x'))
            else Maybe (LoggingContext, Either TraceControl (Folding a acc))
-> m (Maybe (LoggingContext, Either TraceControl (Folding a acc)))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (LoggingContext, Either TraceControl (Folding a acc))
forall a. Maybe a
Nothing
        (LoggingContext
lc, Left TraceControl
control) -> do
          Maybe (LoggingContext, Either TraceControl (Folding a acc))
-> m (Maybe (LoggingContext, Either TraceControl (Folding a acc)))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (LoggingContext, Either TraceControl (Folding a acc))
 -> m (Maybe (LoggingContext, Either TraceControl (Folding a acc))))
-> Maybe (LoggingContext, Either TraceControl (Folding a acc))
-> m (Maybe (LoggingContext, Either TraceControl (Folding a acc)))
forall a b. (a -> b) -> a -> b
$ (LoggingContext, Either TraceControl (Folding a acc))
-> Maybe (LoggingContext, Either TraceControl (Folding a acc))
forall a. a -> Maybe a
Just (LoggingContext
lc, TraceControl -> Either TraceControl (Folding a acc)
forall a b. a -> Either a b
Left TraceControl
control)

-- | Allows to route to different tracers, based on the message being processed.
--   The second argument must mappend all possible tracers of the first
--   argument to one tracer. This is required for the configuration!
routingTrace :: forall m a. Monad m
  => (a -> m (Trace m a))
  -> Trace m a
  -> Trace m a
routingTrace :: forall (m :: * -> *) a.
Monad m =>
(a -> m (Trace m a)) -> Trace m a -> Trace m a
routingTrace a -> m (Trace m a)
rf Trace m a
rc = ((LoggingContext, Either TraceControl a) -> m ()) -> Trace m a
forall (m :: * -> *) a.
Monad m =>
((LoggingContext, Either TraceControl a) -> m ()) -> Trace m a
contramapM'
    (\case
      (LoggingContext
lc, Right a
a) -> do
          Trace m a
nt <- a -> m (Trace m a)
rf a
a
          Tracer m (LoggingContext, Either TraceControl a)
-> (LoggingContext, Either TraceControl a) -> m ()
forall (m :: * -> *) a. Monad m => Tracer m a -> a -> m ()
T.traceWith (Trace m a -> Tracer m (LoggingContext, Either TraceControl a)
forall (m :: * -> *) a.
Trace m a -> Tracer m (LoggingContext, Either TraceControl a)
unpackTrace Trace m a
nt) (LoggingContext
lc, a -> Either TraceControl a
forall a b. b -> Either a b
Right a
a)
      (LoggingContext
lc, Left TraceControl
control) ->
          Tracer m (LoggingContext, Either TraceControl a)
-> (LoggingContext, Either TraceControl a) -> m ()
forall (m :: * -> *) a. Monad m => Tracer m a -> a -> m ()
T.traceWith (Trace m a -> Tracer m (LoggingContext, Either TraceControl a)
forall (m :: * -> *) a.
Trace m a -> Tracer m (LoggingContext, Either TraceControl a)
unpackTrace Trace m a
rc) (LoggingContext
lc, TraceControl -> Either TraceControl a
forall a b. a -> Either a b
Left TraceControl
control))