{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE ScopedTypeVariables #-}


module Cardano.Logging.Configuration
  ( ConfigReflection (..)
  , HermodException(..)
  , emptyConfigReflection
  , configureTracers
  , withNamespaceConfig
  , filterSeverityFromConfig
  , withDetailsFromConfig
  , withBackendsFromConfig
  , withLimitersFromConfig

  , maybeSilent
  , isSilentTracer
  , hasNoMetrics

  , getSeverity
  , getDetails
  , getBackends
  ) where

import           Cardano.Logging.DocuGenerator (addFiltered, addLimiter, addSilent)
import           Cardano.Logging.FrequencyLimiter (limitFrequency)
import           Cardano.Logging.Trace
import           Cardano.Logging.TraceDispatcherMessage
import           Cardano.Logging.Types

import           Control.Applicative (asum)
import           Control.Exception
import           Control.Monad (unless)
import           Control.Monad.IO.Class (MonadIO, liftIO)
import           Control.Monad.IO.Unlift (MonadUnliftIO)
import qualified Control.Tracer as T
import           Data.IORef (IORef, modifyIORef, newIORef, readIORef, writeIORef)
import           Data.List (inits, maximumBy, nub)
import qualified Data.Map.Lazy as Map
import           Data.Maybe (fromMaybe, listToMaybe, mapMaybe)
import qualified Data.Set as Set
import           Data.Text (Text, intercalate, unpack)


-- This is currently ad-hoc. With a future refactoring of trace-dispatcher,
-- it will be moved and serve as a proper error / exception type.
data HermodException = HermodConfigException { HermodException -> String
excMessage :: String }
     deriving Int -> HermodException -> ShowS
[HermodException] -> ShowS
HermodException -> String
(Int -> HermodException -> ShowS)
-> (HermodException -> String)
-> ([HermodException] -> ShowS)
-> Show HermodException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HermodException -> ShowS
showsPrec :: Int -> HermodException -> ShowS
$cshow :: HermodException -> String
show :: HermodException -> String
$cshowList :: [HermodException] -> ShowS
showList :: [HermodException] -> ShowS
Show

instance Exception HermodException

-- | Call this function at initialisation, and later for reconfiguration.
-- Config reflection is used to optimise the tracers and has to collect
-- information about the tracers. Although it is possible to give more then
-- one tracer of the same time, it is not a common case to do this.
configureTracers :: forall a m.
     (MetaTrace a
  ,  MonadIO m)
  => ConfigReflection
  -> TraceConfig
  -> [Trace m a]
  -> m ()
configureTracers :: forall a (m :: * -> *).
(MetaTrace a, MonadIO m) =>
ConfigReflection -> TraceConfig -> [Trace m a] -> m ()
configureTracers ConfigReflection
cr TraceConfig
config [Trace m a]
tracers = do
    (Trace m a -> m ()) -> [Trace m a] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Trace m a
t -> do
            TraceControl -> Trace m a -> m ()
forall {m :: * -> *} {a}.
Monad m =>
TraceControl -> Trace m a -> m ()
configureTrace TraceControl
TCReset Trace m a
t
            TraceControl -> Trace m a -> m ()
forall {m :: * -> *} {a}.
Monad m =>
TraceControl -> Trace m a -> m ()
configureAllTrace (TraceConfig -> TraceControl
TCConfig TraceConfig
config) Trace m a
t
            TraceControl -> Trace m a -> m ()
forall {m :: * -> *} {a}.
Monad m =>
TraceControl -> Trace m a -> m ()
configureTrace (ConfigReflection -> TraceControl
TCOptimize ConfigReflection
cr) Trace m a
t)
          [Trace m a]
tracers
  where
    configureTrace :: TraceControl -> Trace m a -> m ()
configureTrace TraceControl
control (Trace Tracer m (LoggingContext, Either TraceControl a)
tr) =
      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, TraceControl -> Either TraceControl a
forall a b. a -> Either a b
Left TraceControl
control)
    configureAllTrace :: TraceControl -> Trace m a -> m ()
configureAllTrace TraceControl
control (Trace Tracer m (LoggingContext, Either TraceControl a)
tr) =
      (Namespace a -> m ()) -> [Namespace a] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_  (\ Namespace a
ns ->
              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
                  { lcNSInner = nsInner ns}
                  , TraceControl -> Either TraceControl a
forall a b. a -> Either a b
Left TraceControl
control))
            ([Namespace a]
forall a. MetaTrace a => [Namespace a]
allNamespaces :: [Namespace a])

-- | Switch off any message of a particular tracer based on the configuration.
-- If the top tracer is silent and no subtracer is not silent, then switch it off
maybeSilent :: forall m a. (MonadIO m) =>
   ( TraceConfig -> Namespace a -> Bool)
  -> [Text]
  -> Bool
  -> Trace m a
  -> m (Trace m a)
maybeSilent :: forall (m :: * -> *) a.
MonadIO m =>
(TraceConfig -> Namespace a -> Bool)
-> [Text] -> Bool -> Trace m a -> m (Trace m a)
maybeSilent TraceConfig -> Namespace a -> Bool
selectorFunc [Text]
prefixNames Bool
isMetrics (Trace Tracer m (LoggingContext, Either TraceControl a)
tr) = do
    IORef (Maybe Bool)
ref  <- IO (IORef (Maybe Bool)) -> m (IORef (Maybe Bool))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Maybe Bool -> IO (IORef (Maybe Bool))
forall a. a -> IO (IORef a)
newIORef Maybe Bool
forall a. Maybe a
Nothing)
    Trace m a
-> ((LoggingContext, Either TraceControl a)
    -> m (Maybe (LoggingContext, Either TraceControl a)))
-> 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 a) -> Trace m a
forall (m :: * -> *) a.
Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
Trace Tracer m (LoggingContext, Either TraceControl a)
tr) (IORef (Maybe Bool)
-> (LoggingContext, Either TraceControl a)
-> m (Maybe (LoggingContext, Either TraceControl a))
forall {m :: * -> *} {a} {b}.
MonadIO m =>
IORef (Maybe Bool)
-> (a, Either TraceControl b)
-> m (Maybe (a, Either TraceControl b))
mapFunc IORef (Maybe Bool)
ref)
  where
    mapFunc :: IORef (Maybe Bool)
-> (a, Either TraceControl b)
-> m (Maybe (a, Either TraceControl b))
mapFunc IORef (Maybe Bool)
ref =
      \case
        (a
lc, Right b
a) -> do
          Maybe Bool
silence <- IO (Maybe Bool) -> m (Maybe Bool)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Bool) -> m (Maybe Bool))
-> IO (Maybe Bool) -> m (Maybe Bool)
forall a b. (a -> b) -> a -> b
$ IORef (Maybe Bool) -> IO (Maybe Bool)
forall a. IORef a -> IO a
readIORef IORef (Maybe Bool)
ref
          if Maybe Bool
silence Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
            then Maybe (a, Either TraceControl b)
-> m (Maybe (a, Either TraceControl b))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (a, Either TraceControl b)
forall a. Maybe a
Nothing
            else Maybe (a, Either TraceControl b)
-> m (Maybe (a, Either TraceControl b))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (a, Either TraceControl b)
 -> m (Maybe (a, Either TraceControl b)))
