{-# 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
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
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]
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
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
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 :: Lens' LogFunc LogFunc
logFuncL = 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 -> Text -> 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 -> Text -> LogLevel -> Utf8Builder -> IO ()
f Maybe LogOptions
o1 <> :: LogFunc -> LogFunc -> LogFunc
<> LogFunc CallStack -> Text -> LogLevel -> Utf8Builder -> IO ()
g Maybe LogOptions
o2 = LogFunc
    { unLogFunc :: CallStack -> Text -> LogLevel -> Utf8Builder -> IO ()
unLogFunc = \CallStack
a Text
b LogLevel
c Utf8Builder
d -> CallStack -> Text -> LogLevel -> Utf8Builder -> IO ()
f CallStack
a Text
b LogLevel
c Utf8Builder
d forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> CallStack -> Text -> LogLevel -> Utf8Builder -> IO ()
g CallStack
a Text
b LogLevel
c Utf8Builder
d
    , lfOptions :: Maybe LogOptions
lfOptions = Maybe LogOptions
o1 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 -> Text -> LogLevel -> Utf8Builder -> IO ()) -> LogFunc
mkLogFunc forall a b. (a -> b) -> a -> b
$ \CallStack
_ Text
_ LogLevel
_ Utf8Builder
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
  mappend :: LogFunc -> LogFunc -> LogFunc
mappend = 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 -> Text -> LogLevel -> Utf8Builder -> IO ()) -> LogFunc
mkLogFunc CallStack -> Text -> LogLevel -> Utf8Builder -> IO ()
f = (CallStack -> Text -> LogLevel -> Utf8Builder -> IO ())
-> Maybe LogOptions -> LogFunc
LogFunc CallStack -> Text -> LogLevel -> Utf8Builder -> IO ()
f 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 :: forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Text -> LogLevel -> Utf8Builder -> m ()
logGeneric Text
src LogLevel
level Utf8Builder
str = do
  LogFunc CallStack -> Text -> LogLevel -> Utf8Builder -> IO ()
logFunc Maybe LogOptions
_ <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasLogFunc env => Lens' env LogFunc
logFuncL
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ CallStack -> Text -> LogLevel -> Utf8Builder -> IO ()
logFunc HasCallStack => CallStack
callStack Text
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 :: forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug = forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Text -> LogLevel -> Utf8Builder -> m ()
logGeneric Text
"" 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 :: forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo = forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Text -> LogLevel -> Utf8Builder -> m ()
logGeneric Text
"" 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 :: forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn = forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Text -> LogLevel -> Utf8Builder -> m ()
logGeneric Text
"" 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 :: forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError = forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Text -> LogLevel -> Utf8Builder -> m ()
logGeneric Text
"" 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 :: forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Text -> Utf8Builder -> m ()
logOther = forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Text -> LogLevel -> Utf8Builder -> m ()
logGeneric Text
"" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> 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 :: forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Text -> Utf8Builder -> m ()
logDebugS Text
src = forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Text -> LogLevel -> Utf8Builder -> m ()
logGeneric Text
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 :: forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Text -> Utf8Builder -> m ()
logInfoS Text
src = forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Text -> LogLevel -> Utf8Builder -> m ()
logGeneric Text
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 :: forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Text -> Utf8Builder -> m ()
logWarnS Text
src = forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Text -> LogLevel -> Utf8Builder -> m ()
logGeneric Text
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 :: forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Text -> Utf8Builder -> m ()
logErrorS Text
src = forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Text -> LogLevel -> Utf8Builder -> m ()
logGeneric Text
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 :: forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Text -> Text -> Utf8Builder -> m ()
logOtherS Text
src = forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Text -> LogLevel -> Utf8Builder -> m ()
logGeneric Text
src forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> 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 :: forall (m :: * -> *) env.
(MonadIO m, HasCallStack, MonadReader env m, HasLogFunc env) =>
Utf8Builder -> m ()
logSticky = forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Text -> Utf8Builder -> m ()
logOther Text
"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 :: forall (m :: * -> *) env.
(MonadIO m, HasCallStack, MonadReader env m, HasLogFunc env) =>
Utf8Builder -> m ()
logStickyDone = forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Text -> Utf8Builder -> m ()
logOther Text
"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 :: forall (m :: * -> *). MonadIO m => Handle -> m Bool
canUseUtf8 Handle
h = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. String -> Handle -> (Handle__ -> IO a) -> IO a
wantWritableHandle String
"canUseUtf8" Handle
h forall a b. (a -> b) -> a -> b
$ \Handle__
h_ -> do
  -- TODO also handle haOutputNL for CRLF
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (TextEncoding -> String
textEncodingName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle__ -> Maybe TextEncoding
haCodec Handle__
h_) forall a. Eq a => a -> a -> Bool
== 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 :: forall (m :: * -> *). MonadIO m => m (IORef Builder, LogOptions)
logOptionsMemory = do
  IORef Builder
