{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE BangPatterns #-}
module RIO.Prelude.Logger
(
withLogFunc
, newLogFunc
, LogFunc
, HasLogFunc (..)
, logOptionsHandle
, LogOptions
, setLogMinLevel
, setLogMinLevelIO
, setLogVerboseFormat
, setLogVerboseFormatIO
, setLogTerminal
, setLogUseTime
, setLogUseColor
, setLogUseLoc
, setLogFormat
, setLogLevelColors
, setLogSecondaryColor
, setLogAccentColors
, logDebug
, logInfo
, logWarn
, logError
, logOther
, logSticky
, logStickyDone
, logDebugS
, logInfoS
, logWarnS
, logErrorS
, logOtherS
, logGeneric
, mkLogFunc
, logOptionsMemory
, LogLevel (..)
, LogSource
, CallStack
, displayCallStack
, noLogging
, logFuncUseColorL
, logFuncLogLevelColorsL
, logFuncSecondaryColorL
, logFuncAccentColorsL
, 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
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)
type LogSource = Text
class HasLogFunc env where
logFuncL :: Lens' env LogFunc
instance HasLogFunc LogFunc where
logFuncL :: Lens' LogFunc LogFunc
logFuncL = forall a. a -> a
id
data LogFunc = LogFunc
{ LogFunc -> CallStack -> Text -> LogLevel -> Utf8Builder -> IO ()
unLogFunc :: !(CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ())
, LogFunc -> Maybe LogOptions
lfOptions :: !(Maybe LogOptions)
}
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
}
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
(<>)
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
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
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
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
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
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
logOther
:: (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack)
=> Text
-> 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
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
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
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
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
logOtherS
:: (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack)
=> Text
-> 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
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"
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"
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
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"
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)
logOptionsHandle
:: MonadIO m
=> Handle
-> Bool
-> 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'
}
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
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 ()
)
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)
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
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 ())
}
data LogColors = LogColors
{
LogColors -> LogLevel -> Utf8Builder
logColorLogLevels :: !(LogLevel -> Utf8Builder)
, LogColors -> Utf8Builder
logColorSecondary :: !Utf8Builder
, 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"
defaultLogLevelColors LogLevel
LevelInfo = Utf8Builder
"\ESC[34m"
defaultLogLevelColors LogLevel
LevelWarn = Utf8Builder
"\ESC[33m"
defaultLogLevelColors LogLevel
LevelError = Utf8Builder
"\ESC[31m"
defaultLogLevelColors (LevelOther Text
_) = Utf8Builder
"\ESC[35m"
defaultLogSecondaryColor :: Utf8Builder
defaultLogSecondaryColor :: Utf8Builder
defaultLogSecondaryColor = Utf8Builder
"\ESC[90m"
defaultLogAccentColors :: Int -> Utf8Builder
defaultLogAccentColors :: Int -> Utf8Builder
defaultLogAccentColors = forall a b. a -> b -> a
const Utf8Builder
"\ESC[92m"
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 }
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 }
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 }
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 }
setLogTerminal :: Bool -> LogOptions -> LogOptions
setLogTerminal :: Bool -> LogOptions -> LogOptions
setLogTerminal Bool
t LogOptions
options = LogOptions
options { logTerminal :: Bool
logTerminal = Bool
t }
setLogUseTime :: Bool -> LogOptions -> LogOptions
setLogUseTime :: Bool -> LogOptions -> LogOptions
setLogUseTime Bool
t LogOptions
options = LogOptions
options { logUseTime :: Bool
logUseTime = Bool
t }
setLogUseColor :: Bool -> LogOptions -> LogOptions
setLogUseColor :: Bool -> LogOptions -> LogOptions
setLogUseColor Bool
c LogOptions
options = LogOptions
options { logUseColor :: Bool
logUseColor = Bool
c }
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 }
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 }
setLogAccentColors
:: (Int -> Utf8Builder)
-> 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 }
setLogUseLoc :: Bool -> LogOptions -> LogOptions
setLogUseLoc :: Bool -> LogOptions -> LogOptions
setLogUseLoc Bool
l LogOptions
options = LogOptions
options { logUseLoc :: Bool
logUseLoc = Bool
l }
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
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)
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)
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
| 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
| 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
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)
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)
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)
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)
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)
class HasGLogFunc env where
type GMsg env
gLogFuncL :: Lens' env (GLogFunc (GMsg env))
instance HasGLogFunc (GLogFunc msg) where
type GMsg (GLogFunc msg) = msg
gLogFuncL :: Lens' (GLogFunc msg) (GLogFunc (GMsg (GLogFunc msg)))
gLogFuncL = forall a. a -> a
id
newtype GLogFunc msg = GLogFunc (CallStack -> msg -> IO ())
#if MIN_VERSION_base(4,12,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
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)
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
(<>)
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 #-}
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 #-}
mkGLogFunc :: (CallStack -> msg -> IO ()) -> GLogFunc msg
mkGLogFunc :: forall msg. (CallStack -> msg -> IO ()) -> GLogFunc msg
mkGLogFunc = forall msg. (CallStack -> msg -> IO ()) -> GLogFunc msg
GLogFunc
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 #-}
class HasLogLevel msg where
getLogLevel :: msg -> LogLevel
class HasLogSource msg where
getLogSource :: msg -> LogSource
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)))