{-# 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 (LogLevel -> LogLevel -> Bool
(LogLevel -> LogLevel -> Bool)
-> (LogLevel -> LogLevel -> Bool) -> Eq LogLevel
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LogLevel -> LogLevel -> Bool
$c/= :: LogLevel -> LogLevel -> Bool
== :: LogLevel -> LogLevel -> Bool
$c== :: LogLevel -> LogLevel -> Bool
Eq, Int -> LogLevel -> ShowS
[LogLevel] -> ShowS
LogLevel -> String
(Int -> LogLevel -> ShowS)
-> (LogLevel -> String) -> ([LogLevel] -> ShowS) -> Show LogLevel
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LogLevel] -> ShowS
$cshowList :: [LogLevel] -> ShowS
show :: LogLevel -> String
$cshow :: LogLevel -> String
showsPrec :: Int -> LogLevel -> ShowS
$cshowsPrec :: Int -> LogLevel -> ShowS
Show, 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
readListPrec :: ReadPrec [LogLevel]
$creadListPrec :: ReadPrec [LogLevel]
readPrec :: ReadPrec LogLevel
$creadPrec :: ReadPrec LogLevel
readList :: ReadS [LogLevel]
$creadList :: ReadS [LogLevel]
readsPrec :: Int -> ReadS LogLevel
$creadsPrec :: Int -> ReadS LogLevel
Read, 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
min :: LogLevel -> LogLevel -> LogLevel
$cmin :: LogLevel -> LogLevel -> LogLevel
max :: LogLevel -> LogLevel -> LogLevel
$cmax :: LogLevel -> LogLevel -> LogLevel
>= :: LogLevel -> LogLevel -> Bool
$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
compare :: LogLevel -> LogLevel -> Ordering
$ccompare :: LogLevel -> LogLevel -> Ordering
$cp1Ord :: Eq LogLevel
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 :: (LogFunc -> f LogFunc) -> LogFunc -> f LogFunc
logFuncL = (LogFunc -> f LogFunc) -> LogFunc -> f LogFunc
forall a. a -> a
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
  { LogFunc
-> CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ()
unLogFunc :: !(CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ())
  , LogFunc -> Maybe LogOptions
lfOptions :: !(Maybe LogOptions)
  }

-- | Perform both sets of actions per log entry.
--
-- @since 0.0.0.0
instance Semigroup LogFunc where
  LogFunc CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ()
f Maybe LogOptions
o1 <> :: LogFunc -> LogFunc -> LogFunc
<> LogFunc CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ()
g Maybe LogOptions
o2 = LogFunc :: (CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ())
-> Maybe LogOptions -> LogFunc
LogFunc
    { unLogFunc :: CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ()
unLogFunc = \CallStack
a LogSource
b LogLevel
c Utf8Builder
d -> CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ()
f CallStack
a LogSource
b LogLevel
c Utf8Builder
d IO () -> IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ()
g CallStack
a LogSource
b LogLevel
c Utf8Builder
d
    , lfOptions :: Maybe LogOptions
lfOptions = Maybe LogOptions
o1 Maybe LogOptions -> Maybe LogOptions -> Maybe LogOptions
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Maybe LogOptions
o2
    }

-- | 'mempty' peforms no logging.
--
-- @since 0.0.0.0
instance Monoid LogFunc where
  mempty :: LogFunc
mempty = (CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ())
-> LogFunc
mkLogFunc ((CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ())
 -> LogFunc)
-> (CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ())
-> LogFunc
forall a b. (a -> b) -> a -> b
$ \CallStack
_ LogSource
_ LogLevel
_ Utf8Builder
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  mappend :: LogFunc -> LogFunc -> LogFunc
mappend = LogFunc -> LogFunc -> LogFunc
forall a. Semigroup a => a -> a -> a
(<>)

-- | Create a 'LogFunc' from the given function.
--
-- @since 0.0.0.0
mkLogFunc :: (CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ()) -> LogFunc
mkLogFunc :: (CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ())
-> LogFunc
mkLogFunc CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ()
f = (CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ())
-> Maybe LogOptions -> LogFunc
LogFunc CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ()
f Maybe LogOptions
forall a. Maybe a
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 :: LogSource -> LogLevel -> Utf8Builder -> m ()
logGeneric LogSource
src LogLevel
level Utf8Builder
str = do
  LogFunc CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ()
