    {-# LANGUAGE Rank2Types #-}
    {-# LANGUAGE ImplicitParams #-}
    {-# LANGUAGE ConstraintKinds #-}
    {-# LANGUAGE NondecreasingIndentation #-}
    -- | Description: Log msgs via a synchronized channel
    --
    -- Log msgs via a synchronized channel.
    --
    -- With inspiration from the @monad-logger@ package.
    --
    -- See examples in 'SemMC.Log.Tests'.
    --
    -- WARNING: loggers that automatically infer the call stack (via
    -- `Ghc.HasCallStack`) are not composable, in that they infer a call
    -- stack at their call site. So, if you use one to build up another
    -- log function, then that derived log function will infer bogus call
    -- sites! Of course, it's pretty easy to write
    --
    --     writeLogEvent logCfg level msg
    --
    -- when defining a new logger, so not a big deal, just something to
    -- watch out for.
    module What4.Serialize.Log (
      -- * Misc
      LogLevel(..),
      LogEvent(..),
      LogMsg,
      Ghc.HasCallStack,
      -- * Implicit param logger interface
      HasLogCfg,
      logIO,
      logTrace,
      withLogCfg,
      getLogCfg,
      -- * Explicit parameter logger interface
      logIOWith,
      logEndWith,
      writeLogEvent,
      -- * Monadic logger interface
      MonadHasLogCfg(..),
      logM,
      -- * Configuration
      LogCfg,
      mkLogCfg,
      mkNonLogCfg,
      withLogging,
      -- * Log consumers
      stdErrLogEventConsumer,
      fileLogEventConsumer,
      tmpFileLogEventConsumer,
      -- * Log formatting and consumption (useful for 3rd-party consumers)
      prettyLogEvent,
      consumeUntilEnd,
      -- * Named threads
      named,
      namedIO,
      namedM
      ) where

    import qualified GHC.Stack as Ghc

    import qualified Control.Concurrent as Cc
    import qualified Control.Exception as Cc
    import           Control.Monad (when)

    import qualified Data.Time.Clock as T
    import qualified Data.Time.Format as T

    import qualified System.IO as IO
    import qualified System.IO.Unsafe as IO

    import qualified UnliftIO as U

    import qualified Control.Concurrent.STM as Stm
    import qualified Control.Concurrent.BoundedChan as BC
    import           Control.Monad.IO.Class ( MonadIO, liftIO )
    import           Data.Map.Strict ( Map )
    import qualified Data.Map.Strict as Map
    import           System.Directory ( createDirectoryIfMissing, getTemporaryDirectory )
    import           Text.Printf ( printf )

    import Debug.Trace

    ----------------------------------------------------------------
    -- * API

    -- | Log levels, in increasing severity/precedence order.
    data LogLevel = Debug -- ^ Fine details
                  | Info  -- ^ Tracking progress
                  | Warn  -- ^ Something notable or suspicious
                  | Error -- ^ Something bad
                  deriving (Int -> LogLevel -> ThreadId -> ThreadId
    [LogLevel] -> ThreadId -> ThreadId
    LogLevel -> ThreadId
    (Int -> LogLevel -> ThreadId -> ThreadId)
    -> (LogLevel -> ThreadId)
    -> ([LogLevel] -> ThreadId -> ThreadId)
    -> Show LogLevel
    forall a.
    (Int -> a -> ThreadId -> ThreadId)
    -> (a -> ThreadId) -> ([a] -> ThreadId -> ThreadId) -> Show a
    $cshowsPrec :: Int -> LogLevel -> ThreadId -> ThreadId
    showsPrec :: Int -> LogLevel -> ThreadId -> ThreadId
    $cshow :: LogLevel -> ThreadId
    show :: LogLevel -> ThreadId
    $cshowList :: [LogLevel] -> ThreadId -> ThreadId
    showList :: [LogLevel] -> ThreadId -> ThreadId
    Show, LogLevel -> LogLevel -> Bool
    (LogLevel -> LogLevel -> Bool)
    -> (LogLevel -> LogLevel -> Bool) -> Eq LogLevel
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: LogLevel -> LogLevel -> Bool
    == :: LogLevel -> LogLevel -> Bool
    $c/= :: LogLevel -> LogLevel -> Bool
    /= :: LogLevel -> LogLevel -> Bool
    Eq, Eq LogLevel
    Eq LogLevel =>
    (LogLevel -> LogLevel -> Ordering)
    -> (LogLevel -> LogLevel -> Bool)
    -> (LogLevel -> LogLevel -> Bool)
    -> (LogLevel -> LogLevel -> Bool)
    -> (LogLevel -> LogLevel -> Bool)
    -> (LogLevel -> LogLevel -> LogLevel)
    -> (LogLevel -> LogLevel -> LogLevel)
    -> Ord LogLevel
    LogLevel -> LogLevel -> Bool
    LogLevel -> LogLevel -> Ordering
    LogLevel -> LogLevel -> LogLevel
    forall a.
    Eq a =>
    (a -> a -> Ordering)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> a)
    -> (a -> a -> a)
    -> Ord a
    $ccompare :: LogLevel -> LogLevel -> Ordering
    compare :: LogLevel -> LogLevel -> Ordering
    $c< :: LogLevel -> LogLevel -> Bool
    < :: LogLevel -> LogLevel -> Bool
    $c<= :: LogLevel -> LogLevel -> Bool
    <= :: LogLevel -> LogLevel -> Bool
    $c> :: LogLevel -> LogLevel -> Bool
    > :: LogLevel -> LogLevel -> Bool
    $c>= :: LogLevel -> LogLevel -> Bool
    >= :: LogLevel -> LogLevel -> Bool
    $cmax :: LogLevel -> LogLevel -> LogLevel
    max :: LogLevel -> LogLevel -> LogLevel
    $cmin :: LogLevel -> LogLevel -> LogLevel
    min :: LogLevel -> LogLevel -> LogLevel
    Ord, ReadPrec [LogLevel]
    ReadPrec LogLevel
    Int -> ReadS LogLevel
    ReadS [LogLevel]
    (Int -> ReadS LogLevel)
    -> ReadS [LogLevel]
    -> ReadPrec LogLevel
    -> ReadPrec [LogLevel]
    -> Read LogLevel
    forall a.
    (Int -> ReadS a)
    -> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
    $creadsPrec :: Int -> ReadS LogLevel
    readsPrec :: Int -> ReadS LogLevel
    $creadList :: ReadS [LogLevel]
    readList :: ReadS [LogLevel]
    $creadPrec :: ReadPrec LogLevel
    readPrec :: ReadPrec LogLevel
    $creadListPrec :: ReadPrec [LogLevel]
    readListPrec :: ReadPrec [LogLevel]
    Read)

    type LogMsg = String

    ----------------------------------------------------------------
    -- ** Implicit param logger interface

    -- | Access to the log config.
    --
    -- Users should prefer 'withLogCfg' to binding the implicit param. The
    -- implicit param is an implementation detail, and we could change the
    -- implementation later, e.g. to use the @reflection@ package.
    --
    -- We use an implicit param to avoid having to change all code in 'IO'
    -- that wants to log to be in 'MonadHasLogCfg' and 'MonadIO' classes.
    --
    -- An even more convenient but more \"unsafe\" implementation would
    -- store the 'LogCfg' in a global, 'unsafePerformIO'd 'IORef'
    -- (cf. @uniqueSource@ in 'Data.Unique').
    type HasLogCfg = (?logCfg :: LogCfg)

    -- | Satisfy a 'HasLogCfg' constraint.
    --
    -- Users can call this function instead of using @ImplicitParams@
    -- themselves.
    withLogCfg :: LogCfg -> (HasLogCfg => a) -> a
    withLogCfg :: forall a. LogCfg -> (HasLogCfg => a) -> a
    withLogCfg LogCfg
    logCfg HasLogCfg => a
    x = let ?logCfg = HasLogCfg
    LogCfg
    logCfg in a
    HasLogCfg => a
    x

    -- | Recover the log config.
    --
    -- Useful for going between implicit and monadic interfaces. E.g.
    --
    -- > flip runReaderT getLogCfg ...
    getLogCfg :: HasLogCfg => LogCfg
    getLogCfg :: HasLogCfg => LogCfg
    getLogCfg = HasLogCfg
    LogCfg
    ?logCfg

    -- | Log in a 'MonadIO'.
    --
    -- If you want the name of function that called 'log' to be included
    -- in the output, then you need to add a 'Ghc.HasCallStack' constraint
    -- to it as well (see 'LogC'). Otherwise, one of two things will happen:
    --
    -- - if no enclosing function has a 'Ghc.HasCallStack' constraint,
    --   then '???' will be used for the enclosing function name.
    --
    -- - if at least one enclosing function has a 'Ghc.HasCallStack'
    --   constraint, then the name of the *closest* enclosing function
    --   with that constraint will be used for the enclosing function
    --   name. So, for example, if you define @outer@ by
    --
    --   > outer :: (MonadHasLogCfg m, Ghc.HasCallStack) => m Int
    --   > outer = inner
    --   >   where
    --   >     inner = do
    --   >       log Debug "Inside 'inner' ..."
    --   >       return 42
    --
    --   then the call to 'log' in @inner@ will have \"outer\" as the
    --   enclosing function name.
    logIO :: (HasLogCfg, Ghc.HasCallStack, MonadIO m)
          => LogLevel -> LogMsg -> m ()
    logIO :: forall (m :: Type -> Type).
    (HasLogCfg, HasCallStack, MonadIO m) =>
    LogLevel -> ThreadId -> m ()
    logIO LogLevel
    level ThreadId
    msg = do
      IO () -> m ()
    forall a. IO a -> m a
    forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
    liftIO (IO () -> m ()) -> IO () -> m ()
    forall a b. (a -> b) -> a -> b
    $ LogCfg -> CallStack -> LogLevel -> ThreadId -> IO ()
    writeLogEvent HasLogCfg
    LogCfg
    ?logCfg CallStack
    HasCallStack => CallStack
    Ghc.callStack LogLevel
    level ThreadId
    msg

    -- | 'logIO' with an explicit config
    logIOWith :: (Ghc.HasCallStack, MonadIO m) => LogCfg -> LogLevel -> LogMsg -> m ()
    logIOWith :: forall (m :: Type -> Type).
    (HasCallStack, MonadIO m) =>
    LogCfg -> LogLevel -> ThreadId -> m ()
    logIOWith LogCfg
    cfg LogLevel
    level ThreadId
    msg =
      IO () -> m ()
    forall a. IO a -> m a
    forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
    liftIO (IO () -> m ()) -> IO () -> m ()
    forall a b. (a -> b) -> a -> b
    $ LogCfg -> CallStack -> LogLevel -> ThreadId -> IO ()
    writeLogEvent LogCfg
    cfg CallStack
    HasCallStack => CallStack
    Ghc.callStack LogLevel
    level ThreadId
    msg

    -- | Log in pure code using 'unsafePerformIO', like 'Debug.Trace'.
    --
    -- See 'logIO'.
    logTrace :: (HasLogCfg, Ghc.HasCallStack) => LogLevel -> LogMsg -> a -> a
    logTrace :: forall a.
    (HasLogCfg, HasCallStack) =>
    LogLevel -> ThreadId -> a -> a
    logTrace LogLevel
    level ThreadId
    msg a
    x = IO a -> a
    forall a. IO a -> a
    IO.unsafePerformIO (IO a -> a) -> IO a -> a
    forall a b. (a -> b) -> a -> b
    $ do
      LogCfg -> CallStack -> LogLevel -> ThreadId -> IO ()
    writeLogEvent HasLogCfg
    LogCfg
    ?logCfg CallStack
    HasCallStack => CallStack
    Ghc.callStack LogLevel
    level ThreadId
    msg
      a -> IO a
    forall a. a -> IO a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return a
    x
    {-# NOINLINE logTrace #-}

    ----------------------------------------------------------------
    -- ** Monadic logger interface

    -- | Monads with logger configuration.
    class MonadHasLogCfg m where
      getLogCfgM :: m LogCfg

    -- | Log in a 'MonadHasLogCfg'.
    --
    -- See 'logIO'.
    logM :: (MonadHasLogCfg m, Ghc.HasCallStack, MonadIO m)
         => LogLevel -> LogMsg -> m ()
    logM :: forall (m :: Type -> Type).
    (MonadHasLogCfg m, HasCallStack, MonadIO m) =>
    LogLevel -> ThreadId -> m ()
    logM LogLevel
    level ThreadId
    msg = do
      logCfg <- m LogCfg
    forall (m :: Type -> Type). MonadHasLogCfg m => m LogCfg
    getLogCfgM
      liftIO $ writeLogEvent logCfg Ghc.callStack level msg

    -- | Signal to the log consumer that there are no more log messages and
    -- terminate the log consumer.  This is useful for cases where the logger is
    -- running in a separate thread and the parent thread wants to wait until the
    -- logger has finished logging and has successfully flushed all log messages
    -- before terminating it.
    logEndWith :: LogCfg -> IO ()
    logEndWith :: LogCfg -> IO ()
    logEndWith LogCfg
    cfg = case LogCfg -> Maybe (BoundedChan (Maybe LogEvent))
    lcChan LogCfg
    cfg of
                       Just BoundedChan (Maybe LogEvent)
    c -> BoundedChan (Maybe LogEvent) -> Maybe LogEvent -> IO ()
    forall a. BoundedChan a -> a -> IO ()
    BC.writeChan BoundedChan (Maybe LogEvent)
    c Maybe LogEvent
    forall a. Maybe a
    Nothing
                       Maybe (BoundedChan (Maybe LogEvent))
    Nothing -> () -> IO ()
    forall a. a -> IO a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return ()

    ----------------------------------------------------------------
    -- ** Initialization

    -- | Initialize a 'LogCfg'.
    --
    -- The first argument is the human friendly name to assign to the
    -- current thread. Since logging should be configured as soon as
    -- possible on startup, \"main\" is probably the right name.
    --
    -- See 'asyncNamed' for naming other threads.
    --
    -- Need to start a log event consumer in another thread,
    -- e.g. 'stdErrLogEventConsumer', if you want anything to happen with
    -- the log events.
    mkLogCfg :: String -> IO LogCfg
    mkLogCfg :: ThreadId -> IO LogCfg
    mkLogCfg ThreadId
    threadName = do
      chan <- Int -> IO (BoundedChan (Maybe LogEvent))
    forall a. Int -> IO (BoundedChan a)
    BC.newBoundedChan Int
    100
      threadMap <- do
        tid <- show <$> Cc.myThreadId
        return $ Map.fromList [ (tid, threadName) ]
      threadMapVar <- Stm.newTVarIO threadMap
      return $ LogCfg { lcChan = Just chan
                      , lcThreadMap = threadMapVar }

    -- | Initialize a 'LogCfg' that does no logging.
    --
    -- This can be used as a LogCfg when no logging is to be performed.
    -- Runtime overhead is smaller when this configuration is specified at
    -- compile time.
    mkNonLogCfg :: IO LogCfg
    mkNonLogCfg :: IO LogCfg
    mkNonLogCfg = do tmVar <- Map ThreadId ThreadId -> IO (TVar (Map ThreadId ThreadId))
    forall a. a -> IO (TVar a)
    Stm.newTVarIO Map ThreadId ThreadId
    forall k a. Map k a
    Map.empty
                     return LogCfg { lcChan = Nothing
                                   , lcThreadMap = tmVar
                                   }

    -- | Run an action with the given log event consumer.
    --
    -- In particular this provides an easy way to run one-off computations
    -- that assume logging, e.g. in GHCi. Spawns the log even consumer
    -- before running the action and cleans up the log event consumer
    -- afterwards.
    withLogging :: (U.MonadUnliftIO m, MonadIO m)
                => String -> (LogCfg -> IO ()) -> (HasLogCfg => m a) -> m a
    withLogging :: forall (m :: Type -> Type) a.
    (MonadUnliftIO m, MonadIO m) =>
    ThreadId -> (LogCfg -> IO ()) -> (HasLogCfg => m a) -> m a
    withLogging ThreadId
    threadName LogCfg -> IO ()
    logEventConsumer HasLogCfg => m a
    action = do
      cfg <- IO LogCfg -> m LogCfg
    forall a. IO a -> m a
    forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
    liftIO (IO LogCfg -> m LogCfg) -> IO LogCfg -> m LogCfg
    forall a b. (a -> b) -> a -> b
    $ ThreadId -> IO LogCfg
    mkLogCfg ThreadId
    threadName
      U.withAsync (liftIO $ logEventConsumer cfg) $ \Async ()
    a -> do
      x <- LogCfg -> (HasLogCfg => m a) -> m a
    forall a. LogCfg -> (HasLogCfg => a) -> a
    withLogCfg LogCfg
    cfg m a
    HasLogCfg => m a
    action
      liftIO $ logEndWith cfg
      U.wait a
      return x

    ----------------------------------------------------------------
    -- ** Log event consumers

    -- | Consume a log channel until it receives a shutdown message
    -- (i.e. a 'Nothing').
    --
    -- Only messages that satisfy the predicate will be passed to the
    -- continuation. For example, using @const True@ will process all log
    -- messages, and using @(>= Info) . leLevel@ will only process
    -- messsages with 'LogLevel' equal to 'Info' or higher, ignoring
    -- 'Debug' level messages.
    consumeUntilEnd ::
      (LogEvent -> Bool) -> (LogEvent -> IO ()) -> LogCfg -> IO ()
    consumeUntilEnd :: (LogEvent -> Bool) -> (LogEvent -> IO ()) -> LogCfg -> IO ()
    consumeUntilEnd LogEvent -> Bool
    keepEvent LogEvent -> IO ()
    k LogCfg
    cfg =
      case LogCfg -> Maybe (BoundedChan (Maybe LogEvent))
    lcChan LogCfg
    cfg of
        Maybe (BoundedChan (Maybe LogEvent))
    Nothing -> () -> IO ()
    forall a. a -> IO a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return ()
        Just BoundedChan (Maybe LogEvent)
    c -> do
          mevent <- BoundedChan (Maybe LogEvent) -> IO (Maybe LogEvent)
    forall a. BoundedChan a -> IO a
    BC.readChan BoundedChan (Maybe LogEvent)
    c
          case mevent of
            Just LogEvent
    event -> do Bool -> IO () -> IO ()
    forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
    when (LogEvent -> Bool
    keepEvent LogEvent
    event) (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ LogEvent -> IO ()
    k LogEvent
    event
                             (LogEvent -> Bool) -> (LogEvent -> IO ()) -> LogCfg -> IO ()
    consumeUntilEnd LogEvent -> Bool
    keepEvent LogEvent -> IO ()
    k LogCfg
    cfg
            Maybe LogEvent
    _ -> () -> IO ()
    forall a. a -> IO a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return ()

    -- | A log event consumer that prints formatted log events to stderr.
    stdErrLogEventConsumer :: (LogEvent -> Bool) -> LogCfg -> IO ()
    stdErrLogEventConsumer :: (LogEvent -> Bool) -> LogCfg -> IO ()
    stdErrLogEventConsumer LogEvent -> Bool
    keepEvent =
      (LogEvent -> Bool) -> (LogEvent -> IO ()) -> LogCfg -> IO ()
    consumeUntilEnd LogEvent -> Bool
    keepEvent ((LogEvent -> IO ()) -> LogCfg -> IO ())
    -> (LogEvent -> IO ()) -> LogCfg -> IO ()
    forall a b. (a -> b) -> a -> b
    $ \LogEvent
    e -> do
        -- Use 'traceIO' because it seems to be atomic in practice,
        -- avoiding problems with interleaving output from other sources.
        ThreadId -> IO ()
    traceIO (LogEvent -> ThreadId
    prettyLogEvent LogEvent
    e)
        Handle -> IO ()
    IO.hFlush Handle
    IO.stderr -- Probably unnecessary.

    -- | A logger that writes to a user-specified file
    --
    -- Note that logs are opened in the 'w' mode (i.e., overwrite).  Callers should
    -- preserve old log files if they really want.
    fileLogEventConsumer :: FilePath -> (LogEvent -> Bool) -> LogCfg -> IO ()
    fileLogEventConsumer :: ThreadId -> (LogEvent -> Bool) -> LogCfg -> IO ()
    fileLogEventConsumer ThreadId
    fp LogEvent -> Bool
    keepEvent LogCfg
    cfg = ThreadId -> IOMode -> (Handle -> IO ()) -> IO ()
    forall r. ThreadId -> IOMode -> (Handle -> IO r) -> IO r
    IO.withFile ThreadId
    fp IOMode
    IO.WriteMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
    forall a b. (a -> b) -> a -> b
    $ \Handle
    h -> do
      let k :: LogEvent -> IO ()
    k LogEvent
    e = Handle -> ThreadId -> IO ()
    IO.hPutStrLn Handle
    h (LogEvent -> ThreadId
    prettyLogEvent LogEvent
    e) IO () -> IO () -> IO ()
    forall a b. IO a -> IO b -> IO b
    forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
    >> Handle -> IO ()
    IO.hFlush Handle
    h
      (LogEvent -> Bool) -> (LogEvent -> IO ()) -> LogCfg -> IO ()
    consumeUntilEnd LogEvent -> Bool
    keepEvent LogEvent -> IO ()
    k LogCfg
    cfg

    -- | A log event consumer that writes formatted log events to a tmp
    -- file.
    tmpFileLogEventConsumer :: (LogEvent -> Bool) -> LogCfg -> IO ()
    tmpFileLogEventConsumer :: (LogEvent -> Bool) -> LogCfg -> IO ()
    tmpFileLogEventConsumer LogEvent -> Bool
    keepEvent LogCfg
    cfg = do
      tmpdir <- (ThreadId -> ThreadId -> ThreadId
    forall a. [a] -> [a] -> [a]
    ++ ThreadId
    "/brittle") (ThreadId -> ThreadId) -> IO ThreadId -> IO ThreadId
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    <$> IO ThreadId
    getTemporaryDirectory
      createDirectoryIfMissing True tmpdir
      (tmpFilePath, tmpFile) <- IO.openTempFile tmpdir "log.txt"
      printf "\n\nWriting logs to %s\n\n" tmpFilePath
      let k LogEvent
    e = Handle -> ThreadId -> IO ()
    IO.hPutStrLn Handle
    tmpFile (LogEvent -> ThreadId
    prettyLogEvent LogEvent
    e) IO () -> IO () -> IO ()
    forall a b. IO a -> IO b -> IO b
    forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
    >> Handle -> IO ()
    IO.hFlush Handle
    tmpFile
      consumeUntilEnd keepEvent k cfg

    ----------------------------------------------------------------
    -- ** Named threads

    -- | Run an IO action with a human friendly thread name.
    --
    -- Any existing thread name will be restored when the action finishes.
    named :: (U.MonadUnliftIO m, MonadIO m) => LogCfg -> String -> m a -> m a
    named :: forall (m :: Type -> Type) a.
    (MonadUnliftIO m, MonadIO m) =>
    LogCfg -> ThreadId -> m a -> m a
    named LogCfg
    cfg ThreadId
    threadName m a
    action = do
      actionIO <- m a -> m (IO a)
    forall (m :: Type -> Type) a. MonadUnliftIO m => m a -> m (IO a)
    U.toIO m a
    action
      liftIO $ do
        tid <- show <$> Cc.myThreadId
        mOldName <- Map.lookup tid <$> Stm.readTVarIO (lcThreadMap cfg)
        Cc.bracket_ (insert tid) (remove tid mOldName) actionIO
      where
        modify :: (Map ThreadId ThreadId -> Map ThreadId ThreadId) -> IO ()
    modify = STM () -> IO ()
    forall a. STM a -> IO a
    Stm.atomically (STM () -> IO ())
    -> ((Map ThreadId ThreadId -> Map ThreadId ThreadId) -> STM ())
    -> (Map ThreadId ThreadId -> Map ThreadId ThreadId)
    -> IO ()
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . TVar (Map ThreadId ThreadId)
    -> (Map ThreadId ThreadId -> Map ThreadId ThreadId) -> STM ()
    forall a. TVar a -> (a -> a) -> STM ()
    Stm.modifyTVar' (LogCfg -> TVar (Map ThreadId ThreadId)
    lcThreadMap LogCfg
    cfg)

        insert :: ThreadId -> IO ()
    insert ThreadId
    tid = (Map ThreadId ThreadId -> Map ThreadId ThreadId) -> IO ()
    modify ((Map ThreadId ThreadId -> Map ThreadId ThreadId) -> IO ())
    -> (Map ThreadId ThreadId -> Map ThreadId ThreadId) -> IO ()
    forall a b. (a -> b) -> a -> b
    $ ThreadId
    -> ThreadId -> Map ThreadId ThreadId -> Map ThreadId ThreadId
    forall k a. Ord k => k -> a -> Map k a -> Map k a
    Map.insert ThreadId
    tid ThreadId
    threadName

        remove :: ThreadId -> Maybe ThreadId -> IO ()
    remove ThreadId
    tid Maybe ThreadId
    Nothing        = (Map ThreadId ThreadId -> Map ThreadId ThreadId) -> IO ()
    modify ((Map ThreadId ThreadId -> Map ThreadId ThreadId) -> IO ())
    -> (Map ThreadId ThreadId -> Map ThreadId ThreadId) -> IO ()
    forall a b. (a -> b) -> a -> b
    $ ThreadId -> Map ThreadId ThreadId -> Map ThreadId ThreadId
    forall k a. Ord k => k -> Map k a -> Map k a
    Map.delete ThreadId
    tid
        remove ThreadId
    tid (Just ThreadId
    oldName) = (Map ThreadId ThreadId -> Map ThreadId ThreadId) -> IO ()
    modify ((Map ThreadId ThreadId -> Map ThreadId ThreadId) -> IO ())
    -> (Map ThreadId ThreadId -> Map ThreadId ThreadId) -> IO ()
    forall a b. (a -> b) -> a -> b
    $ ThreadId
    -> ThreadId -> Map ThreadId ThreadId -> Map ThreadId ThreadId
    forall k a. Ord k => k -> a -> Map k a -> Map k a
    Map.insert ThreadId
    tid ThreadId
    oldName

    -- | Version of 'named' for implicit log cfg.
    namedIO :: (HasLogCfg, U.MonadUnliftIO m, MonadIO m)
            => String -> m a -> m a
    namedIO :: forall (m :: Type -> Type) a.
    (HasLogCfg, MonadUnliftIO m, MonadIO m) =>
    ThreadId -> m a -> m a
    namedIO ThreadId
    threadName m a
    action = LogCfg -> ThreadId -> m a -> m a
    forall (m :: Type -> Type) a.
    (MonadUnliftIO m, MonadIO m) =>
    LogCfg -> ThreadId -> m a -> m a
    named HasLogCfg
    LogCfg
    ?logCfg ThreadId
    threadName m a
    action

    -- | Version of 'named' for 'MonadHasLogCfg' monads.
    namedM :: (MonadHasLogCfg m, U.MonadUnliftIO m, MonadIO m)
           => String -> m a -> m a
    namedM :: forall (m :: Type -> Type) a.
    (MonadHasLogCfg m, MonadUnliftIO m, MonadIO m) =>
    ThreadId -> m a -> m a
    namedM ThreadId
    threadName m a
    action = do
      cfg <- m LogCfg
    forall (m :: Type -> Type). MonadHasLogCfg m => m LogCfg
    getLogCfgM
      named cfg threadName action

    ----------------------------------------------------------------
    -- * Internals

    -- | Stored as 'String' because 'Control.Concurrent.ThreadId' docs say
    -- a thread can't be GC'd as long as someone maintains a reference to
    -- its 'ThreadId'!!!
    type ThreadId = String

    -- | A log event.
    --
    -- Can be converted to a string later, or thrown away.
    data LogEvent = LogEvent
      { LogEvent -> (Maybe ThreadId, SrcLoc)
    leCallSite :: (Maybe String, Ghc.SrcLoc)
        -- ^ The @Maybe String@ is the name of the enclosing function in
        -- which the logging function was called. Not always available,
        -- since it depends on the enclosing function having a
        -- 'Ghc.HasCallStack' constraint.
      , LogEvent -> LogLevel
    leLevel    :: LogLevel
      , LogEvent -> ThreadId
    leMsg      :: LogMsg
      , LogEvent -> ThreadId
    leThreadId :: ThreadId
        -- ^ ID of thread that generated the event.
      , LogEvent -> UTCTime
    leTime     :: T.UTCTime
      }

    -- | Logging configuration.
    data LogCfg = LogCfg
      { LogCfg -> Maybe (BoundedChan (Maybe LogEvent))
    lcChan :: Maybe (BC.BoundedChan (Maybe LogEvent))
      , LogCfg -> TVar (Map ThreadId ThreadId)
    lcThreadMap :: Stm.TVar (Map ThreadId String)
        -- ^ User friendly names for threads. See 'asyncNamed'.

      -- Idea: add a predicate on log events that is used to discard log
      -- events that e.g. aren't of a high enough precedence
      -- level. E.g. only keep events of level 'Warn' or above:
      --
      -- > lcPred le = leLevel le >= Warn
      --
      -- , lcPred :: LogEvent -> Bool
      }

    -- | Format a log event.
    prettyLogEvent :: LogEvent -> String
    prettyLogEvent :: LogEvent -> ThreadId
    prettyLogEvent LogEvent
    le =
      ThreadId
    -> ThreadId
    -> ThreadId
    -> ThreadId
    -> ThreadId
    -> ThreadId
    -> ThreadId
    forall r. PrintfType r => ThreadId -> r
    printf ThreadId
    "[%s][%s][%s][%s]\n%s"
        (LogLevel -> ThreadId
    forall a. Show a => a -> ThreadId
    show (LogLevel -> ThreadId) -> LogLevel -> ThreadId
    forall a b. (a -> b) -> a -> b
    $ LogEvent -> LogLevel
    leLevel LogEvent
    le) ThreadId
    time ThreadId
    location (LogEvent -> ThreadId
    leThreadId LogEvent
    le) (LogEvent -> ThreadId
    leMsg LogEvent
    le)
      where
        time :: String
        time :: ThreadId
    time = TimeLocale -> ThreadId -> UTCTime -> ThreadId
    forall t. FormatTime t => TimeLocale -> ThreadId -> t -> ThreadId
    T.formatTime TimeLocale
    T.defaultTimeLocale ThreadId
    "%T" (LogEvent -> UTCTime
    leTime LogEvent
    le)
        location :: String
        location :: ThreadId
    location = ThreadId -> ThreadId -> ThreadId -> ThreadId
    forall r. PrintfType r => ThreadId -> r
    printf ThreadId
    "%s:%s"
          (Maybe ThreadId -> ThreadId
    prettyFun Maybe ThreadId
    maybeFun) (SrcLoc -> ThreadId
    Ghc.prettySrcLoc SrcLoc
    srcLoc)
        (Maybe ThreadId
    maybeFun, SrcLoc
    srcLoc) = LogEvent -> (Maybe ThreadId, SrcLoc)
    leCallSite LogEvent
    le
        prettyFun :: Maybe ThreadId -> ThreadId
    prettyFun Maybe ThreadId
    Nothing = ThreadId
    "???"
        prettyFun (Just ThreadId
    fun) = ThreadId
    fun

    prettyThreadId :: LogCfg -> ThreadId -> IO ThreadId
    prettyThreadId :: LogCfg -> ThreadId -> IO ThreadId
    prettyThreadId LogCfg
    cfg ThreadId
    tid = do
      mThreadName <- ThreadId -> Map ThreadId ThreadId -> Maybe ThreadId
    forall k a. Ord k => k -> Map k a -> Maybe a
    Map.lookup ThreadId
    tid (Map ThreadId ThreadId -> Maybe ThreadId)
    -> IO (Map ThreadId ThreadId) -> IO (Maybe ThreadId)
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    <$> TVar (Map ThreadId ThreadId) -> IO (Map ThreadId ThreadId)
    forall a. TVar a -> IO a
    Stm.readTVarIO (LogCfg -> TVar (Map ThreadId ThreadId)
    lcThreadMap LogCfg
    cfg)
      return $ printf "%s (%s)" (maybe "???" id mThreadName) tid

    -- | Write a 'LogEvent' to the underlying channel.
    --
    -- This is a low-level function. See 'logIO', 'logM', and 'logTrace'
    -- for a high-level interface that supplies the 'LogCfg' and
    -- 'Ghc.CallStack' parameters automatically.
    --
    -- However, those functions can't be used to build up custom loggers,
    -- since they infer call stack information automatically. If you want
    -- to define a custom logger (even something simple like
    --
    -- > debug msg = logM Debug msg
    --
    -- ) then use 'writeLogEvent'.
    writeLogEvent :: LogCfg -> Ghc.CallStack -> LogLevel -> LogMsg -> IO ()
    writeLogEvent :: LogCfg -> CallStack -> LogLevel -> ThreadId -> IO ()
    writeLogEvent LogCfg
    cfg CallStack
    cs LogLevel
    level ThreadId
    msg = do
      tid <- ThreadId -> ThreadId
    forall a. Show a => a -> ThreadId
    show (ThreadId -> ThreadId) -> IO ThreadId -> IO ThreadId
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    <$> IO ThreadId
    Cc.myThreadId
      ptid <- prettyThreadId cfg tid
      time <- T.getCurrentTime
      case lcChan cfg of
        Maybe (BoundedChan (Maybe LogEvent))
    Nothing -> () -> IO ()
    forall a. a -> IO a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return ()
        Just BoundedChan (Maybe LogEvent)
    c -> BoundedChan (Maybe LogEvent) -> Maybe LogEvent -> IO ()
    forall a. BoundedChan a -> a -> IO ()
    BC.writeChan BoundedChan (Maybe LogEvent)
    c (LogEvent -> Maybe LogEvent
    forall a. a -> Maybe a
    Just (ThreadId -> UTCTime -> LogEvent
    event ThreadId
    ptid UTCTime
    time))
      where
        event :: ThreadId -> UTCTime -> LogEvent
    event ThreadId
    tid UTCTime
    time = LogEvent
          { leCallSite :: (Maybe ThreadId, SrcLoc)
    leCallSite = (Maybe ThreadId, SrcLoc)
    callSite
          , leLevel :: LogLevel
    leLevel = LogLevel
    level
          , leMsg :: ThreadId
    leMsg = ThreadId
    msg
          , leThreadId :: ThreadId
    leThreadId = ThreadId
    tid
          , leTime :: UTCTime
    leTime = UTCTime
    time
          }
        -- | The call stack has the most recent call first. Assuming
        -- 'writeLogEvent' is always called in a logging function with a
        -- 'Ghc.HasCallStack' constraint, the call stack will be non-empty
        -- -- i.e. @topSrcLoc@ will be defined -- but there may not be a
        -- lower frame corresponding to the context in which the logging
        -- function was called. To get a lower frame, some enclosing
        -- function needs a 'Ghc.HasCallStack' constraint itself.
        --
        -- And only functions with 'Ghc.HasCallStack' will get frames. See
        -- discussion at 'log'.
        callSite :: (Maybe ThreadId, SrcLoc)
    callSite = case CallStack -> [(ThreadId, SrcLoc)]
    Ghc.getCallStack CallStack
    cs of
                     (ThreadId
    _,SrcLoc
    topSrcLoc):[(ThreadId, SrcLoc)]
    rest -> case [(ThreadId, SrcLoc)]
    rest of
                       []                 -> (Maybe ThreadId
    forall a. Maybe a
    Nothing,           SrcLoc
    topSrcLoc)
                       (ThreadId
    enclosingFun,SrcLoc
    _):[(ThreadId, SrcLoc)]
    _ -> (ThreadId -> Maybe ThreadId
    forall a. a -> Maybe a
    Just ThreadId
    enclosingFun, SrcLoc
    topSrcLoc)
                     [] -> ThreadId -> (Maybe ThreadId, SrcLoc)
    forall a. HasCallStack => ThreadId -> a
    error ThreadId
    "Do we ever not have a call site?"