{-# 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
logCfg <- m LogCfg
forall (m :: Type -> Type). MonadHasLogCfg m => m LogCfg
getLogCfgM
  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
logCfg CallStack
HasCallStack => CallStack
Ghc.callStack LogLevel
level ThreadId
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
  BoundedChan (Maybe LogEvent)
chan <- Int -> IO (BoundedChan (Maybe LogEvent))
forall a. Int -> IO (BoundedChan a)
BC.newBoundedChan Int
100
  Map ThreadId ThreadId
threadMap <- do
    ThreadId
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
    Map ThreadId ThreadId -> IO (Map ThreadId ThreadId)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Map ThreadId ThreadId -> IO (Map ThreadId ThreadId))
-> Map ThreadId ThreadId -> IO (Map ThreadId ThreadId)
forall a b. (a -> b) -> a -> b
$ [(ThreadId, ThreadId)] -> Map ThreadId ThreadId
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (ThreadId
tid, ThreadId
threadName) ]
  TVar (Map ThreadId ThreadId)
threadMapVar <- Map ThreadId ThreadId -> IO (TVar (Map ThreadId ThreadId))
forall a. a -> IO (TVar a)
Stm.newTVarIO Map ThreadId ThreadId
threadMap
  LogCfg -> IO LogCfg
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (LogCfg -> IO LogCfg) -> LogCfg -> IO LogCfg
forall a b. (a -> b) -> a -> b
$ LogCfg { lcChan :: Maybe (BoundedChan (Maybe LogEvent))
lcChan = BoundedChan (Maybe LogEvent)
-> Maybe (BoundedChan (Maybe LogEvent))
forall a. a -> Maybe a
Just BoundedChan (Maybe LogEvent)
chan
                  , lcThreadMap :: TVar (Map ThreadId ThreadId)
lcThreadMap = TVar (Map ThreadId ThreadId)
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 TVar (Map ThreadId ThreadId)
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
                 LogCfg -> IO LogCfg
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return LogCfg { lcChan :: Maybe (BoundedChan (Maybe LogEvent))
lcChan = Maybe (BoundedChan (Maybe LogEvent))
forall a. Maybe a
Nothing
                               , lcThreadMap :: TVar (Map ThreadId ThreadId)
lcThreadMap = TVar (Map ThreadId ThreadId)
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
  LogCfg
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
  m () -> (Async () -> m a) -> m a
forall (m :: Type -> Type) a b.
MonadUnliftIO m =>
m a -> (Async a -> m b) -> m b
U.withAsync (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 -> IO ()
logEventConsumer LogCfg
cfg) ((Async () -> m a) -> m a) -> (Async () -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \Async ()
a -> do
  a
x <- LogCfg -> (HasLogCfg => m a) -> m a
forall a. LogCfg -> (HasLogCfg => a) -> a
withLogCfg LogCfg
cfg m a
HasLogCfg => m a
action
  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 -> IO ()
logEndWith LogCfg
cfg
  Async () -> m ()
forall (m :: Type -> Type) a. MonadIO m => Async a -> m a
U.wait Async ()
a
  a -> m a
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return a
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
      Maybe LogEvent
mevent <- BoundedChan (Maybe LogEvent) -> IO (Maybe LogEvent)
forall a. BoundedChan a -> IO a
BC.readChan BoundedChan (Maybe LogEvent)
c
      case Maybe LogEvent
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
  ThreadId
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
  Bool -> ThreadId -> IO ()
createDirectoryIfMissing Bool
True ThreadId
tmpdir
  (ThreadId
tmpFilePath, Handle
tmpFile) <- ThreadId -> ThreadId -> IO (ThreadId, Handle)
IO.openTempFile ThreadId
tmpdir ThreadId
"log.txt"
  ThreadId -> ThreadId -> IO ()
forall r. PrintfType r => ThreadId -> r
printf ThreadId
"\n\nWriting logs to %s\n\n" ThreadId
tmpFilePath
  let k :: LogEvent -> IO ()
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
  (LogEvent -> Bool) -> (LogEvent -> IO ()) -> LogCfg -> IO ()
consumeUntilEnd LogEvent -> Bool
keepEvent LogEvent -> IO ()
k LogCfg
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
  IO a
actionIO <- m a -> m (IO a)
forall (m :: Type -> Type) a. MonadUnliftIO m => m a -> m (IO a)
U.toIO m a
action
  IO a -> m a
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ do
    ThreadId
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
    Maybe ThreadId
mOldName <- 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)
    IO () -> IO () -> IO a -> IO a
forall a b c. IO a -> IO b -> IO c -> IO c
Cc.bracket_ (ThreadId -> IO ()
insert ThreadId
tid) (ThreadId -> Maybe ThreadId -> IO ()
remove ThreadId
tid Maybe ThreadId
mOldName) IO a
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
  LogCfg
cfg <- m LogCfg
forall (m :: Type -> Type). MonadHasLogCfg m => m LogCfg
getLogCfgM
  LogCfg -> ThreadId -> m a -> m a
forall (m :: Type -> Type) a.
(MonadUnliftIO m, MonadIO m) =>
LogCfg -> ThreadId -> m a -> m a
named LogCfg
cfg ThreadId
threadName m a
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
  Maybe ThreadId
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)
  ThreadId -> IO ThreadId
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (ThreadId -> IO ThreadId) -> ThreadId -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ ThreadId -> ThreadId -> ThreadId -> ThreadId
forall r. PrintfType r => ThreadId -> r
printf ThreadId
"%s (%s)" (ThreadId -> (ThreadId -> ThreadId) -> Maybe ThreadId -> ThreadId
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ThreadId
"???" ThreadId -> ThreadId
forall a. a -> a
id Maybe ThreadId
mThreadName) ThreadId
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
  ThreadId
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
  ThreadId
ptid <- LogCfg -> ThreadId -> IO ThreadId
prettyThreadId LogCfg
cfg ThreadId
tid
  UTCTime
time <- IO UTCTime
T.getCurrentTime
  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 -> 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?"