ref <- forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef forall a. Monoid a => a
mempty
  let options :: LogOptions
options = LogOptions
        { logMinLevel :: IO LogLevel
logMinLevel = forall (m :: * -> *) a. Monad m => a -> m a
return LogLevel
LevelInfo
        , logVerboseFormat :: IO Bool
logVerboseFormat = 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 = forall a. a -> a
id
        , logSend :: Builder -> IO ()
logSend = \Builder
new -> forall (m :: * -> *) a b.
MonadIO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef' IORef Builder
ref forall a b. (a -> b) -> a -> b
$ \Builder
old -> (Builder
old forall a. Semigroup a => a -> a -> a
<> Builder
new, ())
        }
  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.
-- Logging output is guaranteed to be non-interleaved only for a
-- UTF-8 'Handle' in a multi-thread environment.
--
-- 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 :: forall (m :: * -> *). MonadIO m => Handle -> Bool -> m LogOptions
logOptionsHandle Handle
handle' Bool
verbose = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
  Bool
terminal <- forall (m :: * -> *). MonadIO m => Handle -> m Bool
hIsTerminalDevice Handle
handle'
  Bool
useUtf8 <- forall (m :: * -> *). MonadIO m => Handle -> m Bool
canUseUtf8 Handle
handle'
  Bool
unicode <- if Bool
useUtf8 then forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True else IO Bool
getCanUseUnicode
  forall (m :: * -> *) a. Monad m => a -> m a
return LogOptions
    { logMinLevel :: IO LogLevel
logMinLevel = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if Bool
verbose then LogLevel
LevelDebug else LogLevel
LevelInfo
    , logVerboseFormat :: IO Bool
logVerboseFormat = 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 = 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 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 Text
decodeUtf8' ByteString
bs of
              Left UnicodeException
e -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"mkLogOptions: invalid UTF8 sequence: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (UnicodeException
e, ByteString
bs)
              Right Text
text -> do
                let text' :: Text
text'
                      | Bool
unicode = Text
text
                      | Bool
otherwise = (Char -> Char) -> Text -> Text
T.map Char -> Char
replaceUnicode Text
text
                Handle -> Text -> IO ()
TIO.hPutStr Handle
handle' Text
text'
                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 = forall a. TextEncoding -> String -> (CString -> IO a) -> IO a
withCString TextEncoding
enc String
str forall a b. (a -> b) -> a -> b
$ \CString
cstr -> do
            String
str' <- TextEncoding -> CString -> IO String
peekCString TextEncoding
enc CString
cstr
            forall (m :: * -> *) a. Monad m => a -> m a
return (String
str forall a. Eq a => a -> a -> Bool
== String
str')
    IO Bool
test forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (IOException -> m a) -> m a
`catchIO` \IOException
_ -> 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 :: forall (n :: * -> *) (m :: * -> *).
(MonadIO n, MonadIO m) =>
LogOptions -> n (LogFunc, m ())
newLogFunc LogOptions
options =
  if LogOptions -> Bool
logTerminal LogOptions
options then do
    MVar (ByteString, Int)
var <- forall (m :: * -> *) a. MonadIO m => a -> m (MVar a)
newMVar (forall a. Monoid a => a
mempty,Int
0)
    forall (m :: * -> *) a. Monad m => a -> m a
return (LogFunc
             { unLogFunc :: CallStack -> Text -> LogLevel -> Utf8Builder -> IO ()
unLogFunc = MVar (ByteString, Int)
-> LogOptions
-> (CallStack -> Text -> LogLevel -> Utf8Builder -> IO ())
-> CallStack
-> Text
-> LogLevel
-> Utf8Builder
-> IO ()
stickyImpl MVar (ByteString, Int)
var LogOptions
options (LogOptions -> CallStack -> Text -> LogLevel -> Utf8Builder -> IO ()
simpleLogFunc LogOptions
options)
             , lfOptions :: Maybe LogOptions
lfOptions = forall a. a -> Maybe a
Just LogOptions
options
             }
           , do (ByteString
state,Int
_) <- forall (m :: * -> *) a. MonadIO m => MVar a -> m a
takeMVar MVar (ByteString, Int)
var
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
B.null ByteString
state) (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ LogOptions -> Builder -> IO ()
logSend LogOptions
options Builder
"\n")
           )
  else
    forall (m :: * -> *) a. Monad m => a -> m a
