Logger.hs

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

-- |
-- Module      :  ELynx.Tools.Logger
-- Description :  Monad logger utility functions
-- Copyright   :  (c) Dominik Schrempf 2020
-- 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
  ( MonadIO,
    liftIO,
  )
import Control.Monad.Logger
  ( Loc,
    LogLevel,
    LogSource,
    LoggingT,
    MonadLogger,
    filterLogger,
    logInfo,
    runLoggingT,
  )
import Control.Monad.Trans.Control (MonadBaseControl)
import Control.Monad.Trans.Reader (ReaderT (runReaderT))
import qualified Data.ByteString.Char8 as B
import Data.Text
  ( Text,
    pack,
  )
import ELynx.Tools.InputOutput (openFile')
import ELynx.Tools.Reproduction
  ( Arguments (..),
    ELynx,
    Force,
    GlobalArguments (..),
    Reproducible (..),
    Seed (..),
    ToJSON,
    logFooter,
    logHeader,
    toLogLevel,
    writeReproduction,
  )
import System.IO
  ( BufferMode (LineBuffering),
    Handle,
    IOMode (WriteMode),
    hClose,
    hSetBuffering,
    stderr,
  )
import System.Log.FastLogger
  ( LogStr,
    fromLogStr,
  )
import System.Random.MWC
  ( createSystemRandom,
    fromSeed,
    save,
  )

-- | Unified way of creating a new section in the log.
logNewSection :: MonadLogger m => Text -> m ()
logNewSection s = $(logInfo) $ "== " <> 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 args f worker = do
  -- Arguments.
  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
    -- Header.
    h <- liftIO $ logHeader (cmdName @a) (cmdDsc @a)
    $(logInfo) $ pack $ h ++ "\n"
    -- Fix seed.
    lArgs' <- case getSeed lArgs of
      Nothing -> return lArgs
      Just Random -> do
        -- XXX: Have to go via a generator here, since creation of seed is not
        -- supported.
        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'
    -- Run the worker with the fixed seed.
    runReaderT worker $ f args'
    -- Reproduction file.
    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'
    -- Footer.
    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 = B.hPutStrLn h ls where ls = fromLogStr msg

output2H :: Handle -> Handle -> Loc -> LogSource -> LogLevel -> LogStr -> IO ()
output2H h1 h2 _ _ _ msg = do
  B.hPutStrLn h1 ls
  B.hPutStrLn h2 ls
  where
    ls = fromLogStr msg