{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module ELynx.Tools.Logger
( logNewSection
, eLynxWrapper
) where
import Control.Exception.Lifted
import Control.Monad.Base
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Trans.Control
import qualified Data.ByteString.Char8 as B
import Data.Text
import System.IO
import System.Log.FastLogger
import ELynx.Tools.Options
logNewSection :: MonadLogger m => Text -> m ()
logNewSection s = do
$(logInfo) ""
$(logInfo) $ "-- " <> s
eLynxWrapper :: (MonadBaseControl IO m, MonadIO m)
=> LogLevel -> Maybe FilePath -> String -> LoggingT m () -> m ()
eLynxWrapper lvl logFile headerMsg worker = runELynxLoggingT lvl logFile $
do
h <- liftIO $ logHeader headerMsg
$(logInfo) $ pack h
worker
f <- liftIO logFooter
$(logInfo) $ pack f
runELynxLoggingT :: (MonadBaseControl IO m, MonadIO m)
=> LogLevel -> Maybe FilePath -> LoggingT m a -> m a
runELynxLoggingT lvl f = case f of
Nothing -> runELynxStderrLoggingT . filterLogger (\_ l -> l >= lvl)
Just fn -> runELynxFileLoggingT fn . filterLogger (\_ l -> l >= lvl)
runELynxFileLoggingT :: MonadBaseControl IO m => FilePath -> LoggingT m a -> m a
runELynxFileLoggingT fp logger = bracket
(liftBase $ openFile fp AppendMode)
(liftBase . hClose)
$ \h -> liftBase (hSetBuffering h LineBuffering) >> runLoggingT logger (output2H stderr h)
runELynxStderrLoggingT :: MonadIO m => LoggingT m a -> m a
runELynxStderrLoggingT = (`runLoggingT` output stderr)
output :: Handle
-> Loc
-> LogSource
-> LogLevel
-> LogStr
-> IO ()
output h loc src lvl msg =
B.hPutStr h ls
where
ls = logStrToBS loc src lvl msg
output2H :: Handle
-> Handle
-> Loc
-> LogSource
-> LogLevel
-> LogStr
-> IO ()
output2H h1 h2 loc src lvl msg = do
B.hPutStr h1 ls
B.hPutStr h2 ls
where
ls = logStrToBS loc src lvl msg
logStrToBS :: Loc
-> LogSource
-> LogLevel
-> LogStr
-> B.ByteString
logStrToBS _ _ _ msg = fromLogStr msg <> "\n"