logFunc Maybe LogOptions
_ <- Getting LogFunc env LogFunc -> m LogFunc
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting LogFunc env LogFunc
forall env. HasLogFunc env => Lens' env LogFunc
logFuncL
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ()
logFunc CallStack
HasCallStack => CallStack
callStack LogSource
src LogLevel
level Utf8Builder
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 :: Utf8Builder -> m ()
logDebug = LogSource -> LogLevel -> Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
LogSource -> LogLevel -> Utf8Builder -> m ()
logGeneric LogSource
"" LogLevel
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 :: Utf8Builder -> m ()
logInfo = LogSource -> LogLevel -> Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
LogSource -> LogLevel -> Utf8Builder -> m ()
logGeneric LogSource
"" LogLevel
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 :: Utf8Builder -> m ()
logWarn = LogSource -> LogLevel -> Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
LogSource -> LogLevel -> Utf8Builder -> m ()
logGeneric LogSource
"" LogLevel
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 :: Utf8Builder -> m ()
logError = LogSource -> LogLevel -> Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
LogSource -> LogLevel -> Utf8Builder -> m ()
logGeneric LogSource
"" LogLevel
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 :: LogSource -> Utf8Builder -> m ()
logOther = LogSource -> LogLevel -> Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
LogSource -> LogLevel -> Utf8Builder -> m ()
logGeneric LogSource
"" (LogLevel -> Utf8Builder -> m ())
-> (LogSource -> LogLevel) -> LogSource -> Utf8Builder -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogSource -> LogLevel
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 :: LogSource -> Utf8Builder -> m ()
logDebugS LogSource
src = LogSource -> LogLevel -> Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
LogSource -> LogLevel -> Utf8Builder -> m ()
logGeneric LogSource
src LogLevel
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 :: LogSource -> Utf8Builder -> m ()
logInfoS LogSource
src = LogSource -> LogLevel -> Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
LogSource -> LogLevel -> Utf8Builder -> m ()
logGeneric LogSource
src LogLevel
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 :: LogSource -> Utf8Builder -> m ()
logWarnS LogSource
src = LogSource -> LogLevel -> Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
LogSource -> LogLevel -> Utf8Builder -> m ()
logGeneric LogSource
src LogLevel
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 :: LogSource -> Utf8Builder -> m ()
logErrorS LogSource
src = LogSource -> LogLevel -> Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
LogSource -> LogLevel -> Utf8Builder -> m ()
logGeneric LogSource
src LogLevel
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 :: LogSource -> LogSource -> Utf8Builder -> m ()
logOtherS LogSource
src = LogSource -> LogLevel -> Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
LogSource -> LogLevel -> Utf8Builder -> m ()
logGeneric LogSource
src (LogLevel -> Utf8Builder -> m ())
-> (LogSource -> LogLevel) -> LogSource -> Utf8Builder -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogSource -> LogLevel
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 :: Utf8Builder -> m ()
logSticky = LogSource -> Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
LogSource -> Utf8Builder -> m ()
logOther LogSource
"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 :: Utf8Builder -> m ()
logStickyDone = LogSource -> Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
LogSource -> Utf8Builder -> m ()
logOther LogSource
"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 :: Handle -> m Bool
canUseUtf8 Handle
h = IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ String -> Handle -> (Handle__ -> IO Bool) -> IO Bool
forall a. String -> Handle -> (Handle__ -> IO a) -> IO a
wantWritableHandle String
"canUseUtf8" Handle
h ((Handle__ -> IO Bool) -> IO Bool)
-> (Handle__ -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \Handle__
h_ -> do
  -- TODO also handle haOutputNL for CRLF
  Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ (TextEncoding -> String
textEncodingName (TextEncoding -> String) -> Maybe TextEncoding -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle__ -> Maybe TextEncoding
haCodec Handle__
h_) Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Maybe String
forall a. a -> Maybe a
Just String
"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 :: m (IORef Builder, LogOptions)
logOptionsMemory = do
  IORef Builder
ref <- Builder -> m (IORef Builder)
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef Builder
forall a. Monoid a => a
mempty
  let options :: LogOptions
options = LogOptions :: IO LogLevel
-> IO Bool
-> Bool
-> Bool
-> Bool
-> LogColors
-> Bool
-> (Utf8Builder -> Utf8Builder)
-> (Builder -> IO ())
-> LogOptions
LogOptions
        { logMinLevel :: IO LogLevel
logMinLevel = LogLevel -> IO LogLevel
forall (m :: * -> *) a. Monad m => a -> m a
return LogLevel
LevelInfo
        , logVerboseFormat :: IO Bool
logVerboseFormat = Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        , logTerminal :: Bool
logTerminal = Bool
True
        , logUseTime :: Bool
logUseTime = Bool
False
        , logUseColor :: Bool
logUseColor = Bool
False
        , logColors :: LogColors
logColors = LogColors
defaultLogColors
        , logUseLoc :: Bool
logUseLoc = Bool
False
        , logFormat :: Utf8Builder -> Utf8Builder
logFormat = Utf8Builder -> Utf8Builder
forall a. a -> a
id
        , logSend :: Builder -> IO ()
logSend = \Builder
new -> IORef Builder -> (Builder -> (Builder, ())) -> IO ()
forall (m :: * -> *) a b.
MonadIO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef' IORef Builder
ref ((Builder -> (Builder, ())) -> IO ())
-> (Builder -> (Builder, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Builder
old -> (Builder
old Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
new, ())
        }
  (IORef Builder, LogOptions) -> m (IORef Builder, LogOptions)
forall (m :: * -> *) a. Monad m => a -> m a
return (IORef Builder
ref, LogOptions
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 -> Bool -> m LogOptions
logOptionsHandle Handle
handle' Bool
verbose = IO LogOptions -> m LogOptions
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO LogOptions -> m LogOptions) -> IO LogOptions -> m LogOptions
forall a b. (a -> b) -> a -> b
$ do
  Bool
terminal <- Handle -> IO Bool
forall (m :: * -> *). MonadIO m => Handle -> m Bool
hIsTerminalDevice Handle
handle'
  Bool
useUtf8 <- Handle -> IO Bool
forall (m :: * -> *). MonadIO m => Handle -> m Bool
canUseUtf8 Handle
handle'
  Bool
unicode <- if Bool
useUtf8 then Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True else IO Bool
getCanUseUnicode
  LogOptions -> IO LogOptions
forall (m :: * -> *) a. Monad m => a -> m a
return LogOptions :: IO LogLevel
-> IO Bool
-> Bool
-> Bool
-> Bool
-> LogColors
-> Bool
-> (Utf8Builder -> Utf8Builder)
-> (Builder -> IO ())
-> LogOptions
LogOptions
    { logMinLevel :: IO LogLevel
logMinLevel = LogLevel -> IO LogLevel
forall (m :: * -> *) a. Monad m => a -> m a
return (LogLevel -> IO LogLevel) -> LogLevel -> IO LogLevel
forall a b. (a -> b) -> a -> b
$ if Bool
verbose then LogLevel
LevelDebug else LogLevel
LevelInfo
    , logVerboseFormat :: IO Bool
logVerboseFormat = Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
verbose
    , logTerminal :: Bool
logTerminal = Bool
terminal
    , logUseTime :: Bool
logUseTime = Bool
verbose
#if WINDOWS
    , logUseColor = False
#else
    , logUseColor :: Bool
logUseColor = Bool
verbose Bool -> Bool -> Bool
&& Bool
terminal
#endif
    , logColors :: LogColors
logColors = LogColors
defaultLogColors
    , logUseLoc :: Bool
logUseLoc = Bool
verbose
    , logFormat :: Utf8Builder -> Utf8Builder
logFormat = Utf8Builder -> Utf8Builder
forall a. a -> a
id
    , logSend :: Builder -> IO ()
logSend = \Builder
builder ->
        if Bool
useUtf8 Bool -> Bool -> Bool
&& Bool
unicode
          then Handle -> Builder -> IO ()
hPutBuilder Handle
handle' (Builder
builder Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
flush)
          else do
            let lbs :: ByteString
lbs = Builder -> ByteString
toLazyByteString Builder
builder
                bs :: ByteString
bs = ByteString -> ByteString
toStrictBytes ByteString
lbs
            case ByteString -> Either UnicodeException LogSource
decodeUtf8' ByteString
bs of
              Left UnicodeException
e -> String -> IO ()
forall a. HasCallStack => String -> a
error (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"mkLogOptions: invalid UTF8 sequence: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (UnicodeException, ByteString) -> String
forall a. Show a => a -> String
show (UnicodeException
e, ByteString
bs)
              Right LogSource
text -> do
                let text' :: LogSource
text'
                      | Bool
unicode = LogSource
text
                      | Bool
otherwise = (Char -> Char) -> LogSource -> LogSource
T.map Char -> Char
replaceUnicode LogSource
text
                Handle -> LogSource -> IO ()
TIO.hPutStr Handle
handle' LogSource
text'
                Handle -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> m ()
hFlush Handle
handle'
    }

-- | Taken from GHC: determine if we should use Unicode syntax
getCanUseUnicode :: IO Bool
getCanUseUnicode :: IO Bool
getCanUseUnicode = do
    let enc :: TextEncoding
enc = TextEncoding
localeEncoding
        str :: String
str = String
"\x2018\x2019"
        test :: IO Bool
test = TextEncoding -> String -> (CString -> IO Bool) -> IO Bool
forall a. TextEncoding -> String -> (CString -> IO a) -> IO a
withCString TextEncoding
enc String
str ((CString -> IO Bool) -> IO Bool)
-> (CString -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \CString
cstr -> do
            String
str' <- TextEncoding -> CString -> IO String
peekCString TextEncoding
enc CString
cstr
            Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (String
str String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
str')
    IO Bool
test IO Bool -> (IOException -> IO Bool) -> IO Bool
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (IOException -> m a) -> m a
`catchIO` \IOException
_ -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
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 :: LogOptions -> n (LogFunc, m ())
newLogFunc LogOptions
options =
  if LogOptions -> Bool
logTerminal LogOptions
options then do
    MVar (ByteString, Int)
var <- (ByteString, Int) -> n (MVar (ByteString, Int))
forall (m :: * -> *) a. MonadIO m => a -> m (MVar a)
newMVar (ByteString
forall a. Monoid a => a
mempty,Int
0)
    (LogFunc, m ()) -> n (LogFunc, m ())
forall (m :: * -> *) a. Monad m => a -> m a
return (LogFunc :: (CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ())
-> Maybe LogOptions -> LogFunc
LogFunc
             { unLogFunc :: CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ()
unLogFunc = MVar (ByteString, Int)
-> LogOptions
-> (CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ())
-> CallStack
-> LogSource
-> LogLevel
-> Utf8Builder
-> IO ()
stickyImpl MVar (ByteString, Int)
var LogOptions
options (LogOptions
-> CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ()
simpleLogFunc LogOptions
options)
             , lfOptions :: Maybe LogOptions
lfOptions = LogOptions -> Maybe LogOptions
forall a. a -> Maybe a
Just LogOptions
options
             }
           , do (ByteString
state,Int
_) <- MVar (ByteString, Int) -> m (ByteString, Int)
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
takeMVar MVar (ByteString, Int)
var
                Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
B.null ByteString
state) (IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ LogOptions -> Builder -> IO ()
logSend LogOptions
options Builder
"\n")
           )
  else
    (LogFunc, m ()) -> n (LogFunc, m ())
forall (m :: * -> *) a. Monad m => a -> m a
return (LogFunc :: (CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ())
-> Maybe LogOptions -> LogFunc
LogFunc
            { unLogFunc :: CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ()
unLogFunc = \CallStack
cs LogSource
src LogLevel
level Utf8Builder
str ->
                LogOptions
-> CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ()
simpleLogFunc LogOptions
options CallStack
cs LogSource
src (LogLevel -> LogLevel
noSticky LogLevel
level) Utf8Builder
str
            , lfOptions :: Maybe LogOptions
lfOptions = LogOptions -> Maybe LogOptions
forall a. a -> Maybe a
Just LogOptions
options
            }
           , () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
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 :: LogOptions -> (LogFunc -> m a) -> m a
withLogFunc LogOptions
options LogFunc -> m a
inner = ((forall a. m a -> IO a) -> IO a) -> m a
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO a) -> m a)
-> ((forall a. m a -> IO a) -> IO a) -> m a
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
run -> do
  IO (LogFunc, IO ())
-> ((LogFunc, IO ()) -> IO ())
-> ((LogFunc, IO ()) -> IO a)
-> IO a
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket (LogOptions -> IO (LogFunc, IO ())
forall (n :: * -> *) (m :: * -> *).
(MonadIO n, MonadIO m) =>
LogOptions -> n (LogFunc, m ())
newLogFunc LogOptions
options)
          (LogFunc, IO ()) -> IO ()
forall a b. (a, b) -> b
snd
          (m a -> IO a
forall a. m a -> IO a
run (m a -> IO a)
-> ((LogFunc, IO ()) -> m a) -> (LogFunc, IO ()) -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogFunc -> m a
inner (LogFunc -> m a)
-> ((LogFunc, IO ()) -> LogFunc) -> (LogFunc, IO ()) -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LogFunc, IO ()) -> LogFunc
forall a b. (a, b) -> a
fst)


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

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

-- | Configuration for how to create a 'LogFunc'. Intended to be used
-- with the 'withLogFunc' function.
--
-- @since 0.0.0.0
data LogOptions = LogOptions
  { LogOptions -> IO LogLevel
logMinLevel :: !(IO LogLevel)
  , LogOptions -> IO Bool
logVerboseFormat :: !(IO Bool)
  , LogOptions -> Bool
logTerminal :: !Bool
  , LogOptions -> Bool
logUseTime :: !Bool
  , LogOptions -> Bool
logUseColor :: !Bool
  , LogOptions -> LogColors
logColors :: !LogColors
  , LogOptions -> Bool
logUseLoc :: !Bool
  , LogOptions -> Utf8Builder -> Utf8Builder
logFormat :: !(Utf8Builder -> Utf8Builder)
  , LogOptions -> Builder -> IO ()
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'.
    LogColors -> LogLevel -> Utf8Builder
logColorLogLevels :: !(LogLevel -> Utf8Builder)
    -- | The color of secondary content.
  , LogColors -> Utf8Builder
logColorSecondary :: !Utf8Builder
    -- | The color of accents, which are indexed by 'Int'.
  , LogColors -> Int -> Utf8Builder
logColorAccents :: !(Int -> Utf8Builder)
  }

defaultLogColors :: LogColors
defaultLogColors :: LogColors
defaultLogColors = LogColors :: (LogLevel -> Utf8Builder)
-> Utf8Builder -> (Int -> Utf8Builder) -> LogColors
LogColors
  { logColorLogLevels :: LogLevel -> Utf8Builder
logColorLogLevels = LogLevel -> Utf8Builder
defaultLogLevelColors
  , logColorSecondary :: Utf8Builder
logColorSecondary = Utf8Builder
defaultLogSecondaryColor
  , logColorAccents :: Int -> Utf8Builder
logColorAccents = Int -> Utf8Builder
defaultLogAccentColors
  }

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

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

defaultLogAccentColors :: Int -> Utf8Builder
defaultLogAccentColors :: Int -> Utf8Builder
defaultLogAccentColors = Utf8Builder -> Int -> Utf8Builder
forall a b. a -> b -> a
const Utf8Builder
"\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 :: LogLevel -> LogOptions -> LogOptions
setLogMinLevel LogLevel
level LogOptions
options = LogOptions
options { logMinLevel :: IO LogLevel
logMinLevel = LogLevel -> IO LogLevel
forall (m :: * -> *) a. Monad m => a -> m a
return LogLevel
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 :: IO LogLevel -> LogOptions -> LogOptions
setLogMinLevelIO IO LogLevel
getLevel LogOptions
options = LogOptions
options { logMinLevel :: IO LogLevel
logMinLevel = IO LogLevel
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 :: Bool -> LogOptions -> LogOptions
setLogVerboseFormat Bool
v LogOptions
options = LogOptions
options { logVerboseFormat :: IO Bool
logVerboseFormat = Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
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 :: IO Bool -> LogOptions -> LogOptions
setLogVerboseFormatIO IO Bool
getVerboseLevel LogOptions
options =
  LogOptions
options { logVerboseFormat :: IO Bool
logVerboseFormat = IO Bool
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 :: Bool -> LogOptions -> LogOptions
setLogTerminal Bool
t LogOptions
options = LogOptions
options { logTerminal :: Bool
logTerminal = Bool
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 :: Bool -> LogOptions -> LogOptions
setLogUseTime Bool
t LogOptions
options = LogOptions
options { logUseTime :: Bool
logUseTime = Bool
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 :: Bool -> LogOptions -> LogOptions
setLogUseColor Bool
c LogOptions
options = LogOptions
options { logUseColor :: Bool
logUseColor = Bool
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 :: (LogLevel -> Utf8Builder) -> LogOptions -> LogOptions
setLogLevelColors LogLevel -> Utf8Builder
logLevelColors LogOptions
options =
  let lc :: LogColors
lc = (LogOptions -> LogColors
logColors LogOptions
options){ logColorLogLevels :: LogLevel -> Utf8Builder
logColorLogLevels = LogLevel -> Utf8Builder
logLevelColors }
  in  LogOptions
options { logColors :: LogColors
logColors = 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 :: Utf8Builder -> LogOptions -> LogOptions
setLogSecondaryColor Utf8Builder
c LogOptions
options =
  let lc :: LogColors
lc = (LogOptions -> LogColors
logColors LogOptions
options){ logColorSecondary :: Utf8Builder
logColorSecondary = Utf8Builder
c }
  in  LogOptions
options { logColors :: LogColors
logColors = 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 :: (Int -> Utf8Builder) -> LogOptions -> LogOptions
setLogAccentColors Int -> Utf8Builder
accentColors LogOptions
options =
  let lc :: LogColors
lc = (LogOptions -> LogColors
logColors LogOptions
options){ logColorAccents :: Int -> Utf8Builder
logColorAccents = Int -> Utf8Builder
accentColors }
  in  LogOptions
options { logColors :: LogColors
logColors = 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 :: Bool -> LogOptions -> LogOptions
setLogUseLoc Bool
l LogOptions
options = LogOptions
options { logUseLoc :: Bool
logUseLoc = Bool
l }

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

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

    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LogLevel
level LogLevel -> LogLevel -> Bool
forall a. Ord a => a -> a -> Bool
>= LogLevel
logLevel) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      Utf8Builder
timestamp <- Bool -> IO Utf8Builder
getTimestamp Bool
logVerbose
      LogOptions -> Builder -> IO ()
logSend LogOptions
lo (Builder -> IO ()) -> Builder -> IO ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder -> Builder
getUtf8Builder (Utf8Builder -> Builder) -> Utf8Builder -> Builder
forall a b. (a -> b) -> a -> b
$
        Utf8Builder
timestamp Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
        Bool -> Utf8Builder
getLevel Bool
logVerbose Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
        Utf8Builder -> Utf8Builder
ansi Utf8Builder
reset Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
        Utf8Builder
getSource Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
        LogOptions -> Utf8Builder -> Utf8Builder
logFormat LogOptions
lo Utf8Builder
msg Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
        Utf8Builder
getLoc Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
        Utf8Builder -> Utf8Builder
ansi Utf8Builder
reset Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
        Utf8Builder
"\n"
  where
   reset :: Utf8Builder
reset = Utf8Builder
"\ESC[0m"
   lc :: LogColors
lc = LogOptions -> LogColors
logColors LogOptions
lo
   levelColor :: Utf8Builder
levelColor = LogColors -> LogLevel -> Utf8Builder
logColorLogLevels LogColors
lc LogLevel
level
   timestampColor :: Utf8Builder
timestampColor = LogColors -> Utf8Builder
logColorSecondary LogColors
lc
   locColor :: Utf8Builder
locColor = LogColors -> Utf8Builder
logColorSecondary LogColors
lc

   ansi :: Utf8Builder -> Utf8Builder
   ansi :: Utf8Builder -> Utf8Builder
ansi Utf8Builder
xs | LogOptions -> Bool
logUseColor LogOptions
lo = Utf8Builder
xs
           | Bool
otherwise = Utf8Builder
forall a. Monoid a => a
mempty

   getTimestamp :: Bool -> IO Utf8Builder
   getTimestamp :: Bool -> IO Utf8Builder
getTimestamp Bool
logVerbose
     | Bool
logVerbose Bool -> Bool -> Bool
&& LogOptions -> Bool
logUseTime LogOptions
lo =
       do ZonedTime
now <- IO ZonedTime
getZonedTime
          Utf8Builder -> IO Utf8Builder
forall (m :: * -> *) a. Monad m => a -> m a
return (Utf8Builder -> IO Utf8Builder) -> Utf8Builder -> IO Utf8Builder
forall a b. (a -> b) -> a -> b
$ Utf8Builder -> Utf8Builder
ansi Utf8Builder
timestampColor Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> String -> Utf8Builder
forall a. IsString a => String -> a
fromString (ZonedTime -> String
formatTime' ZonedTime
now) Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
": "
     | Bool
otherwise = Utf8Builder -> IO Utf8Builder
forall (m :: * -> *) a. Monad m => a -> m a
return Utf8Builder
forall a. Monoid a => a
mempty
     where
       formatTime' :: ZonedTime -> String
formatTime' =
           Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
timestampLength ShowS -> (ZonedTime -> String) -> ZonedTime -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeLocale -> String -> ZonedTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%F %T.%q"

   getLevel :: Bool -> Utf8Builder
   getLevel :: Bool -> Utf8Builder
getLevel Bool
logVerbose
     | Bool
logVerbose = Utf8Builder -> Utf8Builder
ansi Utf8Builder
levelColor Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
         case LogLevel
level of
           LogLevel
LevelDebug -> Utf8Builder
"[debug] "
           LogLevel
LevelInfo -> Utf8Builder
"[info] "
           LogLevel
LevelWarn -> Utf8Builder
"[warn] "
           LogLevel
LevelError -> Utf8Builder
"[error] "
           LevelOther LogSource
name ->
             Utf8Builder
"[" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
             LogSource -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display LogSource
name Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
             Utf8Builder
"] "
     | Bool
otherwise = Utf8Builder
forall a. Monoid a => a
mempty

   getSource :: Utf8Builder
   getSource :: Utf8Builder
getSource = case LogSource
src of
     LogSource
"" -> Utf8Builder
""
     LogSource
_  -> Utf8Builder
"(" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> LogSource -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display LogSource
src Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
") "

   getLoc :: Utf8Builder
   getLoc :: Utf8Builder
getLoc
     | LogOptions -> Bool
logUseLoc LogOptions
lo = Utf8Builder -> Utf8Builder
ansi Utf8Builder
locColor Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\n@(" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> CallStack -> Utf8Builder
displayCallStack CallStack
cs Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
")"
     | Bool
otherwise = Utf8Builder
forall a. Monoid a => a
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 :: CallStack -> Utf8Builder
displayCallStack CallStack
cs =
     case [(String, SrcLoc)] -> [(String, SrcLoc)]
forall a. [a] -> [a]
reverse ([(String, SrcLoc)] -> [(String, SrcLoc)])
-> [(String, SrcLoc)] -> [(String, SrcLoc)]
forall a b. (a -> b) -> a -> b
$ CallStack -> [(String, SrcLoc)]
getCallStack CallStack
cs of
       [] -> Utf8Builder
"<no call stack found>"
       (String
_desc, SrcLoc
loc):[(String, SrcLoc)]
_ ->
         let file :: String
file = SrcLoc -> String
srcLocFile SrcLoc
loc
          in String -> Utf8Builder
forall a. IsString a => String -> a
fromString String
file Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
             Utf8Builder
":" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
             Int -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow (SrcLoc -> Int
srcLocStartLine SrcLoc
loc) Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
             Utf8Builder
":" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
             Int -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow (SrcLoc -> Int
srcLocStartCol SrcLoc
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 :: Int
timestampLength =
  String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%F %T.000000" (Day -> DiffTime -> UTCTime
UTCTime (Integer -> Day
ModifiedJulianDay Integer
0) DiffTime
0))

stickyImpl
    :: MVar (ByteString,Int) -> LogOptions
    -> (CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ())
    -> CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ()
stickyImpl :: MVar (ByteString, Int)
-> LogOptions
-> (CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ())
-> CallStack
-> LogSource
-> LogLevel
-> Utf8Builder
-> IO ()
stickyImpl MVar (ByteString, Int)
ref LogOptions
lo CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ()
logFunc CallStack
loc LogSource
src LogLevel
level Utf8Builder
msgOrig = MVar (ByteString, Int)
-> ((ByteString, Int) -> IO (ByteString, Int)) -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
MVar a -> (a -> m a) -> m ()
modifyMVar_ MVar (ByteString, Int)
ref (((ByteString, Int) -> IO (ByteString, Int)) -> IO ())
-> ((ByteString, Int) -> IO (ByteString, Int)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(ByteString
sticky,Int
stickyLen) -> do
  let backSpaceChar :: Char
backSpaceChar = Char
'\8'
      repeating :: Char -> Builder
repeating = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder) -> (Char -> [Builder]) -> Char -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Builder -> [Builder]
forall a. Int -> a -> [a]
replicate Int
stickyLen (Builder -> [Builder]) -> (Char -> Builder) -> Char -> [Builder]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Builder
char7
      clear :: IO ()
clear = LogOptions -> Builder -> IO ()
logSend LogOptions
lo
        (Char -> Builder
repeating Char
backSpaceChar Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
        Char -> Builder
repeating Char
' ' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
        Char -> Builder
repeating Char
backSpaceChar)

  LogLevel
logLevel <- LogOptions -> IO LogLevel
logMinLevel LogOptions
lo

  case LogLevel
level of
    LevelOther LogSource
"sticky-done" -> do
      IO ()
clear
      CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ()
logFunc CallStack
loc LogSource
src LogLevel
LevelInfo Utf8Builder
msgOrig
      (ByteString, Int) -> IO (ByteString, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
forall a. Monoid a => a
mempty,Int
0)
    LevelOther LogSource
"sticky" -> do
      IO ()
clear
      let bs :: ByteString
bs = ByteString -> ByteString
toStrictBytes (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ Utf8Builder -> Builder
getUtf8Builder Utf8Builder
msgOrig
      LogOptions -> Builder -> IO ()
logSend LogOptions
lo (ByteString -> Builder
byteString ByteString
bs Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
flush)
      (ByteString, Int) -> IO (ByteString, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
bs, ByteString -> Int
utf8CharacterCount ByteString
bs)
    LogLevel
_
      | LogLevel
level LogLevel -> LogLevel -> Bool
forall a. Ord a => a -> a -> Bool
>= LogLevel
logLevel -> do
          IO ()
clear
          CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ()
logFunc CallStack
loc LogSource
src LogLevel
level Utf8Builder
msgOrig
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
B.null ByteString
sticky) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ LogOptions -> Builder -> IO ()
logSend LogOptions
lo (ByteString -> Builder
byteString ByteString
sticky Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
flush)
          (ByteString, Int) -> IO (ByteString, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
sticky,Int
stickyLen)
      | Bool
otherwise -> (ByteString, Int) -> IO (ByteString, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
sticky,Int
stickyLen)

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

    dropCSI :: ByteString -> ByteString
dropCSI ByteString
bs = case ByteString -> Maybe (Word8, ByteString)
B.uncons ByteString
bs of
        Just (Word8
0x5B,ByteString
bs2) -> Int -> ByteString -> ByteString
B.drop Int
1 (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ (Word8 -> Bool) -> ByteString -> ByteString
B.dropWhile Word8 -> Bool
forall a. (Ord a, Num a) => a -> Bool
isSequenceByte ByteString
bs2
        Maybe (Word8, ByteString)
_               -> ByteString
bs

    isSequenceByte :: a -> Bool
isSequenceByte a
c = a
c a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
0x20 Bool -> Bool -> Bool
&& a
c a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
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 :: SimpleGetter env Bool
logFuncUseColorL = (LogFunc -> Const r LogFunc) -> env -> Const r env
forall env. HasLogFunc env => Lens' env LogFunc
logFuncL((LogFunc -> Const r LogFunc) -> env -> Const r env)
-> ((Bool -> Const r Bool) -> LogFunc -> Const r LogFunc)
-> (Bool -> Const r Bool)
-> env
-> Const r env
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(LogFunc -> Bool) -> SimpleGetter LogFunc Bool
forall s a. (s -> a) -> SimpleGetter s a
to (Bool -> (LogOptions -> Bool) -> Maybe LogOptions -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False LogOptions -> Bool
logUseColor (Maybe LogOptions -> Bool)
-> (LogFunc -> Maybe LogOptions) -> LogFunc -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogFunc -> Maybe LogOptions
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 :: SimpleGetter env (LogLevel -> Utf8Builder)
logFuncLogLevelColorsL = (LogFunc -> Const r LogFunc) -> env -> Const r env
forall env. HasLogFunc env => Lens' env LogFunc
logFuncL((LogFunc -> Const r LogFunc) -> env -> Const r env)
-> (((LogLevel -> Utf8Builder)
     -> Const r (LogLevel -> Utf8Builder))
    -> LogFunc -> Const r LogFunc)
-> ((LogLevel -> Utf8Builder) -> Const r (LogLevel -> Utf8Builder))
-> env
-> Const r env
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(LogFunc -> LogLevel -> Utf8Builder)
-> SimpleGetter LogFunc (LogLevel -> Utf8Builder)
forall s a. (s -> a) -> SimpleGetter s a
to
                           ((LogLevel -> Utf8Builder)
-> (LogOptions -> LogLevel -> Utf8Builder)
-> Maybe LogOptions
-> LogLevel
-> Utf8Builder
forall b a. b -> (a -> b) -> Maybe a -> b
maybe LogLevel -> Utf8Builder
defaultLogLevelColors
                                  (LogColors -> LogLevel -> Utf8Builder
logColorLogLevels (LogColors -> LogLevel -> Utf8Builder)
-> (LogOptions -> LogColors)
-> LogOptions
-> LogLevel
-> Utf8Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogOptions -> LogColors
logColors) (Maybe LogOptions -> LogLevel -> Utf8Builder)
-> (LogFunc -> Maybe LogOptions)
-> LogFunc
-> LogLevel
-> Utf8Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogFunc -> Maybe LogOptions
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 :: SimpleGetter env Utf8Builder
logFuncSecondaryColorL = (LogFunc -> Const r LogFunc) -> env -> Const r env
forall env. HasLogFunc env => Lens' env LogFunc
logFuncL((LogFunc -> Const r LogFunc) -> env -> Const r env)
-> ((Utf8Builder -> Const r Utf8Builder)
    -> LogFunc -> Const r LogFunc)
-> (Utf8Builder -> Const r Utf8Builder)
-> env
-> Const r env
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(LogFunc -> Utf8Builder) -> SimpleGetter LogFunc Utf8Builder
forall s a. (s -> a) -> SimpleGetter s a
to
                           (Utf8Builder
-> (LogOptions -> Utf8Builder) -> Maybe LogOptions -> Utf8Builder
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Utf8Builder
defaultLogSecondaryColor
                                  (LogColors -> Utf8Builder
logColorSecondary (LogColors -> Utf8Builder)
-> (LogOptions -> LogColors) -> LogOptions -> Utf8Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogOptions -> LogColors
logColors) (Maybe LogOptions -> Utf8Builder)
-> (LogFunc -> Maybe LogOptions) -> LogFunc -> Utf8Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogFunc -> Maybe LogOptions
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 :: SimpleGetter env (Int -> Utf8Builder)
logFuncAccentColorsL = (LogFunc -> Const r LogFunc) -> env -> Const r env
forall env. HasLogFunc env => Lens' env LogFunc
logFuncL((LogFunc -> Const r LogFunc) -> env -> Const r env)
-> (((Int -> Utf8Builder) -> Const r (Int -> Utf8Builder))
    -> LogFunc -> Const r LogFunc)
-> ((Int -> Utf8Builder) -> Const r (Int -> Utf8Builder))
-> env
-> Const r env
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(LogFunc -> Int -> Utf8Builder)
-> SimpleGetter LogFunc (Int -> Utf8Builder)
forall s a. (s -> a) -> SimpleGetter s a
to
                           ((Int -> Utf8Builder)
-> (LogOptions -> Int -> Utf8Builder)
-> Maybe LogOptions
-> Int
-> Utf8Builder
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int -> Utf8Builder
defaultLogAccentColors
                                  (LogColors -> Int -> Utf8Builder
logColorAccents (LogColors -> Int -> Utf8Builder)
-> (LogOptions -> LogColors) -> LogOptions -> Int -> Utf8Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogOptions -> LogColors
logColors) (Maybe LogOptions -> Int -> Utf8Builder)
-> (LogFunc -> Maybe LogOptions) -> LogFunc -> Int -> Utf8Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogFunc -> Maybe LogOptions
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 :: m a -> m a
noLogging = (env -> env) -> m a -> m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (ASetter env env LogFunc LogFunc -> LogFunc -> env -> env
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter env env LogFunc LogFunc
forall env. HasLogFunc env => Lens' env LogFunc
logFuncL LogFunc
forall a. Monoid a => a
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 :: (GLogFunc (GMsg (GLogFunc msg))
 -> f (GLogFunc (GMsg (GLogFunc msg))))
-> GLogFunc msg -> f (GLogFunc msg)
gLogFuncL = (GLogFunc (GMsg (GLogFunc msg))
 -> f (GLogFunc (GMsg (GLogFunc msg))))
-> GLogFunc msg -> f (GLogFunc msg)
forall a. a -> a
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 :: (a -> b) -> GLogFunc b -> GLogFunc a
contramap = (a -> b) -> GLogFunc b -> GLogFunc a
forall a b. (a -> b) -> GLogFunc b -> GLogFunc a
contramapGLogFunc
  {-# INLINABLE contramap #-}
#endif

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

-- | 'mempty' peforms no logging.
--
-- @since 0.1.13.0
instance Monoid (GLogFunc msg) where
  mempty :: GLogFunc msg
mempty = (CallStack -> msg -> IO ()) -> GLogFunc msg
forall msg. (CallStack -> msg -> IO ()) -> GLogFunc msg
mkGLogFunc ((CallStack -> msg -> IO ()) -> GLogFunc msg)
-> (CallStack -> msg -> IO ()) -> GLogFunc msg
forall a b. (a -> b) -> a -> b
$ \CallStack
_ msg
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  mappend :: GLogFunc msg -> GLogFunc msg -> GLogFunc msg
mappend = GLogFunc msg -> GLogFunc msg -> GLogFunc msg
forall a. Semigroup a => a -> a -> a
(<>)

-- | A vesion of 'contramapMaybeGLogFunc' which supports filering.
--
-- @since 0.1.13.0
contramapMaybeGLogFunc :: (a -> Maybe b) -> GLogFunc b -> GLogFunc a
contramapMaybeGLogFunc :: (a -> Maybe b) -> GLogFunc b -> GLogFunc a
contramapMaybeGLogFunc a -> Maybe b
f (GLogFunc CallStack -> b -> IO ()
io) =
  (CallStack -> a -> IO ()) -> GLogFunc a
forall msg. (CallStack -> msg -> IO ()) -> GLogFunc msg
GLogFunc (\CallStack
stack a
msg -> IO () -> (b -> IO ()) -> Maybe b -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (CallStack -> b -> IO ()
io CallStack
stack) (a -> Maybe b
f a
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 :: (a -> b) -> GLogFunc b -> GLogFunc a
contramapGLogFunc a -> b
f (GLogFunc CallStack -> b -> IO ()
io) = (CallStack -> a -> IO ()) -> GLogFunc a
forall msg. (CallStack -> msg -> IO ()) -> GLogFunc msg
GLogFunc (\CallStack
stack a
msg -> CallStack -> b -> IO ()
io CallStack
stack (a -> b
f a
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 :: (CallStack -> msg -> IO ()) -> GLogFunc msg
mkGLogFunc = (CallStack -> msg -> IO ()) -> GLogFunc msg
forall msg. (CallStack -> msg -> IO ()) -> GLogFunc msg
GLogFunc

-- | Log a value generically.
--
-- @since 0.1.13.0
glog ::
     (MonadIO m, HasCallStack, HasGLogFunc env, MonadReader env m)
  => GMsg env
  -> m ()
glog :: GMsg env -> m ()
glog GMsg env
t = do
  GLogFunc CallStack -> GMsg env -> IO ()
gLogFunc <- Getting (GLogFunc (GMsg env)) env (GLogFunc (GMsg env))
-> m (GLogFunc (GMsg env))
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (GLogFunc (GMsg env)) env (GLogFunc (GMsg env))
forall env. HasGLogFunc env => Lens' env (GLogFunc (GMsg env))
gLogFuncL
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (CallStack -> GMsg env -> IO ()
gLogFunc CallStack
HasCallStack => CallStack
callStack GMsg env
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 -> GLogFunc msg
gLogFuncClassic (LogFunc {unLogFunc :: LogFunc
-> CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ()
unLogFunc = CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ()
io}) =
  (CallStack -> msg -> IO ()) -> GLogFunc msg
forall msg. (CallStack -> msg -> IO ()) -> GLogFunc msg
mkGLogFunc
    (\CallStack
theCallStack msg
msg ->
       IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
         (CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ()
io CallStack
theCallStack (msg -> LogSource
forall msg. HasLogSource msg => msg -> LogSource
getLogSource msg
msg) (msg -> LogLevel
forall msg. HasLogLevel msg => msg -> LogLevel
getLogLevel msg
msg) (msg -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display msg
msg)))