{-# 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
, logDebug
, logInfo
, logWarn
, logError
, logOther
, logSticky
, logStickyDone
, logDebugS
, logInfoS
, logWarnS
, logErrorS
, logOtherS
, logGeneric
, mkLogFunc
, logOptionsMemory
, LogLevel (..)
, LogSource
, CallStack
, displayCallStack
, noLogging
, logFuncUseColorL
, 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
(LogLevel -> LogLevel -> Bool)
-> (LogLevel -> LogLevel -> Bool) -> Eq LogLevel
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LogLevel -> LogLevel -> Bool
$c/= :: LogLevel -> LogLevel -> Bool
== :: LogLevel -> LogLevel -> Bool
$c== :: LogLevel -> LogLevel -> Bool
Eq, Int -> LogLevel -> ShowS
[LogLevel] -> ShowS
LogLevel -> String
(Int -> LogLevel -> ShowS)
-> (LogLevel -> String) -> ([LogLevel] -> ShowS) -> Show LogLevel
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LogLevel] -> ShowS
$cshowList :: [LogLevel] -> ShowS
show :: LogLevel -> String
$cshow :: LogLevel -> String
showsPrec :: Int -> LogLevel -> ShowS
$cshowsPrec :: Int -> LogLevel -> ShowS
Show, ReadPrec [LogLevel]
ReadPrec LogLevel
Int -> ReadS LogLevel
ReadS [LogLevel]
(Int -> ReadS LogLevel)
-> ReadS [LogLevel]
-> ReadPrec LogLevel
-> ReadPrec [LogLevel]
-> Read LogLevel
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [LogLevel]
$creadListPrec :: ReadPrec [LogLevel]
readPrec :: ReadPrec LogLevel
$creadPrec :: ReadPrec LogLevel
readList :: ReadS [LogLevel]
$creadList :: ReadS [LogLevel]
readsPrec :: Int -> ReadS LogLevel
$creadsPrec :: Int -> ReadS LogLevel
Read, Eq LogLevel
Eq LogLevel =>
(LogLevel -> LogLevel -> Ordering)
-> (LogLevel -> LogLevel -> Bool)
-> (LogLevel -> LogLevel -> Bool)
-> (LogLevel -> LogLevel -> Bool)
-> (LogLevel -> LogLevel -> Bool)
-> (LogLevel -> LogLevel -> LogLevel)
-> (LogLevel -> LogLevel -> LogLevel)
-> Ord LogLevel
LogLevel -> LogLevel -> Bool
LogLevel -> LogLevel -> Ordering
LogLevel -> LogLevel -> LogLevel
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: LogLevel -> LogLevel -> LogLevel
$cmin :: LogLevel -> LogLevel -> LogLevel
max :: LogLevel -> LogLevel -> LogLevel
$cmax :: LogLevel -> LogLevel -> LogLevel
>= :: LogLevel -> LogLevel -> Bool
$c>= :: LogLevel -> LogLevel -> Bool
> :: LogLevel -> LogLevel -> Bool
$c> :: LogLevel -> LogLevel -> Bool
<= :: LogLevel -> LogLevel -> Bool
$c<= :: LogLevel -> LogLevel -> Bool
< :: LogLevel -> LogLevel -> Bool
$c< :: LogLevel -> LogLevel -> Bool
compare :: LogLevel -> LogLevel -> Ordering
$ccompare :: LogLevel -> LogLevel -> Ordering
$cp1Ord :: Eq LogLevel
Ord)
type LogSource = Text
class HasLogFunc env where
logFuncL :: Lens' env LogFunc
instance HasLogFunc LogFunc where
logFuncL :: (LogFunc -> f LogFunc) -> LogFunc -> f LogFunc
logFuncL = (LogFunc -> f LogFunc) -> LogFunc -> f LogFunc
forall a. a -> a
id
data LogFunc = LogFunc
{ LogFunc
-> CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ()
unLogFunc :: !(CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ())
, LogFunc -> Maybe LogOptions
lfOptions :: !(Maybe LogOptions)
}
instance Semigroup LogFunc where
LogFunc f :: CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ()
f o1 :: Maybe LogOptions
o1 <> :: LogFunc -> LogFunc -> LogFunc
<> LogFunc g :: CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ()
g o2 :: Maybe LogOptions
o2 = $WLogFunc :: (CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ())
-> Maybe LogOptions -> LogFunc
LogFunc
{ unLogFunc :: CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ()
unLogFunc = \a :: CallStack
a b :: LogSource
b c :: LogLevel
c d :: Utf8Builder
d -> CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ()
f CallStack
a LogSource
b LogLevel
c Utf8Builder
d IO () -> IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ()
g CallStack
a LogSource
b LogLevel
c Utf8Builder
d
, lfOptions :: Maybe LogOptions
lfOptions = Maybe LogOptions
o1 Maybe LogOptions -> Maybe LogOptions -> Maybe LogOptions
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Maybe LogOptions
o2
}
instance Monoid LogFunc where
mempty :: LogFunc
mempty = (CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ())
-> LogFunc
mkLogFunc ((CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ())
-> LogFunc)
-> (CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ())
-> LogFunc
forall a b. (a -> b) -> a -> b
$ \_ _ _ _ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
mappend :: LogFunc -> LogFunc -> LogFunc
mappend = LogFunc -> LogFunc -> LogFunc
forall a. Semigroup a => a -> a -> a
(<>)
mkLogFunc :: (CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ()) -> LogFunc
mkLogFunc :: (CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ())
-> LogFunc
mkLogFunc f :: CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ()
f = (CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ())
-> Maybe LogOptions -> LogFunc
LogFunc CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ()
f Maybe LogOptions
forall a. Maybe a
Nothing
logGeneric
:: (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack)
=> LogSource
-> LogLevel
-> Utf8Builder
-> m ()
logGeneric :: LogSource -> LogLevel -> Utf8Builder -> m ()
logGeneric src :: LogSource
src level :: LogLevel
level str :: Utf8Builder
str = do
LogFunc logFunc :: CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ()
logFunc _ <- Getting LogFunc env LogFunc -> m LogFunc
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting LogFunc env LogFunc
forall env. HasLogFunc env => Lens' env LogFunc
logFuncL
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ()
logFunc CallStack
HasCallStack => CallStack
callStack LogSource
src LogLevel
level Utf8Builder
str
logDebug
:: (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack)
=> Utf8Builder
-> m ()
logDebug :: Utf8Builder -> m ()
logDebug = LogSource -> LogLevel -> Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
LogSource -> LogLevel -> Utf8Builder -> m ()
logGeneric "" LogLevel
LevelDebug
logInfo
:: (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack)
=> Utf8Builder
-> m ()
logInfo :: Utf8Builder -> m ()
logInfo = LogSource -> LogLevel -> Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
LogSource -> LogLevel -> Utf8Builder -> m ()
logGeneric "" LogLevel
LevelInfo
logWarn
:: (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack)
=> Utf8Builder
-> m ()
logWarn :: Utf8Builder -> m ()
logWarn = LogSource -> LogLevel -> Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
LogSource -> LogLevel -> Utf8Builder -> m ()
logGeneric "" LogLevel
LevelWarn
logError
:: (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack)
=> Utf8Builder
-> m ()
logError :: Utf8Builder -> m ()
logError = LogSource -> LogLevel -> Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
LogSource -> LogLevel -> Utf8Builder -> m ()
logGeneric "" LogLevel
LevelError
logOther
:: (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack)
=> Text
-> Utf8Builder
-> m ()
logOther :: LogSource -> Utf8Builder -> m ()
logOther = LogSource -> LogLevel -> Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
LogSource -> LogLevel -> Utf8Builder -> m ()
logGeneric "" (LogLevel -> Utf8Builder -> m ())
-> (LogSource -> LogLevel) -> LogSource -> Utf8Builder -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogSource -> LogLevel
LevelOther
logDebugS
:: (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack)
=> LogSource
-> Utf8Builder
-> m ()
logDebugS :: LogSource -> Utf8Builder -> m ()
logDebugS src :: LogSource
src = LogSource -> LogLevel -> Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
LogSource -> LogLevel -> Utf8Builder -> m ()
logGeneric LogSource
src LogLevel
LevelDebug
logInfoS
:: (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack)
=> LogSource
-> Utf8Builder
-> m ()
logInfoS :: LogSource -> Utf8Builder -> m ()
logInfoS src :: LogSource
src = LogSource -> LogLevel -> Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
LogSource -> LogLevel -> Utf8Builder -> m ()
logGeneric LogSource
src LogLevel
LevelInfo
logWarnS
:: (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack)
=> LogSource
-> Utf8Builder
-> m ()
logWarnS :: LogSource -> Utf8Builder -> m ()
logWarnS src :: LogSource
src = LogSource -> LogLevel -> Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
LogSource -> LogLevel -> Utf8Builder -> m ()
logGeneric LogSource
src LogLevel
LevelWarn
logErrorS
:: (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack)
=> LogSource
-> Utf8Builder
-> m ()
logErrorS :: LogSource -> Utf8Builder -> m ()
logErrorS src :: LogSource
src = LogSource -> LogLevel -> Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
LogSource -> LogLevel -> Utf8Builder -> m ()
logGeneric LogSource
src LogLevel
LevelError
logOtherS
:: (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack)
=> Text
-> LogSource
-> Utf8Builder
-> m ()
logOtherS :: LogSource -> LogSource -> Utf8Builder -> m ()
logOtherS src :: LogSource
src = LogSource -> LogLevel -> Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
LogSource -> LogLevel -> Utf8Builder -> m ()
logGeneric LogSource
src (LogLevel -> Utf8Builder -> m ())
-> (LogSource -> LogLevel) -> LogSource -> Utf8Builder -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogSource -> LogLevel
LevelOther
logSticky :: (MonadIO m, HasCallStack, MonadReader env m, HasLogFunc env) => Utf8Builder -> m ()
logSticky :: Utf8Builder -> m ()
logSticky = LogSource -> Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
LogSource -> Utf8Builder -> m ()
logOther "sticky"
logStickyDone :: (MonadIO m, HasCallStack, MonadReader env m, HasLogFunc env) => Utf8Builder -> m ()
logStickyDone :: Utf8Builder -> m ()
logStickyDone = LogSource -> Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
LogSource -> Utf8Builder -> m ()
logOther "sticky-done"
canUseUtf8 :: MonadIO m => Handle -> m Bool
canUseUtf8 :: Handle -> m Bool
canUseUtf8 h :: Handle
h = IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ String -> Handle -> (Handle__ -> IO Bool) -> IO Bool
forall a. String -> Handle -> (Handle__ -> IO a) -> IO a
wantWritableHandle "canUseUtf8" Handle
h ((Handle__ -> IO Bool) -> IO Bool)
-> (Handle__ -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \h_ :: Handle__
h_ -> do
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ (TextEncoding -> String
textEncodingName (TextEncoding -> String) -> Maybe TextEncoding -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle__ -> Maybe TextEncoding
haCodec Handle__
h_) Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Maybe String
forall a. a -> Maybe a
Just "UTF-8"
logOptionsMemory :: MonadIO m => m (IORef Builder, LogOptions)
logOptionsMemory :: m (IORef Builder, LogOptions)
logOptionsMemory = do
IORef Builder
ref <- Builder -> m (IORef Builder)
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef Builder
forall a. Monoid a => a
mempty
let options :: LogOptions
options = $WLogOptions :: IO LogLevel
-> IO Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> (Utf8Builder -> Utf8Builder)
-> (Builder -> IO ())
-> LogOptions
LogOptions
{ logMinLevel :: IO LogLevel
logMinLevel = LogLevel -> IO LogLevel
forall (m :: * -> *) a. Monad m => a -> m a
return LogLevel
LevelInfo
, logVerboseFormat :: IO Bool
logVerboseFormat = Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
, logTerminal :: Bool
logTerminal = Bool
True
, logUseTime :: Bool
logUseTime = Bool
False
, logUseColor :: Bool
logUseColor = Bool
False
, logUseLoc :: Bool
logUseLoc = Bool
False
, logFormat :: Utf8Builder -> Utf8Builder
logFormat = Utf8Builder -> Utf8Builder
forall a. a -> a
id
, logSend :: Builder -> IO ()
logSend = \new :: Builder
new -> IORef Builder -> (Builder -> (Builder, ())) -> IO ()
forall (m :: * -> *) a b.
MonadIO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef' IORef Builder
ref ((Builder -> (Builder, ())) -> IO ())
-> (Builder -> (Builder, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \old :: Builder
old -> (Builder
old Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
new, ())
}
(IORef Builder, LogOptions) -> m (IORef Builder, LogOptions)
forall (m :: * -> *) a. Monad m => a -> m a
return (IORef Builder
ref, LogOptions
options)
logOptionsHandle
:: MonadIO m
=> Handle
-> Bool
-> m LogOptions
logOptionsHandle :: Handle -> Bool -> m LogOptions
logOptionsHandle handle' :: Handle
handle' verbose :: Bool
verbose = IO LogOptions -> m LogOptions
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO LogOptions -> m LogOptions) -> IO LogOptions -> m LogOptions
forall a b. (a -> b) -> a -> b
$ do
Bool
terminal <- Handle -> IO Bool
forall (m :: * -> *). MonadIO m => Handle -> m Bool
hIsTerminalDevice Handle
handle'
Bool
useUtf8 <- Handle -> IO Bool
forall (m :: * -> *). MonadIO m => Handle -> m Bool
canUseUtf8 Handle
handle'
Bool
unicode <- if Bool
useUtf8 then Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True else IO Bool
getCanUseUnicode
LogOptions -> IO LogOptions
forall (m :: * -> *) a. Monad m => a -> m a
return $WLogOptions :: IO LogLevel
-> IO Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> (Utf8Builder -> Utf8Builder)
-> (Builder -> IO ())
-> LogOptions
LogOptions
{ logMinLevel :: IO LogLevel
logMinLevel = LogLevel -> IO LogLevel
forall (m :: * -> *) a. Monad m => a -> m a
return (LogLevel -> IO LogLevel) -> LogLevel -> IO LogLevel
forall a b. (a -> b) -> a -> b
$ if Bool
verbose then LogLevel
LevelDebug else LogLevel
LevelInfo
, logVerboseFormat :: IO Bool
logVerboseFormat = Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
verbose
, logTerminal :: Bool
logTerminal = Bool
terminal
, logUseTime :: Bool
logUseTime = Bool
verbose
#if WINDOWS
, logUseColor = False
#else
, logUseColor :: Bool
logUseColor = Bool
verbose Bool -> Bool -> Bool
&& Bool
terminal
#endif
, logUseLoc :: Bool
logUseLoc = Bool
verbose
, logFormat :: Utf8Builder -> Utf8Builder
logFormat = Utf8Builder -> Utf8Builder
forall a. a -> a
id
, logSend :: Builder -> IO ()
logSend = \builder :: Builder
builder ->
if Bool
useUtf8 Bool -> Bool -> Bool
&& Bool
unicode
then Handle -> Builder -> IO ()
hPutBuilder Handle
handle' (Builder
builder Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
flush)
else do
let lbs :: ByteString
lbs = Builder -> ByteString
toLazyByteString Builder
builder
bs :: ByteString
bs = ByteString -> ByteString
toStrictBytes ByteString
lbs
case ByteString -> Either UnicodeException LogSource
decodeUtf8' ByteString
bs of
Left e :: UnicodeException
e -> String -> IO ()
forall a. HasCallStack => String -> a
error (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "mkLogOptions: invalid UTF8 sequence: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (UnicodeException, ByteString) -> String
forall a. Show a => a -> String
show (UnicodeException
e, ByteString
bs)
Right text :: LogSource
text -> do
let text' :: LogSource
text'
| Bool
unicode = LogSource
text
| Bool
otherwise = (Char -> Char) -> LogSource -> LogSource
T.map Char -> Char
replaceUnicode LogSource
text
Handle -> LogSource -> IO ()
TIO.hPutStr Handle
handle' LogSource
text'
Handle -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> m ()
hFlush Handle
handle'
}
getCanUseUnicode :: IO Bool
getCanUseUnicode :: IO Bool
getCanUseUnicode = do
let enc :: TextEncoding
enc = TextEncoding
localeEncoding
str :: String
str = "\x2018\x2019"
test :: IO Bool
test = TextEncoding -> String -> (CString -> IO Bool) -> IO Bool
forall a. TextEncoding -> String -> (CString -> IO a) -> IO a
withCString TextEncoding
enc String
str ((CString -> IO Bool) -> IO Bool)
-> (CString -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \cstr :: CString
cstr -> do
String
str' <- TextEncoding -> CString -> IO String
peekCString TextEncoding
enc CString
cstr
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (String
str String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
str')
IO Bool
test IO Bool -> (IOException -> IO Bool) -> IO Bool
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (IOException -> m a) -> m a
`catchIO` \_ -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
newLogFunc :: (MonadIO n, MonadIO m) => LogOptions -> n (LogFunc, m ())
newLogFunc :: LogOptions -> n (LogFunc, m ())
newLogFunc options :: LogOptions
options =
if LogOptions -> Bool
logTerminal LogOptions
options then do
MVar (ByteString, Int)
var <- (ByteString, Int) -> n (MVar (ByteString, Int))
forall (m :: * -> *) a. MonadIO m => a -> m (MVar a)
newMVar (ByteString
forall a. Monoid a => a
mempty,0)
(LogFunc, m ()) -> n (LogFunc, m ())
forall (m :: * -> *) a. Monad m => a -> m a
return ($WLogFunc :: (CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ())
-> Maybe LogOptions -> LogFunc
LogFunc
{ unLogFunc :: CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ()
unLogFunc = MVar (ByteString, Int)
-> LogOptions
-> (CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ())
-> CallStack
-> LogSource
-> LogLevel
-> Utf8Builder
-> IO ()
stickyImpl MVar (ByteString, Int)
var LogOptions
options (LogOptions
-> CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ()
simpleLogFunc LogOptions
options)
, lfOptions :: Maybe LogOptions
lfOptions = LogOptions -> Maybe LogOptions
forall a. a -> Maybe a
Just LogOptions
options
}
, do (state :: ByteString
state,_) <- MVar (ByteString, Int) -> m (ByteString, Int)
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
takeMVar MVar (ByteString, Int)
var
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
B.null ByteString
state) (IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ LogOptions -> Builder -> IO ()
logSend LogOptions
options "\n")
)
else
(LogFunc, m ()) -> n (LogFunc, m ())
forall (m :: * -> *) a. Monad m => a -> m a
return ($WLogFunc :: (CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ())
-> Maybe LogOptions -> LogFunc
LogFunc
{ unLogFunc :: CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ()
unLogFunc = \cs :: CallStack
cs src :: LogSource
src level :: LogLevel
level str :: Utf8Builder
str ->
LogOptions
-> CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ()
simpleLogFunc LogOptions
options CallStack
cs LogSource
src (LogLevel -> LogLevel
noSticky LogLevel
level) Utf8Builder
str
, lfOptions :: Maybe LogOptions
lfOptions = LogOptions -> Maybe LogOptions
forall a. a -> Maybe a
Just LogOptions
options
}
, () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
)
withLogFunc :: MonadUnliftIO m => LogOptions -> (LogFunc -> m a) -> m a
withLogFunc :: LogOptions -> (LogFunc -> m a) -> m a
withLogFunc options :: LogOptions
options inner :: LogFunc -> m a
inner = ((forall a. m a -> IO a) -> IO a) -> m a
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO a) -> m a)
-> ((forall a. m a -> IO a) -> IO a) -> m a
forall a b. (a -> b) -> a -> b
$ \run :: forall a. m a -> IO a
run -> do
IO (LogFunc, IO ())
-> ((LogFunc, IO ()) -> IO ())
-> ((LogFunc, IO ()) -> IO a)
-> IO a
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket (LogOptions -> IO (LogFunc, IO ())
forall (n :: * -> *) (m :: * -> *).
(MonadIO n, MonadIO m) =>
LogOptions -> n (LogFunc, m ())
newLogFunc LogOptions
options)
(LogFunc, IO ()) -> IO ()
forall a b. (a, b) -> b
snd
(m a -> IO a
forall a. m a -> IO a
run (m a -> IO a)
-> ((LogFunc, IO ()) -> m a) -> (LogFunc, IO ()) -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogFunc -> m a
inner (LogFunc -> m a)
-> ((LogFunc, IO ()) -> LogFunc) -> (LogFunc, IO ()) -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LogFunc, IO ()) -> LogFunc
forall a b. (a, b) -> a
fst)
replaceUnicode :: Char -> Char
replaceUnicode :: Char -> Char
replaceUnicode '\x2018' = '`'
replaceUnicode '\x2019' = '\''
replaceUnicode c :: Char
c = Char
c
noSticky :: LogLevel -> LogLevel
noSticky :: LogLevel -> LogLevel
noSticky (LevelOther "sticky-done") = LogLevel
LevelInfo
noSticky (LevelOther "sticky") = LogLevel
LevelInfo
noSticky level :: 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 -> Bool
logUseLoc :: !Bool
, LogOptions -> Utf8Builder -> Utf8Builder
logFormat :: !(Utf8Builder -> Utf8Builder)
, LogOptions -> Builder -> IO ()
logSend :: !(Builder -> IO ())
}
setLogMinLevel :: LogLevel -> LogOptions -> LogOptions
setLogMinLevel :: LogLevel -> LogOptions -> LogOptions
setLogMinLevel level :: LogLevel
level options :: LogOptions
options = LogOptions
options { logMinLevel :: IO LogLevel
logMinLevel = LogLevel -> IO LogLevel
forall (m :: * -> *) a. Monad m => a -> m a
return LogLevel
level }
setLogMinLevelIO :: IO LogLevel -> LogOptions -> LogOptions
setLogMinLevelIO :: IO LogLevel -> LogOptions -> LogOptions
setLogMinLevelIO getLevel :: IO LogLevel
getLevel options :: LogOptions
options = LogOptions
options { logMinLevel :: IO LogLevel
logMinLevel = IO LogLevel
getLevel }
setLogVerboseFormat :: Bool -> LogOptions -> LogOptions
setLogVerboseFormat :: Bool -> LogOptions -> LogOptions
setLogVerboseFormat v :: Bool
v options :: LogOptions
options = LogOptions
options { logVerboseFormat :: IO Bool
logVerboseFormat = Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
v }
setLogVerboseFormatIO :: IO Bool -> LogOptions -> LogOptions
setLogVerboseFormatIO :: IO Bool -> LogOptions -> LogOptions
setLogVerboseFormatIO getVerboseLevel :: IO Bool
getVerboseLevel options :: LogOptions
options =
LogOptions
options { logVerboseFormat :: IO Bool
logVerboseFormat = IO Bool
getVerboseLevel }
setLogTerminal :: Bool -> LogOptions -> LogOptions
setLogTerminal :: Bool -> LogOptions -> LogOptions
setLogTerminal t :: Bool
t options :: LogOptions
options = LogOptions
options { logTerminal :: Bool
logTerminal = Bool
t }
setLogUseTime :: Bool -> LogOptions -> LogOptions
setLogUseTime :: Bool -> LogOptions -> LogOptions
setLogUseTime t :: Bool
t options :: LogOptions
options = LogOptions
options { logUseTime :: Bool
logUseTime = Bool
t }
setLogUseColor :: Bool -> LogOptions -> LogOptions
setLogUseColor :: Bool -> LogOptions -> LogOptions
setLogUseColor c :: Bool
c options :: LogOptions
options = LogOptions
options { logUseColor :: Bool
logUseColor = Bool
c }
setLogUseLoc :: Bool -> LogOptions -> LogOptions
setLogUseLoc :: Bool -> LogOptions -> LogOptions
setLogUseLoc l :: Bool
l options :: LogOptions
options = LogOptions
options { logUseLoc :: Bool
logUseLoc = Bool
l }
setLogFormat :: (Utf8Builder -> Utf8Builder) -> LogOptions -> LogOptions
setLogFormat :: (Utf8Builder -> Utf8Builder) -> LogOptions -> LogOptions
setLogFormat f :: Utf8Builder -> Utf8Builder
f options :: LogOptions
options = LogOptions
options { logFormat :: Utf8Builder -> Utf8Builder
logFormat = Utf8Builder -> Utf8Builder
f }
simpleLogFunc :: LogOptions -> CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ()
simpleLogFunc :: LogOptions
-> CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ()
simpleLogFunc lo :: LogOptions
lo cs :: CallStack
cs src :: LogSource
src level :: LogLevel
level msg :: Utf8Builder
msg = do
LogLevel
logLevel <- LogOptions -> IO LogLevel
logMinLevel LogOptions
lo
Bool
logVerbose <- LogOptions -> IO Bool
logVerboseFormat LogOptions
lo
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LogLevel
level LogLevel -> LogLevel -> Bool
forall a. Ord a => a -> a -> Bool
>= LogLevel
logLevel) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Utf8Builder
timestamp <- Bool -> IO Utf8Builder
getTimestamp Bool
logVerbose
LogOptions -> Builder -> IO ()
logSend LogOptions
lo (Builder -> IO ()) -> Builder -> IO ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder -> Builder
getUtf8Builder (Utf8Builder -> Builder) -> Utf8Builder -> Builder
forall a b. (a -> b) -> a -> b
$
Utf8Builder
timestamp Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
Bool -> Utf8Builder
getLevel Bool
logVerbose Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
Utf8Builder -> Utf8Builder
ansi Utf8Builder
reset Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
getSource Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
LogOptions -> Utf8Builder -> Utf8Builder
logFormat LogOptions
lo Utf8Builder
msg Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
getLoc Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
Utf8Builder -> Utf8Builder
ansi Utf8Builder
reset Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
"\n"
where
reset :: Utf8Builder
reset = "\ESC[0m"
setBlack :: Utf8Builder
setBlack = "\ESC[90m"
setGreen :: Utf8Builder
setGreen = "\ESC[32m"
setBlue :: Utf8Builder
setBlue = "\ESC[34m"
setYellow :: Utf8Builder
setYellow = "\ESC[33m"
setRed :: Utf8Builder
setRed = "\ESC[31m"
setMagenta :: Utf8Builder
setMagenta = "\ESC[35m"
ansi :: Utf8Builder -> Utf8Builder
ansi :: Utf8Builder -> Utf8Builder
ansi xs :: Utf8Builder
xs | LogOptions -> Bool
logUseColor LogOptions
lo = Utf8Builder
xs
| Bool
otherwise = Utf8Builder
forall a. Monoid a => a
mempty
getTimestamp :: Bool -> IO Utf8Builder
getTimestamp :: Bool -> IO Utf8Builder
getTimestamp logVerbose :: Bool
logVerbose
| Bool
logVerbose Bool -> Bool -> Bool
&& LogOptions -> Bool
logUseTime LogOptions
lo =
do ZonedTime
now <- IO ZonedTime
getZonedTime
Utf8Builder -> IO Utf8Builder
forall (m :: * -> *) a. Monad m => a -> m a
return (Utf8Builder -> IO Utf8Builder) -> Utf8Builder -> IO Utf8Builder
forall a b. (a -> b) -> a -> b
$ Utf8Builder -> Utf8Builder
ansi Utf8Builder
setBlack Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> String -> Utf8Builder
forall a. IsString a => String -> a
fromString (ZonedTime -> String
formatTime' ZonedTime
now) Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> ": "
| Bool
otherwise = Utf8Builder -> IO Utf8Builder
forall (m :: * -> *) a. Monad m => a -> m a
return Utf8Builder
forall a. Monoid a => a
mempty
where
formatTime' :: ZonedTime -> String
formatTime' =
Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
timestampLength ShowS -> (ZonedTime -> String) -> ZonedTime -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeLocale -> String -> ZonedTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale "%F %T.%q"
getLevel :: Bool -> Utf8Builder
getLevel :: Bool -> Utf8Builder
getLevel logVerbose :: Bool
logVerbose
| Bool
logVerbose =
case LogLevel
level of
LevelDebug -> Utf8Builder -> Utf8Builder
ansi Utf8Builder
setGreen Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> "[debug] "
LevelInfo -> Utf8Builder -> Utf8Builder
ansi Utf8Builder
setBlue Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> "[info] "
LevelWarn -> Utf8Builder -> Utf8Builder
ansi Utf8Builder
setYellow Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> "[warn] "
LevelError -> Utf8Builder -> Utf8Builder
ansi Utf8Builder
setRed Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> "[error] "
LevelOther name :: LogSource
name ->
Utf8Builder -> Utf8Builder
ansi Utf8Builder
setMagenta Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
"[" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
LogSource -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display LogSource
name Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
"] "
| Bool
otherwise = Utf8Builder
forall a. Monoid a => a
mempty
getSource :: Utf8Builder
getSource :: Utf8Builder
getSource = case LogSource
src of
"" -> ""
_ -> "(" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> LogSource -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display LogSource
src Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> ") "
getLoc :: Utf8Builder
getLoc :: Utf8Builder
getLoc
| LogOptions -> Bool
logUseLoc LogOptions
lo = Utf8Builder -> Utf8Builder
ansi Utf8Builder
setBlack Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> "\n@(" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> CallStack -> Utf8Builder
displayCallStack CallStack
cs Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> ")"
| Bool
otherwise = Utf8Builder
forall a. Monoid a => a
mempty
displayCallStack :: CallStack -> Utf8Builder
displayCallStack :: CallStack -> Utf8Builder
displayCallStack cs :: CallStack
cs =
case [(String, SrcLoc)] -> [(String, SrcLoc)]
forall a. [a] -> [a]
reverse ([(String, SrcLoc)] -> [(String, SrcLoc)])
-> [(String, SrcLoc)] -> [(String, SrcLoc)]
forall a b. (a -> b) -> a -> b
$ CallStack -> [(String, SrcLoc)]
getCallStack CallStack
cs of
[] -> "<no call stack found>"
(_desc :: String
_desc, loc :: SrcLoc
loc):_ ->
let file :: String
file = SrcLoc -> String
srcLocFile SrcLoc
loc
in String -> Utf8Builder
forall a. IsString a => String -> a
fromString String
file Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
":" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
Int -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow (SrcLoc -> Int
srcLocStartLine SrcLoc
loc) Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
":" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
Int -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow (SrcLoc -> Int
srcLocStartCol SrcLoc
loc)
timestampLength :: Int
timestampLength :: Int
timestampLength =
String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale "%F %T.000000" (Day -> DiffTime -> UTCTime
UTCTime (Integer -> Day
ModifiedJulianDay 0) 0))
stickyImpl
:: MVar (ByteString,Int) -> LogOptions
-> (CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ())
-> CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ()
stickyImpl :: MVar (ByteString, Int)
-> LogOptions
-> (CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ())
-> CallStack
-> LogSource
-> LogLevel
-> Utf8Builder
-> IO ()
stickyImpl ref :: MVar (ByteString, Int)
ref lo :: LogOptions
lo logFunc :: CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ()
logFunc loc :: CallStack
loc src :: LogSource
src level :: LogLevel
level msgOrig :: Utf8Builder
msgOrig = MVar (ByteString, Int)
-> ((ByteString, Int) -> IO (ByteString, Int)) -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
MVar a -> (a -> m a) -> m ()
modifyMVar_ MVar (ByteString, Int)
ref (((ByteString, Int) -> IO (ByteString, Int)) -> IO ())
-> ((ByteString, Int) -> IO (ByteString, Int)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(sticky :: ByteString
sticky,stickyLen :: Int
stickyLen) -> do
let backSpaceChar :: Char
backSpaceChar = '\8'
repeating :: Char -> Builder
repeating = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder) -> (Char -> [Builder]) -> Char -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Builder -> [Builder]
forall a. Int -> a -> [a]
replicate Int
stickyLen (Builder -> [Builder]) -> (Char -> Builder) -> Char -> [Builder]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Builder
char7
clear :: IO ()
clear = LogOptions -> Builder -> IO ()
logSend LogOptions
lo
(Char -> Builder
repeating Char
backSpaceChar Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
Char -> Builder
repeating ' ' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
Char -> Builder
repeating Char
backSpaceChar)
LogLevel
logLevel <- LogOptions -> IO LogLevel
logMinLevel LogOptions
lo
case LogLevel
level of
LevelOther "sticky-done" -> do
IO ()
clear
CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ()
logFunc CallStack
loc LogSource
src LogLevel
LevelInfo Utf8Builder
msgOrig
(ByteString, Int) -> IO (ByteString, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
forall a. Monoid a => a
mempty,0)
LevelOther "sticky" -> do
IO ()
clear
let bs :: ByteString
bs = ByteString -> ByteString
toStrictBytes (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ Utf8Builder -> Builder
getUtf8Builder Utf8Builder
msgOrig
LogOptions -> Builder -> IO ()
logSend LogOptions
lo (ByteString -> Builder
byteString ByteString
bs Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
flush)
(ByteString, Int) -> IO (ByteString, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
bs, ByteString -> Int
utf8CharacterCount ByteString
bs)
_
| LogLevel
level LogLevel -> LogLevel -> Bool
forall a. Ord a => a -> a -> Bool
>= LogLevel
logLevel -> do
IO ()
clear
CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ()
logFunc CallStack
loc LogSource
src LogLevel
level Utf8Builder
msgOrig
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
B.null ByteString
sticky) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ LogOptions -> Builder -> IO ()
logSend LogOptions
lo (ByteString -> Builder
byteString ByteString
sticky Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
flush)
(ByteString, Int) -> IO (ByteString, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
sticky,Int
stickyLen)
| Bool
otherwise -> (ByteString, Int) -> IO (ByteString, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
sticky,Int
stickyLen)
utf8CharacterCount :: ByteString -> Int
utf8CharacterCount :: ByteString -> Int
utf8CharacterCount = Int -> ByteString -> Int
forall a. Num a => a -> ByteString -> a
go 0
where
go :: a -> ByteString -> a
go !a
n bs :: ByteString
bs = case ByteString -> Maybe (Word8, ByteString)
B.uncons ByteString
bs of
Nothing -> a
n
Just (c :: Word8
c,bs :: ByteString
bs)
| Word8
c Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. 0xC0 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== 0x80 -> a -> ByteString -> a
go a
n ByteString
bs
| Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== 0x1B -> a -> ByteString -> a
go a
n (ByteString -> a) -> ByteString -> a
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
dropCSI ByteString
bs
| Bool
otherwise -> a -> ByteString -> a
go (a
na -> a -> a
forall a. Num a => a -> a -> a
+1) ByteString
bs
dropCSI :: ByteString -> ByteString
dropCSI bs :: ByteString
bs = case ByteString -> Maybe (Word8, ByteString)
B.uncons ByteString
bs of
Just (0x5B,bs2 :: ByteString
bs2) -> Int -> ByteString -> ByteString
B.drop 1 (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ (Word8 -> Bool) -> ByteString -> ByteString
B.dropWhile Word8 -> Bool
forall a. (Ord a, Num a) => a -> Bool
isSequenceByte ByteString
bs2
_ -> ByteString
bs
isSequenceByte :: a -> Bool
isSequenceByte c :: a
c = a
c a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= 0x20 Bool -> Bool -> Bool
&& a
c a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= 0x3F
logFuncUseColorL :: HasLogFunc env => SimpleGetter env Bool
logFuncUseColorL :: SimpleGetter env Bool
logFuncUseColorL = (LogFunc -> Const r LogFunc) -> env -> Const r env
forall env. HasLogFunc env => Lens' env LogFunc
logFuncL((LogFunc -> Const r LogFunc) -> env -> Const r env)
-> ((Bool -> Const r Bool) -> LogFunc -> Const r LogFunc)
-> (Bool -> Const r Bool)
-> env
-> Const r env
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(LogFunc -> Bool) -> SimpleGetter LogFunc Bool
forall s a. (s -> a) -> SimpleGetter s a
to (Bool -> (LogOptions -> Bool) -> Maybe LogOptions -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False LogOptions -> Bool
logUseColor (Maybe LogOptions -> Bool)
-> (LogFunc -> Maybe LogOptions) -> LogFunc -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogFunc -> Maybe LogOptions
lfOptions)
noLogging :: (HasLogFunc env, MonadReader env m) => m a -> m a
noLogging :: m a -> m a
noLogging = (env -> env) -> m a -> m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (ASetter env env LogFunc LogFunc -> LogFunc -> env -> env
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter env env LogFunc LogFunc
forall env. HasLogFunc env => Lens' env LogFunc
logFuncL LogFunc
forall a. Monoid a => a
mempty)
class HasGLogFunc env where
type GMsg env
gLogFuncL :: Lens' env (GLogFunc (GMsg env))
instance HasGLogFunc (GLogFunc msg) where
type GMsg (GLogFunc msg) = msg
gLogFuncL :: (GLogFunc (GMsg (GLogFunc msg))
-> f (GLogFunc (GMsg (GLogFunc msg))))
-> GLogFunc msg -> f (GLogFunc msg)
gLogFuncL = (GLogFunc (GMsg (GLogFunc msg))
-> f (GLogFunc (GMsg (GLogFunc msg))))
-> GLogFunc msg -> f (GLogFunc msg)
forall a. a -> a
id
newtype GLogFunc msg = GLogFunc (CallStack -> msg -> IO ())
#if MIN_VERSION_base(4,12,0)
instance Contravariant GLogFunc where
contramap :: (a -> b) -> GLogFunc b -> GLogFunc a
contramap = (a -> b) -> GLogFunc b -> GLogFunc a
forall a b. (a -> b) -> GLogFunc b -> GLogFunc a
contramapGLogFunc
{-# INLINABLE contramap #-}
#endif
instance Semigroup (GLogFunc msg) where
GLogFunc f :: CallStack -> msg -> IO ()
f <> :: GLogFunc msg -> GLogFunc msg -> GLogFunc msg
<> GLogFunc g :: CallStack -> msg -> IO ()
g = (CallStack -> msg -> IO ()) -> GLogFunc msg
forall msg. (CallStack -> msg -> IO ()) -> GLogFunc msg
GLogFunc (\a :: CallStack
a b :: msg
b -> CallStack -> msg -> IO ()
f CallStack
a msg
b IO () -> IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> CallStack -> msg -> IO ()
g CallStack
a msg
b)
instance Monoid (GLogFunc msg) where
mempty :: GLogFunc msg
mempty = (CallStack -> msg -> IO ()) -> GLogFunc msg
forall msg. (CallStack -> msg -> IO ()) -> GLogFunc msg
mkGLogFunc ((CallStack -> msg -> IO ()) -> GLogFunc msg)
-> (CallStack -> msg -> IO ()) -> GLogFunc msg
forall a b. (a -> b) -> a -> b
$ \_ _ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
mappend :: GLogFunc msg -> GLogFunc msg -> GLogFunc msg
mappend = GLogFunc msg -> GLogFunc msg -> GLogFunc msg
forall a. Semigroup a => a -> a -> a
(<>)
contramapMaybeGLogFunc :: (a -> Maybe b) -> GLogFunc b -> GLogFunc a
contramapMaybeGLogFunc :: (a -> Maybe b) -> GLogFunc b -> GLogFunc a
contramapMaybeGLogFunc f :: a -> Maybe b
f (GLogFunc io :: CallStack -> b -> IO ()
io) =
(CallStack -> a -> IO ()) -> GLogFunc a
forall msg. (CallStack -> msg -> IO ()) -> GLogFunc msg
GLogFunc (\stack :: CallStack
stack msg :: a
msg -> IO () -> (b -> IO ()) -> Maybe b -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (CallStack -> b -> IO ()
io CallStack
stack) (a -> Maybe b
f a
msg))
{-# INLINABLE contramapMaybeGLogFunc #-}
contramapGLogFunc :: (a -> b) -> GLogFunc b -> GLogFunc a
contramapGLogFunc :: (a -> b) -> GLogFunc b -> GLogFunc a
contramapGLogFunc f :: a -> b
f (GLogFunc io :: CallStack -> b -> IO ()
io) = (CallStack -> a -> IO ()) -> GLogFunc a
forall msg. (CallStack -> msg -> IO ()) -> GLogFunc msg
GLogFunc (\stack :: CallStack
stack msg :: a
msg -> CallStack -> b -> IO ()
io CallStack
stack (a -> b
f a
msg))
{-# INLINABLE contramapGLogFunc #-}
mkGLogFunc :: (CallStack -> msg -> IO ()) -> GLogFunc msg
mkGLogFunc :: (CallStack -> msg -> IO ()) -> GLogFunc msg
mkGLogFunc = (CallStack -> msg -> IO ()) -> GLogFunc msg
forall msg. (CallStack -> msg -> IO ()) -> GLogFunc msg
GLogFunc
glog ::
(MonadIO m, HasCallStack, HasGLogFunc env, MonadReader env m)
=> GMsg env
-> m ()
glog :: GMsg env -> m ()
glog t :: GMsg env
t = do
GLogFunc gLogFunc :: CallStack -> GMsg env -> IO ()
gLogFunc <- Getting (GLogFunc (GMsg env)) env (GLogFunc (GMsg env))
-> m (GLogFunc (GMsg env))
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (GLogFunc (GMsg env)) env (GLogFunc (GMsg env))
forall env. HasGLogFunc env => Lens' env (GLogFunc (GMsg env))
gLogFuncL
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (CallStack -> GMsg env -> IO ()
gLogFunc CallStack
HasCallStack => CallStack
callStack GMsg env
t)
{-# INLINABLE glog #-}
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 :: LogFunc -> GLogFunc msg
gLogFuncClassic (LogFunc {unLogFunc :: LogFunc
-> CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ()
unLogFunc = CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ()
io}) =
(CallStack -> msg -> IO ()) -> GLogFunc msg
forall msg. (CallStack -> msg -> IO ()) -> GLogFunc msg
mkGLogFunc
(\theCallStack :: CallStack
theCallStack msg :: msg
msg ->
IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
(CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ()
io CallStack
theCallStack (msg -> LogSource
forall msg. HasLogSource msg => msg -> LogSource
getLogSource msg
msg) (msg -> LogLevel
forall msg. HasLogLevel msg => msg -> LogLevel
getLogLevel msg
msg) (msg -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display msg
msg)))