{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell   #-}
module EasyLogger.Logger
    ( LogDestination (..)
    , LogLevel (..)
    , initLogger
    , initLoggerAllPackages
    , setLoggingDestination
    , setMinLogLevel
    , logAll
    , logPrintAll
    , logDebug
    , logPrintDebug
    , logInfo
    , logPrintInfo
    , logWarning
    , logPrintWarning
    , logError
    , logPrintError
    , pureLogAll
    , pureLogPrintAll
    , pureLogDebug
    , pureLogPrintDebug
    , pureLogInfo
    , pureLogPrintInfo
    , pureLogWarning
    , pureLogPrintWarning
    , pureLogError
    , pureLogPrintError
    , finalizeAllLoggers
    , finalizeLogger
    , flushLoggers
    ) where

import           Control.Applicative        ((<|>))
import           Control.Monad              (join, when)
import           Control.Monad.IO.Class     (liftIO)
import qualified Data.ByteString.Char8      as S8
import           Data.IORef
import           Data.List                  (find)
import qualified Data.Map.Strict            as M
import qualified Data.Text                  as T
import           Language.Haskell.TH.Syntax as TH
import           System.IO
import           System.IO.Unsafe           (unsafePerformIO)

import           EasyLogger.Date
import           EasyLogger.LogStr
import           EasyLogger.LoggerSet
import           EasyLogger.Push
import           EasyLogger.Util            (liftLoc)


import           Debug.Trace

-- | Add a @LoggerSet@ to the known loggers.
setLoggerSet :: String -> LoggerSet -> IO ()
setLoggerSet :: String -> LoggerSet -> IO ()
setLoggerSet String
pkgName LoggerSet
set = IORef (Map String LoggerSet)
-> (Map String LoggerSet -> Map String LoggerSet) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (Map String LoggerSet)
loggerSets (String -> LoggerSet -> Map String LoggerSet -> Map String LoggerSet
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert String
pkgName LoggerSet
set)


-- | Set of loggers. We have one @LoggerSet@ for each package.
loggerSets :: IORef (M.Map String LoggerSet)
loggerSets :: IORef (Map String LoggerSet)
loggerSets = IO (IORef (Map String LoggerSet)) -> IORef (Map String LoggerSet)
forall a. IO a -> a
unsafePerformIO (IO (IORef (Map String LoggerSet)) -> IORef (Map String LoggerSet))
-> IO (IORef (Map String LoggerSet))
-> IORef (Map String LoggerSet)
forall a b. (a -> b) -> a -> b
$ Map String LoggerSet -> IO (IORef (Map String LoggerSet))
forall a. a -> IO (IORef a)
newIORef Map String LoggerSet
forall a. Monoid a => a
mempty
{-# NOINLINE loggerSets  #-}


-- | Should be used to ensure all logs are completely written before the program exists. Cleans all the file descriptors. You (and also no other library) MUST NOT log after this command as all loggers
-- are deinitalized. However, you might initialize the loggers again and before restarting to log.
finalizeAllLoggers :: IO ()
finalizeAllLoggers :: IO ()
finalizeAllLoggers = do
  [String]
pkgs <- ((String, LoggerSet) -> String)
-> [(String, LoggerSet)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, LoggerSet) -> String
forall a b. (a, b) -> a
fst ([(String, LoggerSet)] -> [String])
-> (Map String LoggerSet -> [(String, LoggerSet)])
-> Map String LoggerSet
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map String LoggerSet -> [(String, LoggerSet)]
forall k a. Map k a -> [(k, a)]
M.toList (Map String LoggerSet -> [String])
-> IO (Map String LoggerSet) -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (Map String LoggerSet) -> IO (Map String LoggerSet)
forall a. IORef a -> IO a
readIORef IORef (Map String LoggerSet)
loggerSets
  (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
closeLoggerPkg [String]
pkgs


-- | Can be used to destroy your own logger (from your package) only. You MUST NOT log after this command.
finalizeLogger :: Q Exp
finalizeLogger :: Q Exp
finalizeLogger = [| closeLogger $(qLocation >>= liftLoc)|]


-- | Flush all loggers of all packages.
flushLoggers :: IO ()
flushLoggers :: IO ()
flushLoggers = IORef (Map String LoggerSet) -> IO (Map String LoggerSet)
forall a. IORef a -> IO a
readIORef IORef (Map String LoggerSet)
loggerSets IO (Map String LoggerSet)
-> (Map String LoggerSet -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (LoggerSet -> IO ()) -> Map String LoggerSet -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ LoggerSet -> IO ()
flushLoggerSet


-- | Close logger of calling package.
closeLogger :: Loc -> IO ()
closeLogger :: Loc -> IO ()
closeLogger (Loc String
_ String
pkgName String
_ CharPos
_ CharPos
_) = String -> IO ()
closeLoggerPkg String
pkgName

-- | Close logger of package with provided package name.
closeLoggerPkg :: String -> IO ()
closeLoggerPkg :: String -> IO ()
closeLoggerPkg String
pkgName = do
  Map String LoggerSet
refs <- IORef (Map String LoggerSet) -> IO (Map String LoggerSet)
forall a. IORef a -> IO a
readIORef IORef (Map String LoggerSet)
loggerSets
  case String -> Map String LoggerSet -> Maybe LoggerSet
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
pkgName Map String LoggerSet
refs of
    Maybe LoggerSet
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just set :: LoggerSet
set@(LoggerSet Maybe String
Nothing IORef FD
_ Array Int Logger
_ IO ()
_) -> String -> IO ()
deletePackage String
pkgName IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> LoggerSet -> IO ()
rmLoggerSet LoggerSet
set
    Just set :: LoggerSet
set@(LoggerSet Maybe String
justFp IORef FD
_ Array Int Logger
_ IO ()
_) -> do
      String -> IO ()
deletePackage String
pkgName
      let nrFD :: Int
nrFD = [LoggerSet] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([LoggerSet] -> Int) -> [LoggerSet] -> Int
forall a b. (a -> b) -> a -> b
$ (LoggerSet -> Bool) -> [LoggerSet] -> [LoggerSet]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(LoggerSet Maybe String
mFp IORef FD
_ Array Int Logger
_ IO ()
_) -> Maybe String
mFp Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe String
justFp) (Map String LoggerSet -> [LoggerSet]
forall k a. Map k a -> [a]
M.elems Map String LoggerSet
refs)
      if Int
nrFD Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1
        then LoggerSet -> IO ()
rmLoggerSet LoggerSet
set
        else LoggerSet -> IO ()
flushLoggerSet LoggerSet
set

-- | Delete a package from the logger sets and with this disable all logging. Ensure the LoggerSet is deleted in case this is the last FD before calling this function!
deletePackage :: String -> IO ()
deletePackage :: String -> IO ()
deletePackage String
pkg = IORef (Map String LoggerSet)
-> (Map String LoggerSet -> Map String LoggerSet) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (Map String LoggerSet)
loggerSets (String -> Map String LoggerSet -> Map String LoggerSet
forall k a. Ord k => k -> Map k a -> Map k a
M.delete String
pkg)


-- | Logging destination. See also `setLoggingDestination`.
data LogDestination
  = LogStdErr
  | LogStdOut
  | LogFile FilePath

-- | Log messages from other packages that use this library too, even if they did not call @initLogger@?
type LogFromAllPackages = Bool

-- | Initialise the logger. MUST only be called in the executable code (not the exposed library code)! Takes a `Bool` that decides wether to log messages from other packages that use the same library
-- and did not initalize the Logger (which should be the case for all of them!).
initLoggerAllPackages :: Q Exp
initLoggerAllPackages :: Q Exp
initLoggerAllPackages = [| \dest logLevel logAllPkgs -> setMinLogLevel logLevel >> setLoggingDestination (loc_package $(qLocation >>= liftLoc)) dest logAllPkgs |]

-- | Initialise the logger. MUST only be called in the executable code (not the exposed library code)! Ignores the other packages logs, if the same packages is used for logging.
initLogger :: Q Exp
initLogger :: Q Exp
initLogger = [| \dest logLevel -> setMinLogLevel logLevel >> setLoggingDestination (loc_package $(qLocation >>= liftLoc)) dest False |]

-- | Set the destination for all consequitive for logging. You should only set this once, at the beginning of the program! The default is `LogStdOut`.
setLoggingDestination :: String -> LogDestination -> LogFromAllPackages -> IO ()
setLoggingDestination :: String -> LogDestination -> Bool -> IO ()
setLoggingDestination String
pkgName LogDestination
LogStdErr Bool
logAllPkgs    = Int -> IO LoggerSet
newStderrLoggerSet Int
defaultBufSize  IO LoggerSet -> (LoggerSet -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \LoggerSet
ls -> String -> LoggerSet -> IO ()
setLoggerSet String
pkgName LoggerSet
ls IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
logAllPkgs (LoggerSet -> String -> LogDestination -> IO ()
setLoggingDestinationAllPkgs LoggerSet
ls String
defaultLogPkgName LogDestination
LogStdErr)
setLoggingDestination String
pkgName LogDestination
LogStdOut Bool
logAllPkgs    = Int -> IO LoggerSet
newStdoutLoggerSet Int
defaultBufSize  IO LoggerSet -> (LoggerSet -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \LoggerSet
ls -> String -> LoggerSet -> IO ()
setLoggerSet String
pkgName LoggerSet
ls IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
logAllPkgs (LoggerSet -> String -> LogDestination -> IO ()
setLoggingDestinationAllPkgs LoggerSet
ls String
defaultLogPkgName LogDestination
LogStdOut)
setLoggingDestination String
pkgName (LogFile String
fp) Bool
logAllPkgs = do
  [LoggerSet]
allLs <- Map String LoggerSet -> [LoggerSet]
forall k a. Map k a -> [a]
M.elems (Map String LoggerSet -> [LoggerSet])
-> IO (Map String LoggerSet) -> IO [LoggerSet]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (Map String LoggerSet) -> IO (Map String LoggerSet)
forall a. IORef a -> IO a
readIORef IORef (Map String LoggerSet)
loggerSets
  LoggerSet
ls <-
    case (LoggerSet -> Bool) -> [LoggerSet] -> Maybe LoggerSet
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(LoggerSet Maybe String
mFp IORef FD
_ Array Int Logger
_ IO ()
_) -> Maybe String
mFp Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Maybe String
forall a. a -> Maybe a
Just String
fp) [LoggerSet]
allLs of
      Maybe LoggerSet
Nothing     -> Int -> String -> IO LoggerSet
newFileLoggerSet Int
defaultBufSize String
fp
      Just LoggerSet
lsFile -> Int -> LoggerSet -> IO LoggerSet
newFileLoggerSetSameFile Int
defaultBufSize LoggerSet
lsFile
  String -> LoggerSet -> IO ()
setLoggerSet String
pkgName LoggerSet
ls IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
logAllPkgs (LoggerSet -> String -> LogDestination -> IO ()
setLoggingDestinationAllPkgs LoggerSet
ls String
defaultLogPkgName (String -> LogDestination
LogFile String
fp))


setLoggingDestinationAllPkgs :: LoggerSet -> String -> LogDestination -> IO ()
setLoggingDestinationAllPkgs :: LoggerSet -> String -> LogDestination -> IO ()
setLoggingDestinationAllPkgs LoggerSet
_ String
pkgName LogDestination
LogStdErr  = Int -> IO LoggerSet
newStderrLoggerSet Int
defaultBufSize          IO LoggerSet -> (LoggerSet -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> LoggerSet -> IO ()
setLoggerSet String
pkgName
setLoggingDestinationAllPkgs LoggerSet
_ String
pkgName LogDestination
LogStdOut  = Int -> IO LoggerSet
newStdoutLoggerSet Int
defaultBufSize          IO LoggerSet -> (LoggerSet -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> LoggerSet -> IO ()
setLoggerSet String
pkgName
setLoggingDestinationAllPkgs LoggerSet
ls String
pkgName LogFile{} = Int -> LoggerSet -> IO LoggerSet
newFileLoggerSetSameFile Int
defaultBufSize LoggerSet
ls IO LoggerSet -> (LoggerSet -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> LoggerSet -> IO ()
setLoggerSet String
pkgName


defaultLogPkgName :: String
defaultLogPkgName :: String
defaultLogPkgName = String
"__default__"

mainLogPkgName :: String
mainLogPkgName :: String
mainLogPkgName = String
"main"


-- | The default buffer size (4,096 bytes).
defaultBufSize :: BufSize
defaultBufSize :: Int
defaultBufSize = Int
4096


-- | Log Level. Levels are sorted. `All` < `Debug` < `Info` < `Warning` < `Error`. None disables all logging. Default: All
data LogLevel
  = LogNone
  | LogAll
  | LogDebug
  | LogInfo
  | LogWarning
  | LogError
  deriving (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, LogLevel
LogLevel -> LogLevel -> Bounded LogLevel
forall a. a -> a -> Bounded a
maxBound :: LogLevel
$cmaxBound :: LogLevel
minBound :: LogLevel
$cminBound :: LogLevel
Bounded, Int -> LogLevel
LogLevel -> Int
LogLevel -> [LogLevel]
LogLevel -> LogLevel
LogLevel -> LogLevel -> [LogLevel]
LogLevel -> LogLevel -> LogLevel -> [LogLevel]
(LogLevel -> LogLevel)
-> (LogLevel -> LogLevel)
-> (Int -> LogLevel)
-> (LogLevel -> Int)
-> (LogLevel -> [LogLevel])
-> (LogLevel -> LogLevel -> [LogLevel])
-> (LogLevel -> LogLevel -> [LogLevel])
-> (LogLevel -> LogLevel -> LogLevel -> [LogLevel])
-> Enum LogLevel
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: LogLevel -> LogLevel -> LogLevel -> [LogLevel]
$cenumFromThenTo :: LogLevel -> LogLevel -> LogLevel -> [LogLevel]
enumFromTo :: LogLevel -> LogLevel -> [LogLevel]
$cenumFromTo :: LogLevel -> LogLevel -> [LogLevel]
enumFromThen :: LogLevel -> LogLevel -> [LogLevel]
$cenumFromThen :: LogLevel -> LogLevel -> [LogLevel]
enumFrom :: LogLevel -> [LogLevel]
$cenumFrom :: LogLevel -> [LogLevel]
fromEnum :: LogLevel -> Int
$cfromEnum :: LogLevel -> Int
toEnum :: Int -> LogLevel
$ctoEnum :: Int -> LogLevel
pred :: LogLevel -> LogLevel
$cpred :: LogLevel -> LogLevel
succ :: LogLevel -> LogLevel
$csucc :: LogLevel -> LogLevel
Enum, 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, 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)

-- | Log level text. Make sure you call @initLogger@, or logging will be disabled.
logLevelText :: LogLevel -> T.Text
logLevelText :: LogLevel -> Text
logLevelText LogLevel
LogNone    = Text
forall a. Monoid a => a
mempty
logLevelText LogLevel
LogAll     = Text
"ALL"
logLevelText LogLevel
LogDebug   = Text
"DEBUG"
logLevelText LogLevel
LogInfo    = Text
"INFO "
logLevelText LogLevel
LogWarning = Text
"WARN "
logLevelText LogLevel
LogError   = Text
"ERROR"

-- | Generic log function. Use TH version, e.g. `logDebug`.
logFun :: (ToLogStr msg) => Loc -> LogLevel -> msg -> IO ()
logFun :: Loc -> LogLevel -> msg -> IO ()
logFun Loc
_ LogLevel
LogNone msg
_ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
logFun loc :: Loc
loc@(Loc String
_ String
pkg String
_ CharPos
_ CharPos
_) LogLevel
level msg
msg = do
  LogLevel
minLevel <- IORef LogLevel -> IO LogLevel
forall a. IORef a -> IO a
readIORef IORef LogLevel
minLogLevel
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LogLevel
level LogLevel -> LogLevel -> Bool
forall a. Ord a => a -> a -> Bool
>= LogLevel
minLevel) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    FormattedTime
now <- IO (IO FormattedTime) -> IO FormattedTime
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IORef (IO FormattedTime) -> IO (IO FormattedTime)
forall a. IORef a -> IO a
readIORef IORef (IO FormattedTime)
cachedTime)
    IORef (Map String LoggerSet) -> IO (Map String LoggerSet)
forall a. IORef a -> IO a
readIORef IORef (Map String LoggerSet)
loggerSets IO (Map String LoggerSet)
-> (Map String LoggerSet -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Map String LoggerSet
sets ->
      case Map String LoggerSet -> Maybe LoggerSet
forall a. Map String a -> Maybe a
getLogger Map String LoggerSet
sets of
        Maybe LoggerSet
Nothing -- Check the package name of the caller, as otherwise any library logging would halt the process.
          | Map String LoggerSet -> Bool
forall k a. Map k a -> Bool
M.null Map String LoggerSet
sets Bool -> Bool -> Bool
&& String
pkg String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
mainLogPkgName -> String -> IO ()
forall a. HasCallStack => String -> a
error String
"You must call `initLogger` at the start of your application! See the documentation of `EasyLogger.Logger`."
        Maybe LoggerSet
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just LoggerSet
set -> LoggerSet -> LogStr -> IO ()
pushLogStr LoggerSet
set (Loc -> FormattedTime -> LogLevel -> LogStr -> LogStr
defaultLogStr Loc
loc FormattedTime
now LogLevel
level (msg -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr msg
msg))
  where
    getLogger :: Map String a -> Maybe a
getLogger Map String a
sets = String -> Map String a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
pkg Map String a
sets Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> Map String a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
defaultLogPkgName Map String a
sets


cachedTime :: IORef (IO FormattedTime)
cachedTime :: IORef (IO FormattedTime)
cachedTime = IO (IORef (IO FormattedTime)) -> IORef (IO FormattedTime)
forall a. IO a -> a
unsafePerformIO (IO (IORef (IO FormattedTime)) -> IORef (IO FormattedTime))
-> IO (IORef (IO FormattedTime)) -> IORef (IO FormattedTime)
forall a b. (a -> b) -> a -> b
$ do
  IO FormattedTime
cache <- FormattedTime -> IO (IO FormattedTime)
newTimeCache FormattedTime
simpleTimeFormat'
  IO FormattedTime -> IO (IORef (IO FormattedTime))
forall a. a -> IO (IORef a)
newIORef IO FormattedTime
cache

minLogLevel :: IORef LogLevel
minLogLevel :: IORef LogLevel
minLogLevel = IO (IORef LogLevel) -> IORef LogLevel
forall a. IO a -> a
unsafePerformIO (IO (IORef LogLevel) -> IORef LogLevel)
-> IO (IORef LogLevel) -> IORef LogLevel
forall a b. (a -> b) -> a -> b
$ LogLevel -> IO (IORef LogLevel)
forall a. a -> IO (IORef a)
newIORef LogLevel
LogAll
{-# NOINLINE minLogLevel  #-}

-- | Set the least logging level. Levels lower will not be logged. Log Level Order: `Debug` < `Info` < `Warning` < `Error`. `None` disables all logging. Note that the output to stderr using e.g. `logPrintError` will not
-- be affected!
setMinLogLevel :: LogLevel -> IO ()
setMinLogLevel :: LogLevel -> IO ()
setMinLogLevel = IORef LogLevel -> LogLevel -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef LogLevel
minLogLevel

------------------------------ All ------------------------------

-- | Generates a function that takes a 'Text' and logs a 'LevelAll' message. Usage:
--
-- > $(logAll) "This is a debug log message"
logAll :: Q Exp
logAll :: Q Exp
logAll = [| liftIO . logFun $(qLocation >>= liftLoc) LogAll |]

-- | Same as `logAll`, but for pure code. Uses @unsafePerformIO@.
--
-- > $(pureLogAll) "This is a debug log message" (3 * 3)
pureLogAll :: Q Exp
pureLogAll :: Q Exp
pureLogAll = [| \txt a -> unsafePerformIO (logFun $(qLocation >>= liftLoc) LogAll txt >> return a) |]


-- | Same as `logAll`, but also prints the message on `stdout`.
logPrintAll :: Q Exp
logPrintAll :: Q Exp
logPrintAll = [| \txt -> liftIO (hPutStrLn stdout ("DEBUG: " ++ T.unpack txt) >> hFlush stdout >> logFun $(qLocation >>= liftLoc) LogAll txt) |]

-- | Same as `pureLogAll`, but also prints the message on `stdout`.
--
-- > $(pureLogPrintAll) "This is a debug log message" (3 * 3)
pureLogPrintAll :: Q Exp
pureLogPrintAll :: Q Exp
pureLogPrintAll = [| \txt a -> unsafePerformIO (hPutStrLn stdout ("DEBUG: " ++ T.unpack txt) >> hFlush stdout >> logFun $(qLocation >>= liftLoc) LogAll txt >> return a) |]


------------------------------ Debug ------------------------------

-- | Generates a function that takes a 'Text' and logs a 'LevelDebug' message. Usage:
--
-- > $(logDebug) "This is a debug log message"
logDebug :: Q Exp
logDebug :: Q Exp
logDebug = [| liftIO . logFun $(qLocation >>= liftLoc) LogDebug |]

-- | Same as `logDebug`, but for pure code. Uses @unsafePerformIO@
--
-- > $(pureLogDebug) "This is a debug log message" defaultValue
pureLogDebug :: Q Exp
pureLogDebug :: Q Exp
pureLogDebug = [| \txt a -> unsafePerformIO (logFun $(qLocation >>= liftLoc) LogDebug txt >> return a) |]


-- | Same as `logDebug`, but also prints the message on `stdout`.
logPrintDebug :: Q Exp
logPrintDebug :: Q Exp
logPrintDebug = [| \txt -> hPutStrLn stdout ("DEBUG: " ++ T.unpack txt) >> hFlush stdout >> logFun $(qLocation >>= liftLoc) LogDebug txt |]

-- | Same as `pureLogDebug`, but also prints the message on `stdout`.
--
-- > $(purePrintLogDebug) "This is a debug log message" defaultValue
pureLogPrintDebug :: Q Exp
pureLogPrintDebug :: Q Exp
pureLogPrintDebug = [| \txt a -> unsafePerformIO (hPutStrLn stdout ("DEBUG: " ++ T.unpack txt) >> hFlush stdout >> logFun $(qLocation >>= liftLoc) LogDebug txt >> return a) |]


------------------------------ Info ------------------------------

-- | Generates a function that takes a 'Text' and logs a 'LevelInfo' message. Usage:
--
-- > $(logInfo) "This is a info log message"
logInfo :: Q Exp
logInfo :: Q Exp
logInfo = [| liftIO . logFun $(qLocation >>= liftLoc) LogInfo |]

-- | Same as `logInfo`, but for pure code. Uses @unsafePerformIO@.
--
-- > $(pureLogInfo) "This is a warning log message" (funcX 10)
pureLogInfo :: Q Exp
pureLogInfo :: Q Exp
pureLogInfo = [| \txt a -> unsafePerformIO (logFun $(qLocation >>= liftLoc) LogInfo txt >> return a) |]


-- | Same as `logInfo`, but also prints the message on `stdout`.
logPrintInfo :: Q Exp
logPrintInfo :: Q Exp
logPrintInfo = [| \txt -> liftIO (hPutStrLn stdout ("INFO: " ++ T.unpack txt) >> hFlush stdout >> logFun $(qLocation >>= liftLoc) LogInfo txt) |]

-- | Same as `pureLogInfo`, but also prints the message on `stdout`.
--
-- > $(pureLogPrintInfo) "This is a warning log message" (funcX 10)
pureLogPrintInfo :: Q Exp
pureLogPrintInfo :: Q Exp
pureLogPrintInfo = [| \txt a -> unsafePerformIO (hPutStrLn stdout ("INFO: " ++ T.unpack txt) >> hFlush stdout >> logFun $(qLocation >>= liftLoc) LogInfo txt >> return a) |]


------------------------------ Warning ------------------------------

-- | Generates a function that takes a 'Text' and logs a 'LevelWarning' message. Usage:
--
-- > $(logWarning) "This is a warning log message"
logWarning :: Q Exp
logWarning :: Q Exp
logWarning = [| liftIO . logFun $(qLocation >>= liftLoc) LogWarning |]

-- | Same as `logWarning`, but for pure code. Uses @unsafePerformIO@.
--
-- > $(pureLogWarning) "This is a warning log message" "myresult"
pureLogWarning :: Q Exp
pureLogWarning :: Q Exp
pureLogWarning = [| \txt a -> unsafePerformIO (logFun $(qLocation >>= liftLoc) LogWarning txt >> return a) |]


-- | Same as `logWarning`, but also prints the message on `stdout`.
logPrintWarning :: Q Exp
logPrintWarning :: Q Exp
logPrintWarning = [| \txt -> liftIO (hPutStrLn stdout ("WARNING: " ++ T.unpack txt) >> hFlush stdout >> logFun $(qLocation >>= liftLoc) LogWarning txt) |]


-- | Same as `pureLogWarning`, but also prints the warning.
--
-- > $(pureLogPrintWarning) "This is a error log message" (4 + 4)
pureLogPrintWarning :: Q Exp
pureLogPrintWarning :: Q Exp
pureLogPrintWarning = [| \txt a -> unsafePerformIO (hPutStrLn stdout ("WARNING: " ++ T.unpack txt) >> hFlush stdout >> logFun $(qLocation >>= liftLoc) LogWarning txt >> return a)  |]


------------------------------ Error ------------------------------

-- | Generates a function that takes a 'Text' and logs a 'LevelError' message. Usage:
--
-- > $(logError) "This is a error log message"
logError :: Q Exp
logError :: Q Exp
logError = [| liftIO . logFun $(qLocation >>= liftLoc) LogError |]


-- | Same as `logError`, but for pure code. Uses @unsafePerformIO@.
--
-- > $(pureLogError) "This is a error log message" (4 + 4)
pureLogError :: Q Exp
pureLogError :: Q Exp
pureLogError = [| \txt a -> unsafePerformIO (logFun $(qLocation >>= liftLoc) LogError txt >> return a) |]


-- | Same as `logError`, but also prints the message on `stderr`.
logPrintError :: Q Exp
logPrintError :: Q Exp
logPrintError = [| \txt -> liftIO (hPutStrLn stderr ("ERROR: " ++ T.unpack txt) >> hFlush stderr >> logFun $(qLocation >>= liftLoc) LogError txt) |]


-- | Same as `pureLogError`, but also prints the message on `stderr`.
--
-- > $(pureLogPrintError) "This is a error log message" (4 + 4)
pureLogPrintError :: Q Exp
pureLogPrintError :: Q Exp
pureLogPrintError = [| \txt a -> unsafePerformIO (hPutStrLn stderr ("ERROR: " ++ T.unpack txt) >> hFlush stderr >> logFun $(qLocation >>= liftLoc) LogError txt >> return a) |]


---- Helpers:

defaultLogStr :: Loc
              -> FormattedTime
              -> LogLevel
              -> LogStr
              -> LogStr
defaultLogStr :: Loc -> FormattedTime -> LogLevel -> LogStr -> LogStr
defaultLogStr Loc
loc FormattedTime
time LogLevel
level LogStr
msg =
  LogStr
"[" LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> Text -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (LogLevel -> Text
logLevelText LogLevel
level) LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> (LogStr
"#" LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> FormattedTime -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr FormattedTime
time) LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
"] " LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr -> LogStr
mkTrailWs LogStr
msg LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
" @(" LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> FormattedTime -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (String -> FormattedTime
S8.pack String
fileLocStr) LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
")\n"
  where
    mkTrailWs :: LogStr -> LogStr
mkTrailWs = Int -> LogStr -> LogStr
mkMinLogStrLen Int
defaultMinLogMsgLen
    fileLocStr :: String
fileLocStr = Loc -> String
loc_package Loc
loc String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
':' Char -> ShowS
forall a. a -> [a] -> [a]
: Loc -> String
loc_module Loc
loc String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
' ' Char -> ShowS
forall a. a -> [a] -> [a]
: Loc -> String
loc_filename Loc
loc String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
':' Char -> ShowS
forall a. a -> [a] -> [a]
: Loc -> String
line Loc
loc String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
':' Char -> ShowS
forall a. a -> [a] -> [a]
: Loc -> String
char Loc
loc String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
'-' Char -> ShowS
forall a. a -> [a] -> [a]
: Loc -> String
lineEnd Loc
loc String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
':' Char -> ShowS
forall a. a -> [a] -> [a]
: Loc -> String
charEnd Loc
loc
    line :: Loc -> String
line = Int -> String
forall a. Show a => a -> String
show (Int -> String) -> (Loc -> Int) -> Loc -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CharPos -> Int
forall a b. (a, b) -> a
fst (CharPos -> Int) -> (Loc -> CharPos) -> Loc -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Loc -> CharPos
loc_start
    char :: Loc -> String
char = Int -> String
forall a. Show a => a -> String
show (Int -> String) -> (Loc -> Int) -> Loc -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CharPos -> Int
forall a b. (a, b) -> b
snd (CharPos -> Int) -> (Loc -> CharPos) -> Loc -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Loc -> CharPos
loc_start
    lineEnd :: Loc -> String
lineEnd = Int -> String
forall a. Show a => a -> String
show (Int -> String) -> (Loc -> Int) -> Loc -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CharPos -> Int
forall a b. (a, b) -> a
fst (CharPos -> Int) -> (Loc -> CharPos) -> Loc -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Loc -> CharPos
loc_end
    charEnd :: Loc -> String
charEnd = Int -> String
forall a. Show a => a -> String
show (Int -> String) -> (Loc -> Int) -> Loc -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CharPos -> Int
forall a b. (a, b) -> b
snd (CharPos -> Int) -> (Loc -> CharPos) -> Loc -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Loc -> CharPos
loc_end


defaultMinLogMsgLen :: Int
defaultMinLogMsgLen :: Int
defaultMinLogMsgLen = Int
60