return (LogFunc
            { unLogFunc :: CallStack -> Text -> LogLevel -> Utf8Builder -> IO ()
unLogFunc = \CallStack
cs Text
src LogLevel
level Utf8Builder
str ->
                LogOptions -> CallStack -> Text -> LogLevel -> Utf8Builder -> IO ()
simpleLogFunc LogOptions
options CallStack
cs Text
src (LogLevel -> LogLevel
noSticky LogLevel
level) Utf8Builder
str
            , lfOptions :: Maybe LogOptions
lfOptions = forall a. a -> Maybe a
Just LogOptions
options
            }
           , 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 :: forall (m :: * -> *) a.
MonadUnliftIO m =>
LogOptions -> (LogFunc -> m a) -> m a
withLogFunc LogOptions
options LogFunc -> m a
inner = forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
run -> do
  forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket (forall (n :: * -> *) (m :: * -> *).
(MonadIO n, MonadIO m) =>
LogOptions -> n (LogFunc, m ())
newLogFunc LogOptions
options)
          forall a b. (a, b) -> b
snd
          (forall a. m a -> IO a
run forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogFunc -> m a
inner forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 Text
"sticky-done") = LogLevel
LevelInfo
noSticky (LevelOther Text
"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
  { 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 Text
_) = Utf8Builder
"\ESC[35m" -- Magenta

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

defaultLogAccentColors :: Int -> Utf8Builder
defaultLogAccentColors :: Int -> Utf8Builder
defaultLogAccentColors = 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 = 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 = 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 enable
-- 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 -> Text -> LogLevel -> Utf8Builder -> IO ()
simpleLogFunc LogOptions
lo CallStack
cs Text
src LogLevel
level Utf8Builder
msg = do
    LogLevel
logLevel   <- LogOptions -> IO LogLevel
logMinLevel LogOptions
lo
    Bool
logVerbose <- LogOptions -> IO Bool
logVerboseFormat LogOptions
lo

    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LogLevel
level forall a. Ord a => a -> a -> Bool
>= LogLevel
logLevel) forall a b. (a -> b) -> a -> b
$ do
      Utf8Builder
timestamp <- Bool -> IO Utf8Builder
getTimestamp Bool
logVerbose
      LogOptions -> Builder -> IO ()
logSend LogOptions
lo forall a b. (a -> b) -> a -> b
$ Utf8Builder -> Builder
getUtf8Builder forall a b. (a -> b) -> a -> b
$
        Utf8Builder
timestamp forall a. Semigroup a => a -> a -> a
<>
        Bool -> Utf8Builder
getLevel Bool
logVerbose forall a. Semigroup a => a -> a -> a
<>
        Utf8Builder -> Utf8Builder
ansi Utf8Builder
reset forall a. Semigroup a => a -> a -> a
<>
        Utf8Builder
getSource forall a. Semigroup a => a -> a -> a
<>
        LogOptions -> Utf8Builder -> Utf8Builder
logFormat LogOptions
lo Utf8Builder
msg forall a. Semigroup a => a -> a -> a
<>
        Utf8Builder
getLoc forall a. Semigroup a => a -> a -> a
<>
        Utf8Builder -> Utf8Builder
ansi Utf8Builder
reset 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 = 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
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Utf8Builder -> Utf8Builder
ansi Utf8Builder
timestampColor forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => String -> a
fromString (ZonedTime -> String
formatTime' ZonedTime
now) forall a. Semigroup a => a -> a -> a
<> Utf8Builder
": "
     | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty
     where
       formatTime' :: ZonedTime -> String
formatTime' =
           forall a. Int -> [a] -> [a]
take Int
timestampLength forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 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 Text
name ->
             Utf8Builder
"[" forall a. Semigroup a => a -> a -> a
<>
             forall a. Display a => a -> Utf8Builder
display Text
name forall a. Semigroup a => a -> a -> a
<>
             Utf8Builder
"] "
     | Bool
otherwise = forall a. Monoid a => a
mempty

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

   getLoc :: Utf8Builder
   getLoc :: Utf8Builder
getLoc
     | LogOptions -> Bool
logUseLoc LogOptions
lo = Utf8Builder -> Utf8Builder
ansi Utf8Builder
locColor forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\n@(" forall a. Semigroup a => a -> a -> a
<> CallStack -> Utf8Builder
displayCallStack CallStack
cs forall a. Semigroup a => a -> a -> a
<> Utf8Builder
")"
     | Bool
otherwise = 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 forall a. [a] -> [a]
reverse 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 forall a. IsString a => String -> a
fromString String
file forall a. Semigroup a => a -> a -> a
<>
             Utf8Builder
":" forall a. Semigroup a => a -> a -> a
<>
             forall a. Show a => a -> Utf8Builder
displayShow (SrcLoc -> Int
srcLocStartLine SrcLoc
loc) forall a. Semigroup a => a -> a -> a
<>
             Utf8Builder
":" forall a. Semigroup a => a -> a -> a
<>
             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 =
  forall (t :: * -> *) a. Foldable t => t a -> Int
length (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 -> Text -> LogLevel -> Utf8Builder -> IO ())
-> CallStack
-> Text
-> LogLevel
-> Utf8Builder
-> IO ()
stickyImpl MVar (ByteString, Int)
ref LogOptions
lo CallStack -> Text -> LogLevel -> Utf8Builder -> IO ()
logFunc CallStack
loc Text
src LogLevel
level Utf8Builder
msgOrig = forall (m :: * -> *) a.
MonadUnliftIO m =>
MVar a -> (a -> m a) -> m ()
modifyMVar_ MVar (ByteString, Int)
ref forall a b. (a -> b) -> a -> b
$ \(ByteString
sticky,Int
stickyLen) -> do
  let backSpaceChar :: Char
backSpaceChar = Char
'\8'
      repeating :: Char -> Builder
repeating = forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> a -> [a]
replicate Int
stickyLen 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 forall a. Semigroup a => a -> a -> a
<>
        Char -> Builder
repeating Char
' ' 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 Text
"sticky-done" -> do
      IO ()
clear
      CallStack -> Text -> LogLevel -> Utf8Builder -> IO ()
logFunc CallStack
loc Text
src LogLevel
LevelInfo Utf8Builder
msgOrig
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Monoid a => a
mempty,Int
0)
    LevelOther Text
"sticky" -> do
      IO ()
clear
      let bs :: ByteString
bs = ByteString -> ByteString
toStrictBytes forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
toLazyByteString forall a b. (a -> b) -> a -> b
$ Utf8Builder -> Builder
getUtf8Builder Utf8Builder
msgOrig
      LogOptions -> Builder -> IO ()
logSend LogOptions
lo (ByteString -> Builder
byteString ByteString
bs forall a. Semigroup a => a -> a -> a
<> Builder
flush)
      forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
bs, ByteString -> Int
utf8CharacterCount ByteString
bs)
    LogLevel
