Simple.hs

{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}
-- | Implementation of "Imm.Logger" based on @fast-logger@.
-- For further information, please consult "System.Log.FastLogger".
module Imm.Logger.Simple (module Imm.Logger.Simple, module Reexport) where

-- {{{ Imports
import           Imm.Logger                                as Reexport
import           Imm.Prelude
import           Imm.Pretty

import           Control.Concurrent.MVar.Lifted
import           Control.Monad.Trans.Reader
import           Data.Text.Prettyprint.Doc.Render.Terminal
import           System.Log.FastLogger                     as Reexport
-- }}}

data LoggerSettings = LoggerSettings
  { _loggerSet      :: LoggerSet  -- ^ 'LoggerSet' used for 'Debug', 'Info' and 'Warning' logs
  , _errorLoggerSet :: LoggerSet  -- ^ 'LoggerSet' used for 'Error' logs
  , _logLevel       :: LogLevel   -- ^ Discard logs that are strictly less serious than this level
  , _colorizeLogs   :: Bool       -- ^ Enable log colorisation
  }

-- | Default logger forwards error messages to stderr, and other messages to stdout.
defaultLogger :: IO (MVar LoggerSettings)
defaultLogger = newMVar =<< LoggerSettings
  <$> newStdoutLoggerSet defaultBufSize
  <*> newStderrLoggerSet defaultBufSize
  <*> pure Info
  <*> pure True

instance MonadLog (ReaderT (MVar LoggerSettings) IO) where
  -- log :: LogLevel -> Doc -> m ()
  log l t = do
    settings <- readMVar =<< ask
    let loggerSet = (if l == Error then _errorLoggerSet else _loggerSet) settings
        handleColor = (\c -> if c then id else unAnnotate) $ _colorizeLogs settings
        refLevel = _logLevel settings
    when (l >= refLevel) $ lift $ pushLogStrLn loggerSet $ toLogStr $ renderLazy $ layoutPretty defaultLayoutOptions $ handleColor t

  -- getLogLevel :: m LogLevel
  getLogLevel = _logLevel <$> (readMVar =<< ask)

  -- setLogLevel :: LogLevel -> m ()
  setLogLevel level = do
    mvar <- ask
    modifyMVar_ mvar $ \settings -> return (settings { _logLevel = level })

  -- setColorizeLogs :: Bool -> m ()
  setColorizeLogs value = do
    mvar <- ask
    modifyMVar_ mvar $ \settings -> return (settings { _colorizeLogs = value })

  -- flushLogs :: m ()
  flushLogs = do
    settings <- readMVar =<< ask
    lift $ flushLogStr $ _loggerSet settings
    lift $ flushLogStr $ _errorLoggerSet settings