RIO/Prelude/Logger.hs

{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE BangPatterns #-}
module RIO.Prelude.Logger
  ( -- ** Running with logging
    withLogFunc
  , newLogFunc
  , LogFunc
  , HasLogFunc (..)
  , logOptionsHandle
    -- *** Log options
  , LogOptions
  , setLogMinLevel
  , setLogMinLevelIO
  , setLogVerboseFormat
  , setLogVerboseFormatIO
  , setLogTerminal
  , setLogUseTime
  , setLogUseColor
  , setLogUseLoc
  , setLogFormat
  , setLogLevelColors
  , setLogSecondaryColor
  , setLogAccentColors
    -- ** Standard logging functions
  , logDebug
  , logInfo
  , logWarn
  , logError
  , logOther
    -- ** Advanced logging functions
    -- *** Sticky logging
  , logSticky
  , logStickyDone
    -- *** With source
    --
    -- $withSource
  , logDebugS
  , logInfoS
  , logWarnS
  , logErrorS
  , logOtherS
    -- *** Generic log function
  , logGeneric
    -- ** Advanced running functions
  , mkLogFunc
  , logOptionsMemory
    -- ** Data types
  , LogLevel (..)
  , LogSource
  , CallStack
    -- ** Convenience functions
  , displayCallStack
  , noLogging
    -- ** Accessors
  , logFuncUseColorL
  , logFuncLogLevelColorsL
  , logFuncSecondaryColorL
  , logFuncAccentColorsL
    -- * Type-generic logger
    -- $type-generic-intro
  , glog
  , GLogFunc
  , gLogFuncClassic
  , mkGLogFunc
  , contramapMaybeGLogFunc
  , contramapGLogFunc
  , HasGLogFunc(..)
  , HasLogLevel(..)
  , HasLogSource(..)
  ) where

import RIO.Prelude.Reexports hiding ((<>))
import RIO.Prelude.Renames
import RIO.Prelude.Display
import RIO.Prelude.Lens
import Data.Text (Text)
import qualified Data.Text as T
import Control.Monad.IO.Class (MonadIO, liftIO)
import GHC.Stack (HasCallStack, CallStack, SrcLoc (..), getCallStack, callStack)
import Data.Time
import qualified Data.Text.IO as TIO
import Data.Bits
import Data.ByteString.Builder (toLazyByteString, char7, byteString, hPutBuilder)
import Data.ByteString.Builder.Extra (flush)
import           GHC.IO.Handle.Internals         (wantWritableHandle)
import           GHC.IO.Encoding.Types           (textEncodingName)
import           GHC.IO.Handle.Types             (Handle__ (..))
import qualified Data.ByteString as B
import           System.IO                  (localeEncoding)
import           GHC.Foreign                (peekCString, withCString)
import Data.Semigroup (Semigroup (..))

#if MIN_VERSION_base(4,12,0)
import Data.Functor.Contravariant
#endif

-- | The log level of a message.
--
-- @since 0.0.0.0
data LogLevel = LevelDebug | LevelInfo | LevelWarn | LevelError | LevelOther !Text
    deriving (Eq, Show, Read, Ord)

-- | Where in the application a log message came from. Used for
-- display purposes only.
--
-- @since 0.0.0.0
type LogSource = Text

-- | Environment values with a logging function.
--
-- @since 0.0.0.0
class HasLogFunc env where
  logFuncL :: Lens' env LogFunc
instance HasLogFunc LogFunc where
  logFuncL = id

-- | A logging function, wrapped in a newtype for better error messages.
--
-- An implementation may choose any behavior of this value it wishes,
-- including printing to standard output or no action at all.
--
-- @since 0.0.0.0
data LogFunc = LogFunc
  { unLogFunc :: !(CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ())
  , lfOptions :: !(Maybe LogOptions)
  }

-- | Perform both sets of actions per log entry.
--
-- @since 0.0.0.0
instance Semigroup LogFunc where
  LogFunc f o1 <> LogFunc g o2 = LogFunc
    { unLogFunc = \a b c d -> f a b c d *> g a b c d
    , lfOptions = o1 `mplus` o2
    }

-- | 'mempty' peforms no logging.
--
-- @since 0.0.0.0
instance Monoid LogFunc where
  mempty = mkLogFunc $ \_ _ _ _ -> return ()
  mappend = (<>)

-- | Create a 'LogFunc' from the given function.
--
-- @since 0.0.0.0
mkLogFunc :: (CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ()) -> LogFunc
mkLogFunc f = LogFunc f Nothing

-- | Generic, basic function for creating other logging functions.
--
-- @since 0.0.0.0
logGeneric
  :: (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack)
  => LogSource
  -> LogLevel
  -> Utf8Builder
  -> m ()
logGeneric src level str = do
  LogFunc logFunc _ <- view logFuncL
  liftIO $ logFunc callStack src level str

-- | Log a debug level message with no source.
--
-- @since 0.0.0.0
logDebug
  :: (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack)
  => Utf8Builder
  -> m ()
logDebug = logGeneric "" LevelDebug

-- | Log an info level message with no source.
--
-- @since 0.0.0.0
logInfo
  :: (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack)
  => Utf8Builder
  -> m ()
logInfo = logGeneric "" LevelInfo

-- | Log a warn level message with no source.
--
-- @since 0.0.0.0
logWarn
  :: (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack)
  => Utf8Builder
  -> m ()
logWarn = logGeneric "" LevelWarn

-- | Log an error level message with no source.
--
-- @since 0.0.0.0
logError
  :: (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack)
  => Utf8Builder
  -> m ()
logError = logGeneric "" LevelError

-- | Log a message with the specified textual level and no source.
--
-- @since 0.0.0.0
logOther
  :: (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack)
  => Text -- ^ level
  -> Utf8Builder
  -> m ()
logOther = logGeneric "" . LevelOther

-- $withSource
--
-- There is a set of logging functions that take an extra 'LogSource'
-- argument to provide context, typically detailing what part of an
-- application the message comes from.
--
-- For example, in verbose mode, @infoLogS "database" "connected"@ will
-- result in
--
-- > [info] (database) connected

-- | Log a debug level message with the given source.
--
-- @since 0.0.0.0
logDebugS
  :: (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack)
  => LogSource
  -> Utf8Builder
  -> m ()
logDebugS src = logGeneric src LevelDebug

-- | Log an info level message with the given source.
--
-- @since 0.0.0.0
logInfoS
  :: (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack)
  => LogSource
  -> Utf8Builder
  -> m ()
logInfoS src = logGeneric src LevelInfo

-- | Log a warn level message with the given source.
--
-- @since 0.0.0.0
logWarnS
  :: (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack)
  => LogSource
  -> Utf8Builder
  -> m ()
logWarnS src = logGeneric src LevelWarn

-- | Log an error level message with the given source.
--
-- @since 0.0.0.0
logErrorS
  :: (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack)
  => LogSource
  -> Utf8Builder
  -> m ()
logErrorS src = logGeneric src LevelError

-- | Log a message with the specified textual level and the given
-- source.
--
-- @since 0.0.0.0
logOtherS
  :: (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack)
  => Text -- ^ level
  -> LogSource
  -> Utf8Builder
  -> m ()
logOtherS src = logGeneric src . LevelOther

-- | Write a "sticky" line to the terminal. Any subsequent lines will
-- overwrite this one, and that same line will be repeated below
-- again. In other words, the line sticks at the bottom of the output
-- forever. Running this function again will replace the sticky line
-- with a new sticky line. When you want to get rid of the sticky
-- line, run 'logStickyDone'.
--
-- Note that not all 'LogFunc' implementations will support sticky
-- messages as described. However, the 'withLogFunc' implementation
-- provided by this module does.
--
-- @since 0.0.0.0
logSticky :: (MonadIO m, HasCallStack, MonadReader env m, HasLogFunc env) => Utf8Builder -> m ()
logSticky = logOther "sticky"

-- | This will print out the given message with a newline and disable
-- any further stickiness of the line until a new call to 'logSticky'
-- happens.
--
-- @since 0.0.0.0
logStickyDone :: (MonadIO m, HasCallStack, MonadReader env m, HasLogFunc env) => Utf8Builder -> m ()
logStickyDone = logOther "sticky-done"

-- TODO It might be better at some point to have a 'runSticky' function
-- that encompasses the logSticky->logStickyDone pairing.

canUseUtf8 :: MonadIO m => Handle -> m Bool
canUseUtf8 h = liftIO $ wantWritableHandle "canUseUtf8" h $ \h_ -> do
  -- TODO also handle haOutputNL for CRLF
  return $ (textEncodingName <$> haCodec h_) == Just "UTF-8"

-- | Create a 'LogOptions' value which will store its data in
-- memory. This is primarily intended for testing purposes. This will
-- return both a 'LogOptions' value and an 'IORef' containing the
-- resulting 'Builder' value.
--
-- This will default to non-verbose settings and assume there is a
-- terminal attached. These assumptions can be overridden using the
-- appropriate @set@ functions.
--
-- @since 0.0.0.0
logOptionsMemory :: MonadIO m => m (IORef Builder, LogOptions)
logOptionsMemory = do
  ref <- newIORef mempty
  let options = LogOptions
        { logMinLevel = return LevelInfo
        , logVerboseFormat = return False
        , logTerminal = True
        , logUseTime = False
        , logUseColor = False
        , logColors = defaultLogColors
        , logUseLoc = False
        , logFormat = id
        , logSend = \new -> atomicModifyIORef' ref $ \old -> (old <> new, ())
        }
  return (ref, options)

-- | Create a 'LogOptions' value from the given 'Handle' and whether
-- to perform verbose logging or not. Individiual settings can be
-- overridden using appropriate @set@ functions.
--
-- When Verbose Flag is @True@, the following happens:
--
--     * @setLogVerboseFormat@ is called with @True@
--     * @setLogUseColor@ is called with @True@ (except on Windows)
--     * @setLogUseLoc@ is called with @True@
--     * @setLogUseTime@ is called with @True@
--     * @setLogMinLevel@ is called with 'Debug' log level
--
-- @since 0.0.0.0
logOptionsHandle
  :: MonadIO m
  => Handle
  -> Bool -- ^ Verbose Flag
  -> m LogOptions
logOptionsHandle handle' verbose = liftIO $ do
  terminal <- hIsTerminalDevice handle'
  useUtf8 <- canUseUtf8 handle'
  unicode <- if useUtf8 then return True else getCanUseUnicode
  return LogOptions
    { logMinLevel = return $ if verbose then LevelDebug else LevelInfo
    , logVerboseFormat = return verbose
    , logTerminal = terminal
    , logUseTime = verbose
#if WINDOWS
    , logUseColor = False
#else
    , logUseColor = verbose && terminal
#endif
    , logColors = defaultLogColors
    , logUseLoc = verbose
    , logFormat = id
    , logSend = \builder ->
        if useUtf8 && unicode
          then hPutBuilder handle' (builder <> flush)
          else do
            let lbs = toLazyByteString builder
                bs = toStrictBytes lbs
            case decodeUtf8' bs of
              Left e -> error $ "mkLogOptions: invalid UTF8 sequence: " ++ show (e, bs)
              Right text -> do
                let text'
                      | unicode = text
                      | otherwise = T.map replaceUnicode text
                TIO.hPutStr handle' text'
                hFlush handle'
    }

-- | Taken from GHC: determine if we should use Unicode syntax
getCanUseUnicode :: IO Bool
getCanUseUnicode = do
    let enc = localeEncoding
        str = "\x2018\x2019"
        test = withCString enc str $ \cstr -> do
            str' <- peekCString enc cstr
            return (str == str')
    test `catchIO` \_ -> return False


-- | Given a 'LogOptions' value, returns both a new 'LogFunc' and a sub-routine that
-- disposes it.
--
-- Intended for use if you want to deal with the teardown of 'LogFunc' yourself,
-- otherwise prefer the 'withLogFunc' function instead.
--
--  @since 0.1.3.0
newLogFunc :: (MonadIO n, MonadIO m) => LogOptions -> n (LogFunc, m ())
newLogFunc options =
  if logTerminal options then do
    var <- newMVar (mempty,0)
    return (LogFunc
             { unLogFunc = stickyImpl var options (simpleLogFunc options)
             , lfOptions = Just options
             }
           , do (state,_) <- takeMVar var
                unless (B.null state) (liftIO $ logSend options "\n")
           )
  else
    return (LogFunc
            { unLogFunc = \cs src level str ->
                simpleLogFunc options cs src (noSticky level) str
            , lfOptions = Just options
            }
           , return ()
           )

-- | Given a 'LogOptions' value, run the given function with the
-- specified 'LogFunc'. A common way to use this function is:
--
-- @
-- let isVerbose = False -- get from the command line instead
-- logOptions' <- logOptionsHandle stderr isVerbose
-- let logOptions = setLogUseTime True logOptions'
-- withLogFunc logOptions $ \\lf -> do
--   let app = App -- application specific environment
--         { appLogFunc = lf
--         , appOtherStuff = ...
--         }
--   runRIO app $ do
--     logInfo "Starting app"
--     myApp
-- @
--
-- @since 0.0.0.0
withLogFunc :: MonadUnliftIO m => LogOptions -> (LogFunc -> m a) -> m a
withLogFunc options inner = withRunInIO $ \run -> do
  bracket (newLogFunc options)
          snd
          (run . inner . fst)


-- | Replace Unicode characters with non-Unicode equivalents
replaceUnicode :: Char -> Char
replaceUnicode '\x2018' = '`'
replaceUnicode '\x2019' = '\''
replaceUnicode c = c

noSticky :: LogLevel -> LogLevel
noSticky (LevelOther "sticky-done") = LevelInfo
noSticky (LevelOther "sticky") = LevelInfo
noSticky level = level

-- | Configuration for how to create a 'LogFunc'. Intended to be used
-- with the 'withLogFunc' function.
--
-- @since 0.0.0.0
data LogOptions = LogOptions
  { logMinLevel :: !(IO LogLevel)
  , logVerboseFormat :: !(IO Bool)
  , logTerminal :: !Bool
  , logUseTime :: !Bool
  , logUseColor :: !Bool
  , logColors :: !LogColors
  , logUseLoc :: !Bool
  , logFormat :: !(Utf8Builder -> Utf8Builder)
  , logSend :: !(Builder -> IO ())
  }

-- | ANSI color codes for use in the configuration of the creation of a
-- 'LogFunc'.
--
-- @since 0.1.18.0
data LogColors = LogColors
  { -- | The color associated with each 'LogLevel'.
    logColorLogLevels :: !(LogLevel -> Utf8Builder)
    -- | The color of secondary content.
  , logColorSecondary :: !Utf8Builder
    -- | The color of accents, which are indexed by 'Int'.
  , logColorAccents :: !(Int -> Utf8Builder)
  }

defaultLogColors :: LogColors
defaultLogColors = LogColors
  { logColorLogLevels = defaultLogLevelColors
  , logColorSecondary = defaultLogSecondaryColor
  , logColorAccents = defaultLogAccentColors
  }

defaultLogLevelColors :: LogLevel -> Utf8Builder
defaultLogLevelColors LevelDebug = "\ESC[32m" -- Green
defaultLogLevelColors LevelInfo = "\ESC[34m" -- Blue
defaultLogLevelColors LevelWarn = "\ESC[33m" -- Yellow
defaultLogLevelColors LevelError = "\ESC[31m" -- Red
defaultLogLevelColors (LevelOther _) = "\ESC[35m" -- Magenta

defaultLogSecondaryColor :: Utf8Builder
defaultLogSecondaryColor = "\ESC[90m"  -- Bright black (gray)

defaultLogAccentColors :: Int -> Utf8Builder
defaultLogAccentColors = const "\ESC[92m" -- Bright green

-- | Set the minimum log level. Messages below this level will not be
-- printed.
--
-- Default: in verbose mode, 'LevelDebug'. Otherwise, 'LevelInfo'.
--
-- @since 0.0.0.0
setLogMinLevel :: LogLevel -> LogOptions -> LogOptions
setLogMinLevel level options = options { logMinLevel = return level }

-- | Refer to 'setLogMinLevel'. This modifier allows to alter the verbose format
-- value dynamically at runtime.
--
-- Default: in verbose mode, 'LevelDebug'. Otherwise, 'LevelInfo'.
--
-- @since 0.1.3.0
setLogMinLevelIO :: IO LogLevel -> LogOptions -> LogOptions
setLogMinLevelIO getLevel options = options { logMinLevel = getLevel }

-- | Use the verbose format for printing log messages.
--
-- Default: follows the value of the verbose flag.
--
-- @since 0.0.0.0
setLogVerboseFormat :: Bool -> LogOptions -> LogOptions
setLogVerboseFormat v options = options { logVerboseFormat = return v }

-- | Refer to 'setLogVerboseFormat'. This modifier allows to alter the verbose
--   format value dynamically at runtime.
--
-- Default: follows the value of the verbose flag.
--
-- @since 0.1.3.0
setLogVerboseFormatIO :: IO Bool -> LogOptions -> LogOptions
setLogVerboseFormatIO getVerboseLevel options =
  options { logVerboseFormat = getVerboseLevel }

-- | Do we treat output as a terminal. If @True@, we will enabled
-- sticky logging functionality.
--
-- Default: checks if the @Handle@ provided to 'logOptionsHandle' is a
-- terminal with 'hIsTerminalDevice'.
--
-- @since 0.0.0.0
setLogTerminal :: Bool -> LogOptions -> LogOptions
setLogTerminal t options = options { logTerminal = t }

-- | Include the time when printing log messages.
--
-- Default: `True` in debug mode, `False` otherwise.
--
-- @since 0.0.0.0
setLogUseTime :: Bool -> LogOptions -> LogOptions
setLogUseTime t options = options { logUseTime = t }

-- | Use ANSI color codes in the log output.
--
-- Default: `True` if in verbose mode /and/ the 'Handle' is a terminal device.
--
-- @since 0.0.0.0
setLogUseColor :: Bool -> LogOptions -> LogOptions
setLogUseColor c options = options { logUseColor = c }

-- | ANSI color codes for 'LogLevel' in the log output.
--
-- Default: 'LevelDebug'   = \"\\ESC[32m\" -- Green
--          'LevelInfo'    = \"\\ESC[34m\" -- Blue
--          'LevelWarn'    = \"\\ESC[33m\" -- Yellow
--          'LevelError'   = \"\\ESC[31m\" -- Red
--          'LevelOther' _ = \"\\ESC[35m\" -- Magenta
--
-- @since 0.1.18.0
setLogLevelColors :: (LogLevel -> Utf8Builder) -> LogOptions -> LogOptions
setLogLevelColors logLevelColors options =
  let lc = (logColors options){ logColorLogLevels = logLevelColors }
  in  options { logColors = lc }

-- | ANSI color codes for secondary content in the log output.
--
-- Default: \"\\ESC[90m\" -- Bright black (gray)
--
-- @since 0.1.18.0
setLogSecondaryColor :: Utf8Builder -> LogOptions -> LogOptions
setLogSecondaryColor c options =
  let lc = (logColors options){ logColorSecondary = c }
  in  options { logColors = lc }

-- | ANSI color codes for accents in the log output. Accent colors are indexed
-- by 'Int'.
--
-- Default: 'const' \"\\ESC[92m\" -- Bright green, for all indicies
--
-- @since 0.1.18.0
setLogAccentColors
  :: (Int -> Utf8Builder)  -- ^ This should be a total function.
  -> LogOptions
  -> LogOptions
setLogAccentColors accentColors options =
  let lc = (logColors options){ logColorAccents = accentColors }
  in  options { logColors = lc }

-- | Use code location in the log output.
--
-- Default: `True` if in verbose mode, `False` otherwise.
--
-- @since 0.1.2.0
setLogUseLoc :: Bool -> LogOptions -> LogOptions
setLogUseLoc l options = options { logUseLoc = l }

-- | Set format method for messages
--
-- Default: `id`
--
-- @since 0.1.13.0
setLogFormat :: (Utf8Builder -> Utf8Builder) -> LogOptions -> LogOptions
setLogFormat f options = options { logFormat = f }

simpleLogFunc :: LogOptions -> CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ()
simpleLogFunc lo cs src level msg = do
    logLevel   <- logMinLevel lo
    logVerbose <- logVerboseFormat lo

    when (level >= logLevel) $ do
      timestamp <- getTimestamp logVerbose
      logSend lo $ getUtf8Builder $
        timestamp <>
        getLevel logVerbose <>
        ansi reset <>
        getSource <>
        logFormat lo msg <>
        getLoc <>
        ansi reset <>
        "\n"
  where
   reset = "\ESC[0m"
   lc = logColors lo
   levelColor = logColorLogLevels lc level
   timestampColor = logColorSecondary lc
   locColor = logColorSecondary lc

   ansi :: Utf8Builder -> Utf8Builder
   ansi xs | logUseColor lo = xs
           | otherwise = mempty

   getTimestamp :: Bool -> IO Utf8Builder
   getTimestamp logVerbose
     | logVerbose && logUseTime lo =
       do now <- getZonedTime
          return $ ansi timestampColor <> fromString (formatTime' now) <> ": "
     | otherwise = return mempty
     where
       formatTime' =
           take timestampLength . formatTime defaultTimeLocale "%F %T.%q"

   getLevel :: Bool -> Utf8Builder
   getLevel logVerbose
     | logVerbose = ansi levelColor <>
         case level of
           LevelDebug -> "[debug] "
           LevelInfo -> "[info] "
           LevelWarn -> "[warn] "
           LevelError -> "[error] "
           LevelOther name ->
             "[" <>
             display name <>
             "] "
     | otherwise = mempty

   getSource :: Utf8Builder
   getSource = case src of
     "" -> ""
     _  -> "(" <> display src <> ") "

   getLoc :: Utf8Builder
   getLoc
     | logUseLoc lo = ansi locColor <> "\n@(" <> displayCallStack cs <> ")"
     | otherwise = mempty

-- | Convert a 'CallStack' value into a 'Utf8Builder' indicating
-- the first source location.
--
-- TODO Consider showing the entire call stack instead.
--
-- @since 0.0.0.0
displayCallStack :: CallStack -> Utf8Builder
displayCallStack cs =
     case reverse $ getCallStack cs of
       [] -> "<no call stack found>"
       (_desc, loc):_ ->
         let file = srcLocFile loc
          in fromString file <>
             ":" <>
             displayShow (srcLocStartLine loc) <>
             ":" <>
             displayShow (srcLocStartCol loc)

-- | The length of a timestamp in the format "YYYY-MM-DD hh:mm:ss.μμμμμμ".
-- This definition is top-level in order to avoid multiple reevaluation at runtime.
timestampLength :: Int
timestampLength =
  length (formatTime defaultTimeLocale "%F %T.000000" (UTCTime (ModifiedJulianDay 0) 0))

stickyImpl
    :: MVar (ByteString,Int) -> LogOptions
    -> (CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ())
    -> CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ()
stickyImpl ref lo logFunc loc src level msgOrig = modifyMVar_ ref $ \(sticky,stickyLen) -> do
  let backSpaceChar = '\8'
      repeating = mconcat . replicate stickyLen . char7
      clear = logSend lo
        (repeating backSpaceChar <>
        repeating ' ' <>
        repeating backSpaceChar)

  logLevel <- logMinLevel lo

  case level of
    LevelOther "sticky-done" -> do
      clear
      logFunc loc src LevelInfo msgOrig
      return (mempty,0)
    LevelOther "sticky" -> do
      clear
      let bs = toStrictBytes $ toLazyByteString $ getUtf8Builder msgOrig
      logSend lo (byteString bs <> flush)
      return (bs, utf8CharacterCount bs)
    _
      | level >= logLevel -> do
          clear
          logFunc loc src level msgOrig
          unless (B.null sticky) $ logSend lo (byteString sticky <> flush)
          return (sticky,stickyLen)
      | otherwise -> return (sticky,stickyLen)

-- | The number of Unicode characters in a UTF-8 encoded byte string,
-- excluding ANSI CSI sequences.
utf8CharacterCount :: ByteString -> Int
utf8CharacterCount = go 0
  where
    go !n bs = case B.uncons bs of
        Nothing -> n
        Just (c,bs)
            | c .&. 0xC0 == 0x80 -> go n bs            -- UTF-8 continuation
            | c == 0x1B          -> go n $ dropCSI bs  -- ANSI escape
            | otherwise          -> go (n+1) bs

    dropCSI bs = case B.uncons bs of
        Just (0x5B,bs2) -> B.drop 1 $ B.dropWhile isSequenceByte bs2
        _               -> bs

    isSequenceByte c = c >= 0x20 && c <= 0x3F

-- | Is the log func configured to use color output?
--
-- Intended for use by code which wants to optionally add additional color to
-- its log messages.
--
-- @since 0.1.0.0
logFuncUseColorL :: HasLogFunc env => SimpleGetter env Bool
logFuncUseColorL = logFuncL.to (maybe False logUseColor . lfOptions)

-- | What color is the log func configured to use for each 'LogLevel'?
--
-- Intended for use by code which wants to optionally add additional color to
-- its log messages.
--
-- @since 0.1.18.0
logFuncLogLevelColorsL :: HasLogFunc env
                       => SimpleGetter env (LogLevel -> Utf8Builder)
logFuncLogLevelColorsL = logFuncL.to
                           (maybe defaultLogLevelColors
                                  (logColorLogLevels . logColors) . lfOptions)

-- | What color is the log func configured to use for secondary content?
--
-- Intended for use by code which wants to optionally add additional color to
-- its log messages.
--
-- @since 0.1.18.0
logFuncSecondaryColorL :: HasLogFunc env
                       => SimpleGetter env Utf8Builder
logFuncSecondaryColorL = logFuncL.to
                           (maybe defaultLogSecondaryColor
                                  (logColorSecondary . logColors) . lfOptions)

-- | What accent colors, indexed by 'Int', is the log func configured to use?
--
-- Intended for use by code which wants to optionally add additional color to
-- its log messages.
--
-- @since 0.1.18.0
logFuncAccentColorsL :: HasLogFunc env
                       => SimpleGetter env (Int -> Utf8Builder)
logFuncAccentColorsL = logFuncL.to
                           (maybe defaultLogAccentColors
                                  (logColorAccents . logColors) . lfOptions)

-- | Disable logging capabilities in a given sub-routine
--
-- Intended to skip logging in general purpose implementations, where secrets
-- might be logged accidently.
--
-- @since 0.1.5.0
noLogging :: (HasLogFunc env, MonadReader env m) => m a -> m a
noLogging = local (set logFuncL mempty)

--------------------------------------------------------------------------------
--
-- $type-generic-intro
--
-- When logging takes on a more semantic meaning and the logs need to
-- be digested, acted upon, translated or serialized upstream (to
-- e.g. a JSON logging server), we have 'GLogFunc' (as in "generic log
-- function"), and is accessed via 'HasGLogFunc'.
--
-- There is only one function to log in this system: the 'glog'
-- function, which can log any message. You determine the log levels
-- or severity of messages when needed.
--
-- Using 'RIO.Prelude.mapRIO' and 'contramapGLogFunc' (or
-- 'contramapMaybeGLogFunc'), you can build hierarchies of loggers.
--
-- Example:
--
-- @
-- import RIO
--
-- data DatabaseMsg = Connected String | Query String | Disconnected deriving Show
-- data WebMsg = Request String | Error String | DatabaseMsg DatabaseMsg deriving Show
-- data AppMsg = InitMsg String | WebMsg WebMsg deriving Show
--
-- main :: IO ()
-- main =
--   runRIO
--     (mkGLogFunc (\stack msg -> print msg))
--     (do glog (InitMsg "Ready to go!")
--         runWeb
--           (do glog (Request "/foo")
--               runDB (do glog (Connected "127.0.0.1")
--                         glog (Query "SELECT 1"))
--               glog (Error "Oh noes!")))
--
-- runDB :: RIO (GLogFunc DatabaseMsg) () -> RIO (GLogFunc WebMsg) ()
-- runDB = mapRIO (contramapGLogFunc DatabaseMsg)
--
-- runWeb :: RIO (GLogFunc WebMsg) () -> RIO (GLogFunc AppMsg) ()
-- runWeb = mapRIO (contramapGLogFunc WebMsg)
-- @
--
-- If we instead decided that we only wanted to log database queries,
-- and not bother the upstream with connect/disconnect messages, we
-- could simplify the constructor to @DatabaseQuery String@:
--
-- @
-- data WebMsg = Request String | Error String | DatabaseQuery String deriving Show
-- @
--
-- And then @runDB@ could use 'contramapMaybeGLogFunc' to parse only queries:
--
-- @
-- runDB =
--   mapRIO
--     (contramapMaybeGLogFunc
--        (\msg ->
--           case msg of
--             Query string -> pure (DatabaseQuery string)
--             _ -> Nothing))
-- @
--
-- This way, upstream only has to care about queries and not
-- connect/disconnect constructors.

-- | An app is capable of generic logging if it implements this.
--
-- @since 0.1.13.0
class HasGLogFunc env where
  type GMsg env
  gLogFuncL :: Lens' env (GLogFunc (GMsg env))

-- | Quick way to run a RIO that only has a logger in its environment.
--
-- @since 0.1.13.0
instance HasGLogFunc (GLogFunc msg) where
  type GMsg (GLogFunc msg) = msg
  gLogFuncL = id

-- | A generic logger of some type @msg@.
--
-- Your 'GLocFunc' can re-use the existing classical logging framework
-- of RIO, and/or implement additional transforms,
-- filters. Alternatively, you may log to a JSON source in a database,
-- or anywhere else as needed. You can decide how to log levels or
-- severities based on the constructors in your type. You will
-- normally determine this in your main app entry point.
--
-- @since 0.1.13.0
newtype GLogFunc msg = GLogFunc (CallStack -> msg -> IO ())

#if MIN_VERSION_base(4,12,0)
-- https://hackage.haskell.org/package/base-4.12.0.0/docs/Data-Functor-Contravariant.html

-- | Use this instance to wrap sub-loggers via 'RIO.mapRIO'.
--
-- The 'Contravariant' class is available in base 4.12.0.
--
-- @since 0.1.13.0
instance Contravariant GLogFunc where
  contramap = contramapGLogFunc
  {-# INLINABLE contramap #-}
#endif

-- | Perform both sets of actions per log entry.
--
-- @since 0.1.13.0
instance Semigroup (GLogFunc msg) where
  GLogFunc f <> GLogFunc g = GLogFunc (\a b -> f a b *> g a b)

-- | 'mempty' peforms no logging.
--
-- @since 0.1.13.0
instance Monoid (GLogFunc msg) where
  mempty = mkGLogFunc $ \_ _ -> return ()
  mappend = (<>)

-- | A vesion of 'contramapMaybeGLogFunc' which supports filering.
--
-- @since 0.1.13.0
contramapMaybeGLogFunc :: (a -> Maybe b) -> GLogFunc b -> GLogFunc a
contramapMaybeGLogFunc f (GLogFunc io) =
  GLogFunc (\stack msg -> maybe (pure ()) (io stack) (f msg))
{-# INLINABLE contramapMaybeGLogFunc #-}

-- | A contramap. Use this to wrap sub-loggers via 'RIO.mapRIO'.
--
-- If you are on base > 4.12.0, you can just use 'contramap'.
--
-- @since 0.1.13.0
contramapGLogFunc :: (a -> b) -> GLogFunc b -> GLogFunc a
contramapGLogFunc f (GLogFunc io) = GLogFunc (\stack msg -> io stack (f msg))
{-# INLINABLE contramapGLogFunc #-}

-- | Make a custom generic logger. With this you could, for example,
-- write to a database or a log digestion service. For example:
--
-- > mkGLogFunc (\stack msg -> send (Data.Aeson.encode (JsonLog stack msg)))
--
-- @since 0.1.13.0
mkGLogFunc :: (CallStack -> msg -> IO ()) -> GLogFunc msg
mkGLogFunc = GLogFunc

-- | Log a value generically.
--
-- @since 0.1.13.0
glog ::
     (MonadIO m, HasCallStack, HasGLogFunc env, MonadReader env m)
  => GMsg env
  -> m ()
glog t = do
  GLogFunc gLogFunc <- view gLogFuncL
  liftIO (gLogFunc callStack t)
{-# INLINABLE glog #-}

--------------------------------------------------------------------------------
-- Integration with classical logger framework

-- | Level, if any, of your logs. If unknown, use 'LogOther'. Use for
-- your generic log data types that want to sit inside the classic log
-- framework.
--
-- @since 0.1.13.0
class HasLogLevel msg where
  getLogLevel :: msg -> LogLevel

-- | Source of a log. This can be whatever you want. Use for your
-- generic log data types that want to sit inside the classic log
-- framework.
--
-- @since 0.1.13.0
class HasLogSource msg where
  getLogSource :: msg -> LogSource

-- | Make a 'GLogFunc' via classic 'LogFunc'. Use this if you'd like
-- to log your generic data type via the classic RIO terminal logger.
--
-- @since 0.1.13.0
gLogFuncClassic ::
     (HasLogLevel msg, HasLogSource msg, Display msg) => LogFunc -> GLogFunc msg
gLogFuncClassic (LogFunc {unLogFunc = io}) =
  mkGLogFunc
    (\theCallStack msg ->
       liftIO
         (io theCallStack (getLogSource msg) (getLogLevel msg) (display msg)))