-> Maybe (a, Either TraceControl b)
-> m (Maybe (a, Either TraceControl b))
forall a b. (a -> b) -> a -> b
$ (a, Either TraceControl b) -> Maybe (a, Either TraceControl b)
forall a. a -> Maybe a
Just (a
lc, b -> Either TraceControl b
forall a b. b -> Either a b
Right b
a)
        (a
lc, Left (TCConfig TraceConfig
c)) -> do
          Maybe Bool
silence <- IO (Maybe Bool) -> m (Maybe Bool)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Bool) -> m (Maybe Bool))
-> IO (Maybe Bool) -> m (Maybe Bool)
forall a b. (a -> b) -> a -> b
$ IORef (Maybe Bool) -> IO (Maybe Bool)
forall a. IORef a -> IO a
readIORef IORef (Maybe Bool)
ref
          case Maybe Bool
silence of
            Maybe Bool
Nothing -> do
              let val :: Bool
val = TraceConfig -> Namespace a -> Bool
selectorFunc TraceConfig
c ([Text] -> [Text] -> Namespace a
forall a. [Text] -> [Text] -> Namespace a
Namespace [Text]
prefixNames [] :: Namespace a)
              IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef (Maybe Bool) -> Maybe Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe Bool)
ref (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
val)
            Just Bool
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          Maybe (a, Either TraceControl b)
-> m (Maybe (a, Either TraceControl b))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (a, Either TraceControl b)
 -> m (Maybe (a, Either TraceControl b)))
-> Maybe (a, Either TraceControl b)
-> m (Maybe (a, Either TraceControl b))
forall a b. (a -> b) -> a -> b
$ (a, Either TraceControl b) -> Maybe (a, Either TraceControl b)
forall a. a -> Maybe a
Just (a
lc, TraceControl -> Either TraceControl b
forall a b. a -> Either a b
Left (TraceConfig -> TraceControl
TCConfig TraceConfig
c))
        (a
lc, Left TraceControl
TCReset) -> do
          IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef (Maybe Bool) -> Maybe Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe Bool)
ref Maybe Bool
forall a. Maybe a
Nothing
          Maybe (a, Either TraceControl b)
-> m (Maybe (a, Either TraceControl b))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (a, Either TraceControl b)
 -> m (Maybe (a, Either TraceControl b)))
-> Maybe (a, Either TraceControl b)
-> m (Maybe (a, Either TraceControl b))
forall a b. (a -> b) -> a -> b
$ (a, Either TraceControl b) -> Maybe (a, Either TraceControl b)
forall a. a -> Maybe a
Just (a
lc, TraceControl -> Either TraceControl b
forall a b. a -> Either a b
Left TraceControl
TCReset)
        (a
lc, Left (TCOptimize ConfigReflection
cr)) -> do
          Maybe Bool
silence <- IO (Maybe Bool) -> m (Maybe Bool)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Bool) -> m (Maybe Bool))
-> IO (Maybe Bool) -> m (Maybe Bool)
forall a b. (a -> b) -> a -> b
$ IORef (Maybe Bool) -> IO (Maybe Bool)
forall a. IORef a -> IO a
readIORef IORef (Maybe Bool)
ref
          case Maybe Bool
silence of
            Just Bool
True -> IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ if Bool
isMetrics
                                    then IORef (Set [Text]) -> (Set [Text] -> Set [Text]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef (ConfigReflection -> IORef (Set [Text])
crNoMetrics ConfigReflection
cr) ([Text] -> Set [Text] -> Set [Text]
forall a. Ord a => a -> Set a -> Set a
Set.insert [Text]
prefixNames)
                                    else IORef (Set [Text]) -> (Set [Text] -> Set [Text]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef (ConfigReflection -> IORef (Set [Text])
crSilent ConfigReflection
cr) ([Text] -> Set [Text] -> Set [Text]
forall a. Ord a => a -> Set a -> Set a
Set.insert [Text]
prefixNames)
            Maybe Bool
_         -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef (Set [Text]) -> (Set [Text] -> Set [Text]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef (ConfigReflection -> IORef (Set [Text])
crAllTracers ConfigReflection
cr) ([Text] -> Set [Text] -> Set [Text]
forall a. Ord a => a -> Set a -> Set a
Set.insert [Text]
prefixNames)
          Maybe (a, Either TraceControl b)
-> m (Maybe (a, Either TraceControl b))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (a, Either TraceControl b)
 -> m (Maybe (a, Either TraceControl b)))
-> Maybe (a, Either TraceControl b)
-> m (Maybe (a, Either TraceControl b))
forall a b. (a -> b) -> a -> b
$ (a, Either TraceControl b) -> Maybe (a, Either TraceControl b)
forall a. a -> Maybe a
Just (a
lc,  TraceControl -> Either TraceControl b
forall a b. a -> Either a b
Left (ConfigReflection -> TraceControl
TCOptimize ConfigReflection
cr))
        (a
lc, Left c :: TraceControl
c@TCDocument {}) -> do
          Maybe Bool
silence <- IO (Maybe Bool) -> m (Maybe Bool)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Bool) -> m (Maybe Bool))
-> IO (Maybe Bool) -> m (Maybe Bool)
forall a b. (a -> b) -> a -> b
$ IORef (Maybe Bool) -> IO (Maybe Bool)
forall a. IORef a -> IO a
readIORef IORef (Maybe Bool)
ref
          Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
isMetrics
            (TraceControl -> Maybe Bool -> m ()
forall (m :: * -> *).
MonadIO m =>
TraceControl -> Maybe Bool -> m ()
addSilent TraceControl
c Maybe Bool
silence)
          Maybe (a, Either TraceControl b)
-> m (Maybe (a, Either TraceControl b))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (a, Either TraceControl b)
 -> m (Maybe (a, Either TraceControl b)))
-> Maybe (a, Either TraceControl b)
-> m (Maybe (a, Either TraceControl b))
forall a b. (a -> b) -> a -> b
$ (a, Either TraceControl b) -> Maybe (a, Either TraceControl b)
forall a. a -> Maybe a
Just (a
lc,  TraceControl -> Either TraceControl b
forall a b. a -> Either a b
Left TraceControl
c)


-- When all messages are filtered out, it is silent
isSilentTracer :: forall a. MetaTrace a => TraceConfig -> Namespace a -> Bool
isSilentTracer :: forall a. MetaTrace a => TraceConfig -> Namespace a -> Bool
isSilentTracer TraceConfig
tc (Namespace [Text]
prefixNS [Text]
_) =
    let allNS :: [Namespace a]
allNS = [Namespace a]
forall a. MetaTrace a => [Namespace a]
allNamespaces :: [Namespace a]
    in (Namespace a -> Bool) -> [Namespace a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\ (Namespace [Text]
_ [Text]
innerNS) ->
              Namespace a -> Bool
isFiltered ([Text] -> [Text] -> Namespace a
forall a. [Text] -> [Text] -> Namespace a
Namespace [Text]
prefixNS [Text]
innerNS :: Namespace a))
           [Namespace a]
allNS
  where
    isFiltered :: Namespace a -> Bool
    isFiltered :: Namespace a -> Bool
isFiltered Namespace a
ns =
      let msgSeverity :: Maybe SeverityS