_
      | LogLevel
level forall a. Ord a => a -> a -> Bool
>= LogLevel
logLevel -> do
          IO ()
clear
          CallStack -> Text -> LogLevel -> Utf8Builder -> IO ()
logFunc CallStack
loc Text
src LogLevel
level Utf8Builder
msgOrig
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
B.null ByteString
sticky) forall a b. (a -> b) -> a -> b
$ LogOptions -> Builder -> IO ()
logSend LogOptions
lo (ByteString -> Builder
byteString ByteString
sticky forall a. Semigroup a => a -> a -> a
<> Builder
flush)
          forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
sticky,Int
stickyLen)
      | Bool
otherwise -> 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 = forall {t}. Num t => t -> ByteString -> t
go Int
0
  where
    go :: t -> ByteString -> t
go !t
n ByteString
bs = case ByteString -> Maybe (Word8, ByteString)
B.uncons ByteString
bs of
        Maybe (Word8, ByteString)
Nothing -> t
n
        Just (Word8
c,ByteString
bs)
            | Word8
c forall a. Bits a => a -> a -> a
.&. Word8
0xC0 forall a. Eq a => a -> a -> Bool
== Word8
0x80 -> t -> ByteString -> t
go t
n ByteString
bs            -- UTF-8 continuation
            | Word8
c forall a. Eq a => a -> a -> Bool
== Word8
0x1B          -> t -> ByteString -> t
go t
n forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
dropCSI ByteString
bs  -- ANSI escape
            | Bool
