{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
module ELynx.Tools.Logger
(
logNewSection,
eLynxWrapper,
)
where
import Control.Monad.Base (liftBase)
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Trans.Control (MonadBaseControl)
import Control.Monad.Trans.Reader (ReaderT (runReaderT))
import qualified Data.ByteString.Char8 as BS
import Data.Text
import ELynx.Tools.InputOutput (openFile')
import ELynx.Tools.Reproduction
import System.IO
import System.Random.MWC
logNewSection :: MonadLogger m => Text -> m ()
logNewSection s = $(logInfo) $ "== " <> s
eLynxWrapper ::
forall a b.
(Eq a, Show a, Reproducible a, ToJSON a) =>
Arguments a ->
(Arguments a -> Arguments b) ->
ELynx b () ->
IO ()
eLynxWrapper args f worker = do
let gArgs = global args
lArgs = local args
let lvl = toLogLevel $ verbosity gArgs
rd = forceReanalysis gArgs
outBn = outFileBaseName gArgs
logFile = (++ ".log") <$> outBn
runELynxLoggingT lvl rd logFile $ do
h <- liftIO $ logHeader (cmdName @a) (cmdDsc @a)
$(logInfo) $ pack $ h ++ "\n"
lArgs' <- case getSeed lArgs of
Nothing -> return lArgs
Just Random -> do
g <- liftIO createSystemRandom
s <- liftIO $ fromSeed <$> save g
$(logInfo) $ pack $ "Seed: random; set to " <> show s <> "."
return $ setSeed lArgs s
Just (Fixed s) -> do
$(logInfo) $ pack $ "Seed: " <> show s <> "."
return lArgs
let args' = Arguments gArgs lArgs'
runReaderT worker $ f args'
case outBn of
Nothing ->
$(logInfo)
"No output file given --- skip writing ELynx file for reproducible runs."
Just bn -> do
$(logInfo) "Write ELynx reproduction file."
liftIO $ writeReproduction bn args'
ftr <- liftIO logFooter
$(logInfo) $ pack ftr
runELynxLoggingT ::
(MonadBaseControl IO m, MonadIO m) =>
LogLevel ->
Force ->
Maybe FilePath ->
LoggingT m a ->
m a
runELynxLoggingT lvl _ Nothing =
runELynxStderrLoggingT . filterLogger (\_ l -> l >= lvl)
runELynxLoggingT lvl frc (Just fn) =
runELynxFileLoggingT frc fn . filterLogger (\_ l -> l >= lvl)
runELynxFileLoggingT ::
MonadBaseControl IO m => Force -> FilePath -> LoggingT m a -> m a
runELynxFileLoggingT frc fp logger = do
h <- liftBase $ openFile' frc fp WriteMode
liftBase (hSetBuffering h LineBuffering)
r <- runLoggingT logger (output2H stderr h)
liftBase (hClose h)
return r
runELynxStderrLoggingT :: MonadIO m => LoggingT m a -> m a
runELynxStderrLoggingT = (`runLoggingT` output stderr)
output :: Handle -> Loc -> LogSource -> LogLevel -> LogStr -> IO ()
output h _ _ _ msg = BS.hPutStrLn h ls where ls = fromLogStr msg
output2H :: Handle -> Handle -> Loc -> LogSource -> LogLevel -> LogStr -> IO ()
output2H h1 h2 _ _ _ msg = do
BS.hPutStrLn h1 ls
BS.hPutStrLn h2 ls
where
ls = fromLogStr msg