msgSeverity    = Namespace a -> Maybe a -> Maybe SeverityS
forall a. MetaTrace a => Namespace a -> Maybe a -> Maybe SeverityS
severityFor Namespace a
ns Maybe a
forall a. Maybe a
Nothing
          severityFilter :: SeverityF
severityFilter = TraceConfig -> Namespace a -> SeverityF
forall a. TraceConfig -> Namespace a -> SeverityF
getSeverity TraceConfig
tc Namespace a
ns
      in case SeverityF
severityFilter of
            SeverityF Maybe SeverityS
Nothing -> Bool
True -- silent config
            SeverityF (Just SeverityS
sevF) ->
              case Maybe SeverityS
msgSeverity of
                Just SeverityS
msev -> SeverityS
sevF SeverityS -> SeverityS -> Bool
forall a. Ord a => a -> a -> Bool
> SeverityS
msev
                Maybe SeverityS
Nothing   -> Bool
False -- Impossible case

-- When all messages are filtered out, it is silent
hasNoMetrics :: forall a. MetaTrace a => TraceConfig -> Namespace a -> Bool
hasNoMetrics :: forall a. MetaTrace a => TraceConfig -> Namespace a -> Bool
hasNoMetrics TraceConfig
_tc Namespace a
_ns =
    let allNS :: [Namespace a]
allNS = [Namespace a]
forall a. MetaTrace a => [Namespace a]
allNamespaces :: [Namespace a]
    in (Namespace a -> Bool) -> [Namespace a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ([(Text, Text)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([(Text, Text)] -> Bool)
-> (Namespace a -> [(Text, Text)]) -> Namespace a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Namespace a -> [(Text, Text)]
forall a. MetaTrace a => Namespace a -> [(Text, Text)]
metricsDocFor) [Namespace a]
allNS

-- | Take a selector function called 'extract'.
-- Take a function from trace to trace with this config dependent value.
-- In this way construct a trace transformer with a config value
withNamespaceConfig :: forall m a b c. (MonadIO m, Ord b) =>
     String
  -> (TraceConfig -> Namespace a -> m b)
  -> (Maybe b -> Trace m c -> m (Trace m a))
  -> Trace m c
  -> m (Trace m a)
withNamespaceConfig :: forall (m :: * -> *) a b c.
(MonadIO m, Ord b) =>
String
-> (TraceConfig -> Namespace a -> m b)
-> (Maybe b -> Trace m c -> m (Trace m a))
-> Trace m c
-> m (Trace m a)
withNamespaceConfig String
name TraceConfig -> Namespace a -> m b
extract Maybe b -> Trace m c -> m (Trace m a)
withConfig Trace m c
tr = do
    IORef (Either (Map [Text] b, Maybe b) b)
ref  <- IO (IORef (Either (Map [Text] b, Maybe b) b))
-> m (IORef (Either (Map [Text] b, Maybe b) b))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Either (Map [Text] b, Maybe b) b
-> IO (IORef (Either (Map [Text] b, Maybe b) b))
forall a. a -> IO (IORef a)
newIORef ((Map [Text] b, Maybe b) -> Either (Map [Text] b, Maybe b) b
forall a b. a -> Either a b
Left (Map [Text] b
forall k a. Map k a
Map.empty, Maybe b
forall a. Maybe a
Nothing)))
    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
$ ((LoggingContext, Either TraceControl a) -> m ()) -> Trace m a
forall (m :: * -> *) a.
Monad m =>
((LoggingContext, Either TraceControl a) -> m ()) -> Trace m a
contramapM' (IORef (Either (Map [Text] b, Maybe b) b)
-> (LoggingContext, Either TraceControl a) -> m ()
mapFunc IORef (Either (Map [Text] b, Maybe b) b)
ref)
  where
    configError :: String -> m a
configError = IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> (String -> IO a) -> String -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HermodException -> IO a
forall e a. Exception e => e -> IO a
throwIO (HermodException -> IO a)
-> (String -> HermodException) -> String -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> HermodException
HermodConfigException
    mapFunc :: IORef (Either (Map [Text] b, Maybe b) b)
-> (LoggingContext, Either TraceControl a) -> m ()
mapFunc IORef (Either (Map [Text] b, Maybe b) b)
ref =
      \case
        (LoggingContext
lc, Right a
a) -> do
          Either (Map [Text] b, Maybe b) b
eitherConf <- IO (Either (Map [Text] b, Maybe b) b)
-> m (Either (Map [Text] b, Maybe b) b)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either (Map [Text] b, Maybe b) b)
 -> m (Either (Map [Text] b, Maybe b) b))
-> IO (Either (Map [Text] b, Maybe b) b)
-> m (Either (Map [Text] b, Maybe b) b)
forall a b. (a -> b) -> a -> b
$ IORef (Either (Map [Text] b, Maybe b) b)
-> IO (Either (Map [Text] b, Maybe b) b)
forall a. IORef a -> IO a
readIORef IORef (Either (Map [Text] b, Maybe b) b)
ref
          case Either (Map [Text] b, Maybe b) b
eitherConf of
            Right b
val -> do
              Trace m a
tt <- Maybe b -> Trace m c -> m (Trace m a)
withConfig (b -> Maybe b
forall a. a -> Maybe a
Just b
val) Trace m c
tr
              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
tt) (LoggingContext
lc, a -> Either TraceControl a
forall a b. b -> Either a b
Right a
a)
            Left (Map [Text] b
cmap, Just b
v) ->
              case [Text] -> Map [Text] b -> Maybe b
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (LoggingContext -> [Text]
lcNSPrefix LoggingContext
lc [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ LoggingContext -> [Text]
lcNSInner LoggingContext
lc) Map [Text] b
cmap of
                    Just b
val -> do
                      Trace m a
tt <- Maybe b -> Trace m c -> m (Trace m a)
withConfig (b -> Maybe b
forall a. a -> Maybe a
Just b
val) Trace m c
tr
                      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
tt) (LoggingContext
lc, a -> Either TraceControl a
forall a b. b -> Either a b
Right a
a)
                    Maybe b
Nothing  -> do
                      Trace m a
tt <- Maybe b -> Trace m c -> m (Trace m a)
withConfig (b -> Maybe b
forall a. a -> Maybe a
Just b
v) Trace m c
tr
                      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
tt) (LoggingContext
lc, a -> Either TraceControl a
forall a b. b -> Either a b
Right a
a)
            -- This can happen during reconfiguration, so we don't throw an error any more
            Left (Map [Text] b
_cmap, Maybe b
Nothing) -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        (LoggingContext
lc, Left TraceControl
TCReset) -> do
          IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef (Either (Map [Text] b, Maybe b) b)
-> Either (Map [Text] b, Maybe b) b -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Either (Map [Text] b, Maybe b) b)
ref ((Map [Text] b, Maybe b) -> Either (Map [Text] b, Maybe b) b
forall a b. a -> Either a b
Left (Map [Text] b
forall k a. Map k a
Map.empty, Maybe b
forall a. Maybe a
Nothing))
          Trace m a
tt <- Maybe b -> Trace m c -> m (Trace m a)
withConfig Maybe b
forall a. Maybe a
Nothing Trace m c
tr
          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
tt) (LoggingContext
lc, TraceControl -> Either TraceControl a
forall a b. a -> Either a b
Left TraceControl
TCReset)
        (LoggingContext
lc, Left (TCConfig TraceConfig
c)) -> do
          let nst :: [Text]
