{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}

-- |
-- Module      :  ELynx.Tools.Logger
-- Description :  Monad logger utility functions
-- Copyright   :  (c) Dominik Schrempf 2021
-- License     :  GPL-3.0-or-later
--
-- Maintainer  :  dominik.schrempf@gmail.com
-- Stability   :  unstable
-- Portability :  portable
--
-- Creation date: Fri Sep  6 14:43:19 2019.
module ELynx.Tools.Logger
  ( -- * 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

-- | Unified way of creating a new section in the log.
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

-- | The 'ReaderT' and 'LoggingT' wrapper for ELynx. Prints a header and a
-- footer, logs to 'stderr' if no file is provided. Initializes the seed if none
-- is provided. If a log file is provided, log to the file and to 'stderr'.
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
  -- Arguments.
  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
    -- Header.
    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"
    -- Fix seed.
    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
        -- XXX: Have to go via a generator here, since creation of seed is not
        -- supported.
        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'
    -- Run the worker with the fixed seed.
    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'
    -- Reproduction file.
    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'
    -- Footer.
    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