otherwise          -> t -> ByteString -> t
go (t
nforall a. Num a => a -> a -> a
+t
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 forall a b. (a -> b) -> a -> b
$ (Word8 -> Bool) -> ByteString -> ByteString
B.dropWhile forall {a}. (Ord a, Num a) => a -> Bool
isSequenceByte ByteString
bs2
        Maybe (Word8, ByteString)
_               -> ByteString
bs

    isSequenceByte :: a -> Bool
isSequenceByte a
c = a
c forall a. Ord a => a -> a -> Bool
>= a
0x20 Bool -> Bool -> Bool
&& a
c 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 :: forall env. HasLogFunc env => SimpleGetter env Bool
logFuncUseColorL = forall env. HasLogFunc env => Lens' env LogFunc
logFuncLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False LogOptions -> Bool
logUseColor 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 :: forall env.
HasLogFunc env =>
SimpleGetter env (LogLevel -> Utf8Builder)
logFuncLogLevelColorsL = forall env. HasLogFunc env => Lens' env LogFunc
logFuncLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to
                           (forall b a. b -> (a -> b) -> Maybe a -> b
maybe LogLevel -> Utf8Builder
defaultLogLevelColors
                                  (LogColors -> LogLevel -> Utf8Builder
logColorLogLevels forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogOptions -> LogColors
logColors) 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 :: forall env. HasLogFunc env => SimpleGetter env Utf8Builder
logFuncSecondaryColorL = forall env. HasLogFunc env => Lens' env LogFunc
logFuncLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to
                           (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Utf8Builder
defaultLogSecondaryColor
                                  (LogColors -> Utf8Builder
logColorSecondary forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogOptions -> LogColors
logColors) 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 :: forall env. HasLogFunc env => SimpleGetter env (Int -> Utf8Builder)
logFuncAccentColorsL = forall env. HasLogFunc env => Lens' env LogFunc
logFuncLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to
                           (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int -> Utf8Builder
defaultLogAccentColors
                                  (LogColors -> Int -> Utf8Builder
logColorAccents forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogOptions -> LogColors
logColors) 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 :: forall env (m :: * -> *) a.
(HasLogFunc env, MonadReader env m) =>
m a -> m a
noLogging = forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (forall s t a b. ASetter s t a b -> b -> s -> t
set forall env. HasLogFunc env => Lens' env LogFunc
logFuncL 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 :: Lens' (GLogFunc msg) (GLogFunc (GMsg (GLogFunc msg)))
gLogFuncL = 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 :: forall a' a. (a' -> a) -> GLogFunc a -> GLogFunc a'
contramap = forall a' a. (a' -> a) -> GLogFunc a -> 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 = forall msg. (CallStack -> msg -> IO ()) -> GLogFunc msg
GLogFunc (\CallStack
a msg
b -> CallStack -> msg -> IO ()
f CallStack
a msg
b 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 = forall msg. (CallStack -> msg -> IO ()) -> GLogFunc msg
mkGLogFunc forall a b. (a -> b) -> a -> b
$ \CallStack
_ msg
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
  mappend :: GLogFunc msg -> GLogFunc msg -> GLogFunc msg
mappend = 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 :: forall a b. (a -> Maybe b) -> GLogFunc b -> GLogFunc a
contramapMaybeGLogFunc a -> Maybe b
f (GLogFunc CallStack -> b -> IO ()
io) =
  forall msg. (CallStack -> msg -> IO ()) -> GLogFunc msg
GLogFunc (\CallStack
stack a
msg -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe (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 :: forall a' a. (a' -> a) -> GLogFunc a -> GLogFunc a'
contramapGLogFunc a -> b
f (GLogFunc CallStack -> b -> IO ()
io) = 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 :: forall msg. (CallStack -> msg -> IO ()) -> GLogFunc msg
mkGLogFunc = 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 :: forall (m :: * -> *) env.
(MonadIO m, HasCallStack, HasGLogFunc env, MonadReader env m) =>
GMsg env -> m ()
glog GMsg env
t = do
  GLogFunc CallStack -> GMsg env -> IO ()
gLogFunc <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasGLogFunc env => Lens' env (GLogFunc (GMsg env))
gLogFuncL
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (CallStack -> GMsg env -> IO ()
gLogFunc 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 :: forall msg.
(HasLogLevel msg, HasLogSource msg, Display msg) =>
LogFunc -> GLogFunc msg
gLogFuncClassic (LogFunc {unLogFunc :: LogFunc -> CallStack -> Text -> LogLevel -> Utf8Builder -> IO ()
unLogFunc = CallStack -> Text -> LogLevel -> Utf8Builder -> IO ()
io}) =
  forall msg. (CallStack -> msg -> IO ()) -> GLogFunc msg
mkGLogFunc
    (\CallStack
theCallStack msg
msg ->
       forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
         (CallStack -> Text -> LogLevel -> Utf8Builder -> IO ()
io CallStack
theCallStack (forall msg. HasLogSource msg => msg -> Text
getLogSource msg
msg) (forall msg. HasLogLevel msg => msg -> LogLevel
getLogLevel msg
msg) (forall a. Display a => a -> Utf8Builder
display msg
msg)))