nst = LoggingContext -> [Text]
lcNSPrefix LoggingContext
lc [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ LoggingContext -> [Text]
lcNSInner LoggingContext
lc
          !b
val <- TraceConfig -> Namespace a -> m b
extract TraceConfig
c ([Text] -> [Text] -> Namespace a
forall a. [Text] -> [Text] -> Namespace a
Namespace (LoggingContext -> [Text]
lcNSPrefix LoggingContext
lc) (LoggingContext -> [Text]
lcNSInner LoggingContext
lc))
          Either (Map [Text] b, Maybe b) b
eitherConf <- IO (Either (Map [Text] b, Maybe b) b)
-> m (Either (Map [Text] b, Maybe b) b)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either (Map [Text] b, Maybe b) b)
 -> m (Either (Map [Text] b, Maybe b) b))
-> IO (Either (Map [Text] b, Maybe b) b)
-> m (Either (Map [Text] b, Maybe b) b)
forall a b. (a -> b) -> a -> b
$ IORef (Either (Map [Text] b, Maybe b) b)
-> IO (Either (Map [Text] b, Maybe b) b)
forall a. IORef a -> IO a
readIORef IORef (Either (Map [Text] b, Maybe b) b)
ref
          case Either (Map [Text] b, Maybe b) b
eitherConf of
            Left (Map [Text] b
cmap, Maybe b
Nothing) ->
              case [Text] -> Map [Text] b -> Maybe b
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup [Text]
nst Map [Text] b
cmap of
                Maybe b
Nothing -> do
                  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
                      (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef (Either (Map [Text] b, Maybe b) b)
-> Either (Map [Text] b, Maybe b) b -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Either (Map [Text] b, Maybe b) b)
ref ((Map [Text] b, Maybe b) -> Either (Map [Text] b, Maybe b) b
forall a b. a -> Either a b
Left ([Text] -> b -> Map [Text] b -> Map [Text] b
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert [Text]
nst b
val Map [Text] b
cmap, Maybe b
forall a. Maybe a
Nothing))
                  Trace m a
tt <- Maybe b -> Trace m c -> m (Trace m a)
withConfig (b -> Maybe b
forall a. a -> Maybe a
Just b
val) Trace m c
tr
                  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
tt) (LoggingContext
lc, TraceControl -> Either TraceControl a
forall a b. a -> Either a b
Left (TraceConfig -> TraceControl
TCConfig TraceConfig
c))
                Just b
v  -> do
                  if b
v b -> b -> Bool
forall a. Eq a => a -> a -> Bool
== b
val
                    then do
                      Trace Tracer m (LoggingContext, Either TraceControl a)
tt <- Maybe b -> Trace m c -> m (Trace m a)
withConfig (b -> Maybe b
forall a. a -> Maybe a
Just b
val) Trace m c
tr
                      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)
tt (LoggingContext
lc, TraceControl -> Either TraceControl a
forall a b. a -> Either a b
Left (TraceConfig -> TraceControl
TCConfig TraceConfig
c))
                    else String -> m ()
forall {a}. String -> m a
configError (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Inconsistent trace configuration with context "
                                      String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Text] -> String
forall a. Show a => a -> String
show [Text]
nst
            Right b
_val -> String -> m ()
forall {a}. String -> m a
configError (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Trace not reset before reconfiguration (1)"
                                String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Text] -> String
forall a. Show a => a -> String
show [Text]
nst
            Left (Map [Text] b
_cmap, Just b
_v) -> String -> m ()
forall {a}. String -> m a
configError (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Trace not reset before reconfiguration (2)"
                                String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Text] -> String
forall a. Show a => a -> String
show [Text]
nst
        (LoggingContext
lc, Left (TCOptimize ConfigReflection
cr)) -> do
          Either (Map [Text] b, Maybe b) b
eitherConf <- IO (Either (Map [Text] b, Maybe b) b)
-> m (Either (Map [Text] b, Maybe b) b)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either (Map [Text] b, Maybe b) b)
 -> m (Either (Map [Text] b, Maybe b) b))
-> IO (Either (Map [Text] b, Maybe b) b)
-> m (Either (Map [Text] b, Maybe b) b)
forall a b. (a -> b) -> a -> b
$ IORef (Either (Map [Text] b, Maybe b) b)
-> IO (Either (Map [Text] b, Maybe b) b)
forall a. IORef a -> IO a
readIORef IORef (Either (Map [Text] b, Maybe b) b)
ref
          let nst :: [Text]
nst = LoggingContext -> [Text]
lcNSPrefix LoggingContext
lc [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ LoggingContext -> [Text]
lcNSInner LoggingContext
lc
          case Either (Map [Text] b, Maybe b) b
eitherConf of
            Left (Map [Text] b
cmap, Maybe b
Nothing) ->
              case [b] -> [b]
forall a. Eq a => [a] -> [a]
nub (Map [Text] b -> [b]
forall k a. Map k a -> [a]
Map.elems Map [Text] b
cmap) of
                []     -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                [b
val]  -> do
                            IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef (Either (Map [Text] b, Maybe b) b)
-> Either (Map [Text] b, Maybe b) b -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Either (Map [Text] b, Maybe b) b)
ref (Either (Map [Text] b, Maybe b) b -> IO ())
-> Either (Map [Text] b, Maybe b) b -> IO ()
forall a b. (a -> b) -> a -> b
$ b -> Either (Map [Text] b, Maybe b) b
forall a b. b -> Either a b
Right b
val
                            Trace Tracer m (LoggingContext, Either TraceControl a)
tt <- Maybe b -> Trace m c -> m (Trace m a)
withConfig (b -> Maybe b
forall a. a -> Maybe a
Just b
val) Trace m c
tr
                            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)
tt (LoggingContext
lc, TraceControl -> Either TraceControl a
forall a b. a -> Either a b
Left (ConfigReflection -> TraceControl
TCOptimize ConfigReflection
cr))
                [b]
_      -> let decidingDict :: Map b Int
decidingDict =
                                (Map b Int -> b -> Map b Int) -> Map b Int -> [b] -> Map b Int
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
                                  (\Map b Int
acc b
e -> (Int -> Int -> Int) -> b -> Int -> Map b Int -> Map b Int
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) b
e (Int
1 :: Int) Map b Int
acc)
                                  Map b Int
forall k a. Map k a
Map.empty
                                  (Map [Text] b -> [b]
forall k a. Map k a -> [a]
Map.elems Map [Text] b
cmap)
                              (b
mostCommon, Int
_) = ((b, Int) -> (b, Int) -> Ordering) -> [(b, Int)] -> (b, Int)
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy
                                                  (\(b
_, Int
n') (b
_, Int
m') -> Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
n' Int
m')
                                                  (Map b Int -> [(b, Int)]
forall k a. Map k a -> [(k, a)]
Map.assocs Map b Int
decidingDict)
                              newmap :: Map [Text] b
newmap = (b -> Bool) -> Map [Text] b -> Map [Text] b
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (b -> b -> Bool
forall a. Eq a => a -> a -> Bool
/= b
mostCommon) Map [Text] b
cmap
                          in do
                            IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef (Either (Map [Text] b, Maybe b) b)
-> Either (Map [Text] b, Maybe b) b -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Either (Map [Text] b, Maybe b) b)
ref ((Map [Text] b, Maybe b) -> Either (Map [Text] b, Maybe b) b
forall a b. a -> Either a b
Left (Map [Text] b
newmap, b -> Maybe b
forall a. a -> Maybe a
Just b
mostCommon))
                            Trace Tracer m (LoggingContext, Either TraceControl a)
tt <- Maybe b -> Trace m c -> m (Trace m a)
withConfig Maybe b
forall a. Maybe a
Nothing Trace m c
tr
                            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)
