{-# 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 :: Text -> m ()
logNewSection Text
s = $(Int
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> m ()
(Text -> m ()) -> (Text -> Text) -> Text -> m ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: String -> Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
logInfo) (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"== " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
s
eLynxWrapper ::
forall a b.
(Eq a, Show a, Reproducible a, ToJSON a) =>
Arguments a ->
(Arguments a -> Arguments b) ->
ELynx b () ->
IO ()
eLynxWrapper :: Arguments a -> (Arguments a -> Arguments b) -> ELynx b () -> IO ()
eLynxWrapper Arguments a
args Arguments a -> Arguments b
f ELynx b ()
worker = do
let gArgs :: GlobalArguments
gArgs = Arguments a -> GlobalArguments
forall a. Arguments a -> GlobalArguments
global Arguments a
args
lArgs :: a
lArgs = Arguments a -> a
forall a. Arguments a -> a
local Arguments a
args
let lvl :: LogLevel
lvl = Verbosity -> LogLevel
toLogLevel (Verbosity -> LogLevel) -> Verbosity -> LogLevel
forall a b. (a -> b) -> a -> b
$ GlobalArguments -> Verbosity
verbosity GlobalArguments
gArgs
rd :: Force
rd = GlobalArguments -> Force
forceReanalysis GlobalArguments
gArgs
outBn :: Maybe String
outBn = GlobalArguments -> Maybe String
outFileBaseName GlobalArguments
gArgs
logFile :: Maybe String
logFile = (String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".log") (String -> String) -> Maybe String -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
outBn
LogLevel -> Force -> Maybe String -> LoggingT IO () -> IO ()
forall (m :: * -> *) a.
(MonadBaseControl IO m, MonadIO m) =>
LogLevel -> Force -> Maybe String -> LoggingT m a -> m a
runELynxLoggingT LogLevel
lvl Force
rd Maybe String
logFile (LoggingT IO () -> IO ()) -> LoggingT IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
String
h <- IO String -> LoggingT IO String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> LoggingT IO String)
-> IO String -> LoggingT IO String
forall a b. (a -> b) -> a -> b
$ String -> [String] -> IO String
logHeader (Reproducible a => String
forall a. Reproducible a => String
cmdName @a) (Reproducible a => [String]
forall a. Reproducible a => [String]
cmdDsc @a)
$(Int
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> LoggingT IO ()
(Text -> LoggingT IO ())
-> (Text -> Text) -> Text -> LoggingT IO ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: String -> Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
logInfo) (Text -> LoggingT IO ()) -> Text -> LoggingT IO ()
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
h String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
a
lArgs' <- case a -> Maybe Seed
forall a. Reproducible a => a -> Maybe Seed
getSeed a
lArgs of
Maybe Seed
Nothing -> a -> LoggingT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
lArgs
Just Seed
Random -> do
Gen RealWorld
g <- IO (Gen RealWorld) -> LoggingT IO (Gen RealWorld)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Gen RealWorld)
IO GenIO
createSystemRandom
Vector Word32
s <- IO (Vector Word32) -> LoggingT IO (Vector Word32)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Vector Word32) -> LoggingT IO (Vector Word32))
-> IO (Vector Word32) -> LoggingT IO (Vector Word32)
forall a b. (a -> b) -> a -> b
$ Seed -> Vector Word32
fromSeed (Seed -> Vector Word32) -> IO Seed -> IO (Vector Word32)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenIO -> IO Seed
forall (m :: * -> *). PrimMonad m => Gen (PrimState m) -> m Seed
save Gen RealWorld
GenIO
g
$(Int
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> LoggingT IO ()
(Text -> LoggingT IO ())
-> (Text -> Text) -> Text -> LoggingT IO ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: String -> Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
logInfo) (Text -> LoggingT IO ()) -> Text -> LoggingT IO ()
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"Seed: random; set to " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Vector Word32 -> String
forall a. Show a => a -> String
show Vector Word32
s String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"."
a -> LoggingT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> LoggingT IO a) -> a -> LoggingT IO a
forall a b. (a -> b) -> a -> b
$ a -> Vector Word32 -> a
forall a. Reproducible a => a -> Vector Word32 -> a
setSeed a
lArgs Vector Word32
s
Just (Fixed Vector Word32
s) -> do
$(Int
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> LoggingT IO ()
(Text -> LoggingT IO ())
-> (Text -> Text) -> Text -> LoggingT IO ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: String -> Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
logInfo) (Text -> LoggingT IO ()) -> Text -> LoggingT IO ()
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"Seed: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Vector Word32 -> String
forall a. Show a => a -> String
show Vector Word32
s String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"."
a -> LoggingT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
lArgs
let args' :: Arguments a
args' = GlobalArguments -> a -> Arguments a
forall a. GlobalArguments -> a -> Arguments a
Arguments GlobalArguments
gArgs a
lArgs'
ELynx b () -> Arguments b -> LoggingT IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ELynx b ()
worker (Arguments b -> LoggingT IO ()) -> Arguments b -> LoggingT IO ()
forall a b. (a -> b) -> a -> b
$ Arguments a -> Arguments b
f Arguments a
args'
case (GlobalArguments -> Bool
writeElynxFile GlobalArguments
gArgs, Maybe String
outBn) of
(Bool
False, Maybe String
_) ->
$(Int
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> LoggingT IO ()
(Text -> LoggingT IO ())
-> (Text -> Text) -> Text -> LoggingT IO ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: String -> Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
logInfo)
Text
"No elynx file option --- skip writing ELynx file for reproducible runs."
(Bool
True, Maybe String
Nothing) ->
$(Int
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> LoggingT IO ()
(Text -> LoggingT IO ())
-> (Text -> Text) -> Text -> LoggingT IO ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: String -> Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
logInfo)
Text
"No output file given --- skip writing ELynx file for reproducible runs."
(Bool
True, Just String
bn) -> do
$(Int
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> LoggingT IO ()
(Text -> LoggingT IO ())
-> (Text -> Text) -> Text -> LoggingT IO ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: String -> Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
logInfo) Text
"Write ELynx reproduction file."
IO () -> LoggingT IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> LoggingT IO ()) -> IO () -> LoggingT IO ()
forall a b. (a -> b) -> a -> b
$ String -> Arguments a -> IO ()
forall a.
(Eq a, Show a, Reproducible a, ToJSON a) =>
String -> a -> IO ()
writeReproduction String
bn Arguments a
args'
String
ftr <- IO String -> LoggingT IO String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO String
logFooter
$(Int
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> LoggingT IO ()
(Text -> LoggingT IO ())
-> (Text -> Text) -> Text -> LoggingT IO ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: String -> Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
logInfo) (Text -> LoggingT IO ()) -> Text -> LoggingT IO ()
forall a b. (a -> b) -> a -> b
$ String -> Text
pack String
ftr
runELynxLoggingT ::
(MonadBaseControl IO m, MonadIO m) =>
LogLevel ->
Force ->
Maybe FilePath ->
LoggingT m a ->
m a
runELynxLoggingT :: LogLevel -> Force -> Maybe String -> LoggingT m a -> m a
runELynxLoggingT LogLevel
lvl Force
_ Maybe String
Nothing =
LoggingT m a -> m a
forall (m :: * -> *) a. MonadIO m => LoggingT m a -> m a
runELynxStderrLoggingT (LoggingT m a -> m a)
-> (LoggingT m a -> LoggingT m a) -> LoggingT m a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> LogLevel -> Bool) -> LoggingT m a -> LoggingT m a
forall (m :: * -> *) a.
(Text -> LogLevel -> Bool) -> LoggingT m a -> LoggingT m a
filterLogger (\Text
_ LogLevel
l -> LogLevel
l LogLevel -> LogLevel -> Bool
forall a. Ord a => a -> a -> Bool
>= LogLevel
lvl)
runELynxLoggingT LogLevel
lvl Force
frc (Just String
fn) =
Force -> String -> LoggingT m a -> m a
forall (m :: * -> *) a.
MonadBaseControl IO m =>
Force -> String -> LoggingT m a -> m a
runELynxFileLoggingT Force
frc String
fn (LoggingT m a -> m a)
-> (LoggingT m a -> LoggingT m a) -> LoggingT m a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> LogLevel -> Bool) -> LoggingT m a -> LoggingT m a
forall (m :: * -> *) a.
(Text -> LogLevel -> Bool) -> LoggingT m a -> LoggingT m a
filterLogger (\Text
_ LogLevel
l -> LogLevel
l LogLevel -> LogLevel -> Bool
forall a. Ord a => a -> a -> Bool
>= LogLevel
lvl)
runELynxFileLoggingT ::
MonadBaseControl IO m => Force -> FilePath -> LoggingT m a -> m a
runELynxFileLoggingT :: Force -> String -> LoggingT m a -> m a
runELynxFileLoggingT Force
frc String
fp LoggingT m a
logger = do
Handle
h <- IO Handle -> m Handle
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO Handle -> m Handle) -> IO Handle -> m Handle
forall a b. (a -> b) -> a -> b
$ Force -> String -> IOMode -> IO Handle
openFile' Force
frc String
fp IOMode
WriteMode
IO () -> m ()
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (Handle -> BufferMode -> IO ()
hSetBuffering Handle
h BufferMode
LineBuffering)
a
r <- LoggingT m a -> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> m a
forall (m :: * -> *) a.
LoggingT m a -> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> m a
runLoggingT LoggingT m a
logger (Handle -> Handle -> Loc -> Text -> LogLevel -> LogStr -> IO ()
output2H Handle
stderr Handle
h)
IO () -> m ()
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (Handle -> IO ()
hClose Handle
h)
a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r
runELynxStderrLoggingT :: MonadIO m => LoggingT m a -> m a
runELynxStderrLoggingT :: LoggingT m a -> m a
runELynxStderrLoggingT = (LoggingT m a -> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> m a
forall (m :: * -> *) a.
LoggingT m a -> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> m a
`runLoggingT` Handle -> Loc -> Text -> LogLevel -> LogStr -> IO ()
output Handle
stderr)
output :: Handle -> Loc -> LogSource -> LogLevel -> LogStr -> IO ()
output :: Handle -> Loc -> Text -> LogLevel -> LogStr -> IO ()
output Handle
h Loc
_ Text
_ LogLevel
_ LogStr
msg = Handle -> ByteString -> IO ()
BS.hPutStrLn Handle
h ByteString
ls where ls :: ByteString
ls = LogStr -> ByteString
fromLogStr LogStr
msg
output2H :: Handle -> Handle -> Loc -> LogSource -> LogLevel -> LogStr -> IO ()
output2H :: Handle -> Handle -> Loc -> Text -> LogLevel -> LogStr -> IO ()
output2H Handle
h1 Handle
h2 Loc
_ Text
_ LogLevel
_ LogStr
msg = do
Handle -> ByteString -> IO ()
BS.hPutStrLn Handle
h1 ByteString
ls
Handle -> ByteString -> IO ()
BS.hPutStrLn Handle
h2 ByteString
ls
where
ls :: ByteString
ls = LogStr -> ByteString
fromLogStr LogStr
msg