tt (LoggingContext
lc, TraceControl -> Either TraceControl a
forall a b. a -> Either a b
Left (ConfigReflection -> TraceControl
TCOptimize ConfigReflection
cr))
            Right b
_val -> String -> m ()
forall {a}. String -> m a
configError (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Trace not reset before reconfiguration (3)"
                                String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Text] -> String
forall a. Show a => a -> String
show [Text]
nst
            Left (Map [Text] b
_cmap, Just b
_v) ->
                          String -> m ()
forall {a}. String -> m a
configError (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Trace not reset before reconfiguration (4)"
                                      String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Text] -> String
forall a. Show a => a -> String
show [Text]
nst
        (LoggingContext
lc, Left dc :: TraceControl
dc@TCDocument {}) -> do
          Either (Map [Text] b, Maybe b) b
eitherConf <- IO (Either (Map [Text] b, Maybe b) b)
-> m (Either (Map [Text] b, Maybe b) b)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either (Map [Text] b, Maybe b) b)
 -> m (Either (Map [Text] b, Maybe b) b))
-> IO (Either (Map [Text] b, Maybe b) b)
-> m (Either (Map [Text] b, Maybe b) b)
forall a b. (a -> b) -> a -> b
$ IORef (Either (Map [Text] b, Maybe b) b)
-> IO (Either (Map [Text] b, Maybe b) b)
forall a. IORef a -> IO a
readIORef IORef (Either (Map [Text] b, Maybe b) b)
ref
          let nst :: [Text]
nst = LoggingContext -> [Text]
lcNSPrefix LoggingContext
lc [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ LoggingContext -> [Text]
lcNSInner LoggingContext
lc
          case Either (Map [Text] b, Maybe b) b
eitherConf of
            Right b
val -> do
              Trace m a
tt <- Maybe b -> Trace m c -> m (Trace m a)
withConfig (b -> Maybe b
forall a. a -> Maybe a
Just b
val) Trace m c
tr
              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
tt) (LoggingContext
lc, TraceControl -> Either TraceControl a
forall a b. a -> Either a b
Left TraceControl
dc)
            Left (Map [Text] b
cmap, Just b
v) ->
              case [Text] -> Map [Text] b -> Maybe b
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup [Text]
nst Map [Text] b
cmap of
                    Just b
val -> do
                      Trace m a
tt <- Maybe b -> Trace m c -> m (Trace m a)
withConfig (b -> Maybe b
forall a. a -> Maybe a
Just b
val) Trace m c
tr
                      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
tt) (LoggingContext
lc, TraceControl -> Either TraceControl a
forall a b. a -> Either a b
Left TraceControl
dc)
                    Maybe b
Nothing  -> do
                      Trace m a
tt <- Maybe b -> Trace m c -> m (Trace m a)
withConfig (b -> Maybe b
forall a. a -> Maybe a
Just b
v) Trace m c
tr
                      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
tt) (LoggingContext
lc, TraceControl -> Either TraceControl a
forall a b. a -> Either a b
Left TraceControl
dc)
            Left (Map [Text] b
_cmap, Maybe b
Nothing) -> String -> m ()
forall {a}. String -> m a
configError (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Missing configuration(2) " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
name String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" ns " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Text] -> String
forall a. Show a => a -> String
show [Text]
nst


-- | Filter a trace by severity and take the filter value from the config
filterSeverityFromConfig :: (MonadIO m) =>
     Trace m a
  -> m (Trace m a)
filterSeverityFromConfig :: forall (m :: * -> *) a. MonadIO m => Trace m a -> m (Trace m a)
filterSeverityFromConfig =
    String
-> (TraceConfig -> Namespace a -> m SeverityF)
-> (Maybe SeverityF -> Trace m a -> m (Trace m a))
-> Trace m a
-> m (Trace m a)
forall (m :: * -> *) a b c.
(MonadIO m, Ord b) =>
String
-> (TraceConfig -> Namespace a -> m b)
-> (Maybe b -> Trace m c -> m (Trace m a))
-> Trace m c
-> m (Trace m a)
withNamespaceConfig
      String
"severity"
      (\TraceConfig
conf -> SeverityF -> m SeverityF
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SeverityF -> m SeverityF)
-> (Namespace a -> SeverityF) -> Namespace a -> m SeverityF
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TraceConfig -> Namespace a -> SeverityF
forall a. TraceConfig -> Namespace a -> SeverityF
getSeverity TraceConfig
conf)
      (\Maybe SeverityF
sev Trace m a
tr -> Trace m a
-> ((LoggingContext, Either TraceControl a)
    -> m (Maybe (LoggingContext, Either TraceControl a)))
-> 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 Trace m a
tr (Maybe SeverityF
-> (LoggingContext, Either TraceControl a)
-> m (Maybe (LoggingContext, Either TraceControl a))
forall {f :: * -> *} {b}.
MonadIO f =>
Maybe SeverityF
-> (LoggingContext, Either TraceControl b)
-> f (Maybe (LoggingContext, Either TraceControl b))
mapF Maybe SeverityF
sev))
  where
    mapF :: Maybe SeverityF
-> (LoggingContext, Either TraceControl b)
-> f (Maybe (LoggingContext, Either TraceControl b))
mapF Maybe SeverityF
confSev =
      \case
        (LoggingContext
lc, Right b
cont) -> do
          let visible :: Bool
visible = case LoggingContext -> Maybe SeverityS
lcSeverity LoggingContext
lc of
                            (Just SeverityS
s)  -> case Maybe SeverityF
confSev of
                                          Just (SeverityF (Just SeverityS
fs)) -> SeverityS
s SeverityS -> SeverityS -> Bool
forall a. Ord a => a -> a -> Bool
>= SeverityS
fs
                                          Just (SeverityF Maybe SeverityS
Nothing)   -> Bool
False
                                          Maybe SeverityF
Nothing -> Bool
True
                            Maybe SeverityS
Nothing -> Bool
True
          if Bool
visible
            then Maybe (LoggingContext, Either TraceControl b)
-> f (Maybe (LoggingContext, Either TraceControl b))
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (LoggingContext, Either TraceControl b)
 -> f (Maybe (LoggingContext, Either TraceControl b)))
-> Maybe (LoggingContext, Either TraceControl b)
-> f (Maybe (LoggingContext, Either TraceControl b))
forall a b. (a -> b) -> a -> b
$ (LoggingContext, Either TraceControl b)
-> Maybe (LoggingContext, Either TraceControl b)
forall a. a -> Maybe a
Just (LoggingContext
lc, b -> Either TraceControl b
forall a b. b -> Either a b
Right b
cont)
            else Maybe (LoggingContext, Either TraceControl b)
-> f (Maybe (LoggingContext, Either TraceControl b))
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (LoggingContext, Either TraceControl b)
forall a. Maybe a
Nothing
        (LoggingContext
lc, Left c :: TraceControl
c@TCDocument {}) -> do
          TraceControl -> Maybe SeverityF -> f ()
forall (m :: * -> *).
MonadIO m =>
TraceControl -> Maybe SeverityF -> m ()
addFiltered TraceControl
c Maybe SeverityF
confSev
          Maybe (LoggingContext, Either TraceControl b)
-> f (Maybe (LoggingContext, Either TraceControl b))
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((LoggingContext, Either TraceControl b)
-> Maybe (LoggingContext, Either TraceControl b)
forall a. a -> Maybe a
Just (LoggingContext
lc, TraceControl -> Either TraceControl b
forall a b. a -> Either a b
Left TraceControl
c))
        (LoggingContext
lc, Either TraceControl b
anx) ->  do
          Maybe (LoggingContext, Either TraceControl b)
-> f (Maybe (LoggingContext, Either TraceControl b))
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((LoggingContext, Either TraceControl b)
-> Maybe (LoggingContext, Either TraceControl b)
forall a. a -> Maybe a
Just (LoggingContext
lc, Either TraceControl b
anx))


-- | Set detail level of a trace from the config
withDetailsFromConfig :: (MonadIO m) =>
     Trace m a
  -> m (Trace m a)
withDetailsFromConfig :: forall (m :: * -> *) a. MonadIO m => Trace m a -> m (Trace m a)
withDetailsFromConfig =
  String
-> (TraceConfig -> Namespace a -> m DetailLevel)
-> (Maybe DetailLevel -> Trace m a -> m (Trace m a))
-> Trace m a
-> m (Trace m a)
forall (m :: * -> *) a b c.
(MonadIO m, Ord b) =>
String
-> (TraceConfig -> Namespace a -> m b)
-> (Maybe b -> Trace m c -> m (Trace m a))
-> Trace m c
-> m (Trace m a)
withNamespaceConfig
    String
"details"
    (\TraceConfig
conf -> DetailLevel -> m DetailLevel
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DetailLevel -> m DetailLevel)
-> (Namespace a -> DetailLevel) -> Namespace a -> m DetailLevel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TraceConfig -> Namespace a -> DetailLevel
forall a. TraceConfig -> Namespace a -> DetailLevel
getDetails TraceConfig
conf)
    (\Maybe DetailLevel
mbDtl Trace m a
b -> case Maybe DetailLevel
mbDtl of
              Just DetailLevel
dtl -> 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
$ DetailLevel -> Trace m a -> Trace m a
forall (m :: * -> *) a.
Monad m =>
DetailLevel -> Trace m a -> Trace m a
setDetails DetailLevel
dtl Trace m a
b
              Maybe DetailLevel
Nothing  -> 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
$ DetailLevel -> Trace m a -> Trace m a
forall (m :: * -> *) a.
Monad m =>
DetailLevel -> Trace m a -> Trace m a
setDetails DetailLevel
DNormal Trace m a
b)

-- | Routing and formatting of a trace from the config
withBackendsFromConfig :: (MonadIO m) =>
  (Maybe [BackendConfig] -> Trace m FormattedMessage -> m (Trace m a))
  -> m (Trace m a)
withBackendsFromConfig :: forall (m :: * -> *) a.
MonadIO m =>
(Maybe [BackendConfig]
 -> Trace m FormattedMessage -> m (Trace m a))
-> m (Trace m a)
withBackendsFromConfig Maybe [BackendConfig] -> Trace m FormattedMessage -> m (Trace m a)
rappendPrefixNameAndFormatter =
  String
-> (TraceConfig -> Namespace a -> m [BackendConfig])
-> (Maybe [BackendConfig]
    -> Trace m FormattedMessage -> m (Trace m a))
-> Trace m FormattedMessage
-> m (Trace m a)
forall (m :: * -> *) a b c.
(MonadIO m, Ord b) =>
String
-> (TraceConfig -> Namespace a -> m b)
-> (Maybe b -> Trace m c -> m (Trace m a))
-> Trace m c
-> m (Trace m a)
withNamespaceConfig
    String
"backends"
    (\TraceConfig
conf -> [BackendConfig] -> m [BackendConfig]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([BackendConfig] -> m [BackendConfig])
-> (Namespace a -> [BackendConfig])
-> Namespace a
-> m [BackendConfig]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TraceConfig -> Namespace a -> [BackendConfig]
forall a. TraceConfig -> Namespace a -> [BackendConfig]
getBackends TraceConfig
conf)
    Maybe [BackendConfig] -> Trace m FormattedMessage -> m (Trace m a)
rappendPrefixNameAndFormatter
    (Tracer m (LoggingContext, Either TraceControl FormattedMessage)
-> Trace m FormattedMessage
forall (m :: * -> *) a.
Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
Trace Tracer m (LoggingContext, Either TraceControl FormattedMessage)
forall (m :: * -> *) a. Monad m => Tracer m a
T.nullTracer)

data Limiter m a = Limiter Text Double (Trace m a)

instance Eq (Limiter m a) where
  Limiter Text
t1 Double
_ Trace m a
_ == :: Limiter m a -> Limiter m a -> Bool
== Limiter Text
t2 Double
_ Trace m a
_ = Text
t1 Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
t2

instance Ord (Limiter m a) where
  Limiter Text
t1 Double
_ Trace m a
_ <= :: Limiter m a -> Limiter m a -> Bool
<= Limiter Text
t2 Double
_ Trace m a
_ = Text
t1 Text -> Text -> Bool
forall a. Ord a => a -> a -> Bool
<= Text
t2

instance Show (Limiter m a) where
  show :: Limiter m a -> String
show (Limiter Text
name Double
_ Trace m a
_) = String
"Limiter " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
name


-- | Routing and formatting of a trace from the config
withLimitersFromConfig :: forall a m . (MonadUnliftIO m)
  => Trace m TraceDispatcherMessage
  -> Trace m a
  -> m (Trace m a)
withLimitersFromConfig :: forall a (m :: * -> *).
MonadUnliftIO m =>
Trace m TraceDispatcherMessage -> Trace m a -> m (Trace m a)
withLimitersFromConfig Trace m TraceDispatcherMessage
tri Trace m a
tr = do
    IORef (Map Text (Limiter m a))
ref <- IO (IORef (Map Text (Limiter m a)))
-> m (IORef (Map Text (Limiter m a)))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef (Map Text (Limiter m a)))
 -> m (IORef (Map Text (Limiter m a))))
-> IO (IORef (Map Text (Limiter m a)))
-> m (IORef (Map Text (Limiter m a)))
forall a b. (a -> b) -> a -> b
$ Map Text (Limiter m a) -> IO (IORef (Map Text (Limiter m a)))
forall a. a -> IO (IORef a)
newIORef Map Text (Limiter m a)
forall k a. Map k a
Map.empty
    String
-> (TraceConfig -> Namespace a -> m (Maybe (Limiter m a)))
-> (Maybe (Maybe (Limiter m a)) -> Trace m a -> m (Trace m a))
-> Trace m a
-> m (Trace m a)
forall (m :: * -> *) a b c.
(MonadIO m, Ord b) =>
String
-> (TraceConfig -> Namespace a -> m b)
-> (Maybe b -> Trace m c -> m (Trace m a))
-> Trace m c
-> m (Trace m a)
withNamespaceConfig
      String
"limiters"
      (IORef (Map Text (Limiter m a))
-> TraceConfig -> Namespace a -> m (Maybe (Limiter m a))
getLimiter IORef (Map Text (Limiter m a))
ref)
      Maybe (Maybe (Limiter m a)) -> Trace m a -> m (Trace m a)
withLimiter
      Trace m a
tr
  where
    -- | May return a limiter, which is a stateful transformation from trace to trace
    getLimiter ::
         IORef (Map.Map Text (Limiter m a))
      -> TraceConfig
      -> Namespace a
      -> m (Maybe (Limiter m a))
    getLimiter :: IORef (Map Text (Limiter m a))
-> TraceConfig -> Namespace a -> m (Maybe (Limiter m a))
getLimiter IORef (Map Text (Limiter m a))
stateRef TraceConfig
config Namespace a
ns =
      case TraceConfig -> Namespace a -> Maybe (Text, Double)
forall a. TraceConfig -> Namespace a -> Maybe (Text, Double)
getLimiterSpec TraceConfig
config Namespace a
ns of
        Maybe (Text, Double)
Nothing -> Maybe (Limiter m a) -> m (Maybe (Limiter m a))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Limiter m a)
forall a. Maybe a
Nothing
        Just (Text
name, Double
frequency) ->
          if Double
frequency Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
0
            then Maybe (Limiter m a) -> m (Maybe (Limiter m a))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Limiter m a)
forall a. Maybe a
Nothing
            else do
              Map Text (Limiter m a)
state <- IO (Map Text (Limiter m a)) -> m (Map Text (Limiter m a))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Map Text (Limiter m a)) -> m (Map Text (Limiter m a)))
-> IO (Map Text (Limiter m a)) -> m (Map Text (Limiter m a))
forall a b. (a -> b) -> a -> b
$ IORef (Map Text (Limiter m a)) -> IO (Map Text (Limiter m a))
forall a. IORef a -> IO a
readIORef IORef (Map Text (Limiter m a))
stateRef
              case Text -> Map Text (Limiter m a) -> Maybe (Limiter m a)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
name Map Text (Limiter m a)
state of
                Just Limiter m a
limiter -> Maybe (Limiter m a) -> m (Maybe (Limiter m a))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Limiter m a) -> m (Maybe (Limiter m a)))
-> Maybe (Limiter m a) -> m (Maybe (Limiter m a))
forall a b. (a -> b) -> a -> b
$ Limiter m a -> Maybe (Limiter m a)
forall a. a -> Maybe a
Just Limiter m a
limiter
                Maybe (Limiter m a)
Nothing -> do
                  Trace m a
limiterTrace <- Double
-> Text
-> Trace m TraceDispatcherMessage
-> Trace m a
-> m (Trace m a)
forall a (m :: * -> *).
MonadUnliftIO m =>
Double
-> Text
-> Trace m TraceDispatcherMessage
-> Trace m a
-> m (Trace m a)
limitFrequency Double
frequency Text
name Trace m TraceDispatcherMessage
tri Trace m a
tr
                  let limiter :: Limiter m a
limiter = Text -> Double -> Trace m a -> Limiter m a
forall (m :: * -> *) a. Text -> Double -> Trace m a -> Limiter m a
Limiter Text
name Double
frequency Trace m a
limiterTrace
                  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef (Map Text (Limiter m a)) -> Map Text (Limiter m a) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Map Text (Limiter m a))
stateRef (Text
-> Limiter m a -> Map Text (Limiter m a) -> Map Text (Limiter m a)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
name Limiter m a
limiter Map Text (Limiter m a)
state)
                  Maybe (Limiter m a) -> m (Maybe (Limiter m a))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Limiter m a) -> m (Maybe (Limiter m a)))
-> Maybe (Limiter m a) -> m (Maybe (Limiter m a))
forall a b. (a -> b) -> a -> b
$ Limiter m a -> Maybe (Limiter m a)
forall a. a -> Maybe a
Just Limiter m a
limiter

    withLimiter ::
         Maybe (Maybe (Limiter m a))
      -> Trace m a
      -> m (Trace m a)
    withLimiter :: Maybe (Maybe (Limiter m a)) -> Trace m a -> m (Trace m a)
withLimiter Maybe (Maybe (Limiter m a))
Nothing Trace m a
tr' = Trace m a -> m (Trace m a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Trace m a
tr'
    withLimiter (Just Maybe (Limiter m a)
Nothing) Trace m a
tr' = Trace m a -> m (Trace m a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Trace m a
tr'
    withLimiter (Just (Just (Limiter Text
n Double
d (Trace Tracer m (LoggingContext, Either TraceControl a)
trli)))) (Trace Tracer m (LoggingContext, Either TraceControl a)
tr') =
      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
$ ((LoggingContext, Either TraceControl a) -> m ()) -> Trace m a
forall (m :: * -> *) a.
Monad m =>
((LoggingContext, Either TraceControl a) -> m ()) -> Trace m a
contramapM' (Limiter m a
-> Trace m a -> (LoggingContext, Either TraceControl a) -> m ()
forall {m :: * -> *} {a} {a}.
MonadIO m =>
Limiter m a
-> Trace m a -> (LoggingContext, Either TraceControl a) -> m ()
mapFunc (Text -> Double -> Trace m a -> Limiter m a
forall (m :: * -> *) a. Text -> Double -> Trace m a -> Limiter m a
Limiter Text
n Double
d (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)
trli)) (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)
tr'))
    mapFunc :: Limiter m a
-> Trace m a -> (LoggingContext, Either TraceControl a) -> m ()
mapFunc (Limiter Text
n Double
d (Trace Tracer m (LoggingContext, Either TraceControl a)
trli)) (Trace Tracer m (LoggingContext, Either TraceControl a)
tr') =
        \case
          (LoggingContext
lc, Right a
v) ->
            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)
trli (LoggingContext
lc, a -> Either TraceControl a
forall a b. b -> Either a b
Right a
v)
          (LoggingContext
lc, Left c :: TraceControl
c@TCDocument {}) -> do
            TraceControl -> (Text, Double) -> m ()
forall (m :: * -> *).
MonadIO m =>
TraceControl -> (Text, Double) -> m ()
addLimiter TraceControl
c (Text
n, Double
d)
            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
lc, TraceControl -> Either TraceControl a
forall a b. a -> Either a b
Left TraceControl
c)
          (LoggingContext
lc, Left TraceControl
c) ->
            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
lc, TraceControl -> Either TraceControl a
forall a b. a -> Either a b
Left TraceControl
c)

--------------------------------------------------------

-- | By guaranteeing fallback values in the config's namespace root, the Debug severity value here should never get used.
--   If it has to be used, this points to a severely erroneous config, or an implementation error in the application's MetaTrace instance(s).
--   For those cases only, this ensures the affected trace message isn't silently filtered out.
getSeverity :: TraceConfig -> Namespace a -> SeverityF
getSeverity :: forall a. TraceConfig -> Namespace a -> SeverityF
getSeverity TraceConfig
config Namespace a
ns =
    SeverityF -> Maybe SeverityF -> SeverityF
forall a. a -> Maybe a -> a
fromMaybe (Maybe SeverityS -> SeverityF
SeverityF (SeverityS -> Maybe SeverityS
forall a. a -> Maybe a
Just SeverityS
Debug))
              ((ConfigOption -> Maybe SeverityF)
-> TraceConfig -> [Text] -> Maybe SeverityF
forall a.
(ConfigOption -> Maybe a) -> TraceConfig -> [Text] -> Maybe a
getOption ConfigOption -> Maybe SeverityF
severitySelector TraceConfig
config (Namespace a -> [Text]
forall a. Namespace a -> [Text]
nsGetComplete Namespace a
ns))
  where
    severitySelector :: ConfigOption -> Maybe SeverityF
    severitySelector :: ConfigOption -> Maybe SeverityF
severitySelector (ConfSeverity SeverityF
s) = SeverityF -> Maybe SeverityF
forall a. a -> Maybe a
Just SeverityF
s
    severitySelector ConfigOption
_              = Maybe SeverityF
forall a. Maybe a
Nothing

-- | If no details can be found in the config, it is set to DNormal
getDetails :: TraceConfig -> Namespace a -> DetailLevel
getDetails :: forall a. TraceConfig -> Namespace a -> DetailLevel
getDetails TraceConfig
config Namespace a
ns =
    DetailLevel -> Maybe DetailLevel -> DetailLevel
forall a. a -> Maybe a -> a
fromMaybe DetailLevel
DNormal ((ConfigOption -> Maybe DetailLevel)
-> TraceConfig -> [Text] -> Maybe DetailLevel
forall a.
(ConfigOption -> Maybe a) -> TraceConfig -> [Text] -> Maybe a
getOption ConfigOption -> Maybe DetailLevel
detailSelector TraceConfig
config (Namespace a -> [Text]
forall a. Namespace a -> [Text]
nsGetComplete Namespace a
ns))
  where
    detailSelector :: ConfigOption -> Maybe DetailLevel
    detailSelector :: ConfigOption -> Maybe DetailLevel
detailSelector (ConfDetail DetailLevel
d) = DetailLevel -> Maybe DetailLevel
forall a. a -> Maybe a
Just DetailLevel
d
    detailSelector ConfigOption
_            = Maybe DetailLevel
forall a. Maybe a
Nothing

-- | If no backends can be found in the config, it is set to
-- [EKGBackend, Forwarder, Stdout HumanFormatColoured]
getBackends :: TraceConfig -> Namespace a -> [BackendConfig]
getBackends :: forall a. TraceConfig -> Namespace a -> [BackendConfig]
getBackends TraceConfig
config Namespace a
ns =
    [BackendConfig] -> Maybe [BackendConfig] -> [BackendConfig]
forall a. a -> Maybe a -> a
fromMaybe [BackendConfig
EKGBackend, BackendConfig
Forwarder, FormatLogging -> BackendConfig
Stdout FormatLogging
HumanFormatColoured]
      ((ConfigOption -> Maybe [BackendConfig])
-> TraceConfig -> [Text] -> Maybe [BackendConfig]
forall a.
(ConfigOption -> Maybe a) -> TraceConfig -> [Text] -> Maybe a
getOption ConfigOption -> Maybe [BackendConfig]
backendSelector TraceConfig
config (Namespace a -> [Text]
forall a. Namespace a -> [Text]
nsGetComplete Namespace a
ns))
  where
    backendSelector :: ConfigOption -> Maybe [BackendConfig]
    backendSelector :: ConfigOption -> Maybe [BackendConfig]
backendSelector (ConfBackend [BackendConfig]
s) = [BackendConfig] -> Maybe [BackendConfig]
forall a. a -> Maybe a
Just [BackendConfig]
s
    backendSelector ConfigOption
_             = Maybe [BackendConfig]
forall a. Maybe a
Nothing

-- | May return a limiter specification
getLimiterSpec :: TraceConfig -> Namespace a -> Maybe (Text, Double)
getLimiterSpec :: forall a. TraceConfig -> Namespace a -> Maybe (Text, Double)
getLimiterSpec TraceConfig
config Namespace a
ns = (ConfigOption -> Maybe (Text, Double))
-> TraceConfig -> [Text] -> Maybe (Text, Double)
forall a.
(ConfigOption -> Maybe a) -> TraceConfig -> [Text] -> Maybe a
getOption ConfigOption -> Maybe (Text, Double)
limiterSelector TraceConfig
config (Namespace a -> [Text]
forall a. Namespace a -> [Text]
nsGetComplete Namespace a
ns)
  where
    limiterSelector :: ConfigOption -> Maybe (Text, Double)
    limiterSelector :: ConfigOption -> Maybe (Text, Double)
limiterSelector (ConfLimiter Double
f) = (Text, Double) -> Maybe (Text, Double)
forall a. a -> Maybe a
Just (Text -> [Text] -> Text
intercalate Text
"." (Namespace a -> [Text]
forall a. Namespace a -> [Text]
nsPrefix Namespace a
ns [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Namespace a -> [Text]
forall a. Namespace a -> [Text]
nsInner Namespace a
ns), Double
f)
    limiterSelector ConfigOption
_               = Maybe (Text, Double)
forall a. Maybe a
Nothing

-- | Searches in the config to find an option, most-specific as per namespace first.
-- (Generates all ancestor prefixes once via `inits`, avoiding a repeated O(n) `init` call at each recursion level)
getOption :: (ConfigOption -> Maybe a) -> TraceConfig -> [Text] -> Maybe a
getOption :: forall a.
(ConfigOption -> Maybe a) -> TraceConfig -> [Text] -> Maybe a
getOption ConfigOption -> Maybe a
sel TraceConfig{Map [Text] [ConfigOption]
tcOptions :: Map [Text] [ConfigOption]
tcOptions :: TraceConfig -> Map [Text] [ConfigOption]
tcOptions} [Text]
ns =
  [Maybe a] -> Maybe a
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum ([Maybe a] -> Maybe a) -> [Maybe a] -> Maybe a
forall a b. (a -> b) -> a -> b
$ ([Text] -> Maybe a) -> [[Text]] -> [Maybe a]
forall a b. (a -> b) -> [a] -> [b]
map [Text] -> Maybe a
tryLookup ([[Text]] -> [Maybe a]) -> [[Text]] -> [Maybe a]
forall a b. (a -> b) -> a -> b
$ [[Text]] -> [[Text]]
forall a. [a] -> [a]
reverse ([[Text]] -> [[Text]]) -> [[Text]] -> [[Text]]
forall a b. (a -> b) -> a -> b
$ [Text] -> [[Text]]
forall a. [a] -> [[a]]
inits [Text]
ns
  where
    tryLookup :: [Text] -> Maybe a
tryLookup [Text]
k = [a] -> Maybe a
forall a. [a] -> Maybe a
listToMaybe ([a] -> Maybe a)
-> ([ConfigOption] -> [a]) -> [ConfigOption] -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ConfigOption -> Maybe a) -> [ConfigOption] -> [a]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ConfigOption -> Maybe a
sel ([ConfigOption] -> Maybe a) -> Maybe [ConfigOption] -> Maybe a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Text] -> Map [Text] [ConfigOption] -> Maybe [ConfigOption]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup [Text]
k Map [Text] [ConfigOption]
tcOptions