{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}

-- |
-- Module      :  Mcmc.Logger
-- Description :  Minimal monad logger
-- Copyright   :  2021 Dominik Schrempf
-- License     :  GPL-3.0-or-later
--
-- Maintainer  :  dominik.schrempf@gmail.com
-- Stability   :  unstable
-- Portability :  portable
--
-- Creation date: Tue Jan 12 09:03:04 2021.
module Mcmc.Logger
  ( LogMode (..),
    Verbosity (..),
    HasLock (..),
    HasLogHandles (..),
    HasStartingTime (..),
    HasLogMode (..),
    HasVerbosity (..),
    Logger,
    logOutB,
    logDebugB,
    logDebugS,
    logWarnB,
    logWarnS,
    logInfoB,
    logInfoS,
    logInfoHeader,
    logInfoStartingTime,
    logInfoEndTime,
  )
where

import Control.Concurrent.MVar
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Reader
import Data.Aeson
import Data.Aeson.TH
import qualified Data.ByteString.Lazy.Char8 as BL
import Data.Time.Clock
import Data.Version (showVersion)
import Mcmc.Monitor.Time
import Paths_mcmc (version)
import System.IO

-- | Define where the log output should be directed to.
--
-- Logging is disabled if 'Verbosity' is set to 'Quiet'.
data LogMode = LogStdOutAndFile | LogStdOutOnly | LogFileOnly
  deriving (LogMode -> LogMode -> Bool
(LogMode -> LogMode -> Bool)
-> (LogMode -> LogMode -> Bool) -> Eq LogMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LogMode -> LogMode -> Bool
$c/= :: LogMode -> LogMode -> Bool
== :: LogMode -> LogMode -> Bool
$c== :: LogMode -> LogMode -> Bool
Eq, ReadPrec [LogMode]
ReadPrec LogMode
Int -> ReadS LogMode
ReadS [LogMode]
(Int -> ReadS LogMode)
-> ReadS [LogMode]
-> ReadPrec LogMode
-> ReadPrec [LogMode]
-> Read LogMode
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [LogMode]
$creadListPrec :: ReadPrec [LogMode]
readPrec :: ReadPrec LogMode
$creadPrec :: ReadPrec LogMode
readList :: ReadS [LogMode]
$creadList :: ReadS [LogMode]
readsPrec :: Int -> ReadS LogMode
$creadsPrec :: Int -> ReadS LogMode
Read, Int -> LogMode -> ShowS
[LogMode] -> ShowS
LogMode -> String
(Int -> LogMode -> ShowS)
-> (LogMode -> String) -> ([LogMode] -> ShowS) -> Show LogMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LogMode] -> ShowS
$cshowList :: [LogMode] -> ShowS
show :: LogMode -> String
$cshow :: LogMode -> String
showsPrec :: Int -> LogMode -> ShowS
$cshowsPrec :: Int -> LogMode -> ShowS
Show)

$(deriveJSON defaultOptions ''LogMode)

-- | Not much to say here.
data Verbosity = Quiet | Warn | Info | Debug
  deriving (Verbosity -> Verbosity -> Bool
(Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Bool) -> Eq Verbosity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Verbosity -> Verbosity -> Bool
$c/= :: Verbosity -> Verbosity -> Bool
== :: Verbosity -> Verbosity -> Bool
$c== :: Verbosity -> Verbosity -> Bool
Eq, Eq Verbosity
Eq Verbosity
-> (Verbosity -> Verbosity -> Ordering)
-> (Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Verbosity)
-> (Verbosity -> Verbosity -> Verbosity)
-> Ord Verbosity
Verbosity -> Verbosity -> Bool
Verbosity -> Verbosity -> Ordering
Verbosity -> Verbosity -> Verbosity
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Verbosity -> Verbosity -> Verbosity
$cmin :: Verbosity -> Verbosity -> Verbosity
max :: Verbosity -> Verbosity -> Verbosity
$cmax :: Verbosity -> Verbosity -> Verbosity
>= :: Verbosity -> Verbosity -> Bool
$c>= :: Verbosity -> Verbosity -> Bool
> :: Verbosity -> Verbosity -> Bool
$c> :: Verbosity -> Verbosity -> Bool
<= :: Verbosity -> Verbosity -> Bool
$c<= :: Verbosity -> Verbosity -> Bool
< :: Verbosity -> Verbosity -> Bool
$c< :: Verbosity -> Verbosity -> Bool
compare :: Verbosity -> Verbosity -> Ordering
$ccompare :: Verbosity -> Verbosity -> Ordering
$cp1Ord :: Eq Verbosity
Ord, ReadPrec [Verbosity]
ReadPrec Verbosity
Int -> ReadS Verbosity
ReadS [Verbosity]
(Int -> ReadS Verbosity)
-> ReadS [Verbosity]
-> ReadPrec Verbosity
-> ReadPrec [Verbosity]
-> Read Verbosity
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Verbosity]
$creadListPrec :: ReadPrec [Verbosity]
readPrec :: ReadPrec Verbosity
$creadPrec :: ReadPrec Verbosity
readList :: ReadS [Verbosity]
$creadList :: ReadS [Verbosity]
readsPrec :: Int -> ReadS Verbosity
$creadsPrec :: Int -> ReadS Verbosity
Read, Int -> Verbosity -> ShowS
[Verbosity] -> ShowS
Verbosity -> String
(Int -> Verbosity -> ShowS)
-> (Verbosity -> String)
-> ([Verbosity] -> ShowS)
-> Show Verbosity
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Verbosity] -> ShowS
$cshowList :: [Verbosity] -> ShowS
show :: Verbosity -> String
$cshow :: Verbosity -> String
showsPrec :: Int -> Verbosity -> ShowS
$cshowsPrec :: Int -> Verbosity -> ShowS
Show)

$(deriveJSON defaultOptions ''Verbosity)

-- | Types with an output lock for concurrent output.
class HasLock e where
  getLock :: e -> MVar ()

-- | Types with logging information.
class HasLogHandles e where
  getLogHandles :: e -> [Handle]

-- | Types with starting time.
class HasStartingTime s where
  getStartingTime :: s -> UTCTime

-- | Types with a log mode.
class HasLogMode s where
  getLogMode :: s -> LogMode

-- | Types with verbosity.
class HasVerbosity s where
  getVerbosity :: s -> Verbosity

-- | Reader transformer used for logging to a file and to standard output.
type Logger e a = ReaderT e IO a

msgPrepare :: BL.ByteString -> BL.ByteString -> BL.ByteString
msgPrepare :: ByteString -> ByteString -> ByteString
msgPrepare ByteString
pref ByteString
msg = ByteString -> [ByteString] -> ByteString
BL.intercalate ByteString
"\n" ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ (ByteString -> ByteString) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> ByteString -> ByteString
BL.append ByteString
pref) ([ByteString] -> [ByteString]) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
BL.lines ByteString
msg

-- Make sure that concurrent output is not scrambled.
atomicAction :: HasLock e => IO () -> Logger e ()
atomicAction :: IO () -> Logger e ()
atomicAction IO ()
a = do
  MVar ()
l <- (e -> MVar ()) -> ReaderT e IO (MVar ())
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
reader e -> MVar ()
forall e. HasLock e => e -> MVar ()
getLock
  IO () -> Logger e ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Logger e ()) -> IO () -> Logger e ()
forall a b. (a -> b) -> a -> b
$ MVar () -> (() -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
l (IO () -> () -> IO ()
forall a b. a -> b -> a
const IO ()
a)

-- | Write to standard output and maybe to log file.
logOutB ::
  (HasLogHandles e, HasLock e) =>
  -- | Prefix.
  BL.ByteString ->
  -- | Message.
  BL.ByteString ->
  Logger e ()
logOutB :: ByteString -> ByteString -> Logger e ()
logOutB ByteString
pref ByteString
msg = do
  [Handle]
hs <- (e -> [Handle]) -> ReaderT e IO [Handle]
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
reader e -> [Handle]
forall e. HasLogHandles e => e -> [Handle]
getLogHandles
  (Handle -> Logger e ()) -> [Handle] -> Logger e ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (IO () -> Logger e ()
forall e. HasLock e => IO () -> Logger e ()
atomicAction (IO () -> Logger e ())
-> (Handle -> IO ()) -> Handle -> Logger e ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Handle -> ByteString -> IO ()
`BL.hPutStrLn` ByteString
msg')) [Handle]
hs
  where
    msg' :: ByteString
msg' = ByteString -> ByteString -> ByteString
msgPrepare ByteString
pref ByteString
msg

-- Perform debug action.
logDebugA :: (HasLock e, HasLogHandles e, HasVerbosity e) => Logger e () -> Logger e ()
logDebugA :: Logger e () -> Logger e ()
logDebugA Logger e ()
a = (e -> Verbosity) -> ReaderT e IO Verbosity
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
reader e -> Verbosity
forall s. HasVerbosity s => s -> Verbosity
getVerbosity ReaderT e IO Verbosity -> (Verbosity -> Logger e ()) -> Logger e ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Verbosity
v -> Bool -> Logger e () -> Logger e ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
v Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
Debug) Logger e ()
a

-- | Log debug message.
logDebugB :: (HasLock e, HasLogHandles e, HasVerbosity e) => BL.ByteString -> Logger e ()
logDebugB :: ByteString -> Logger e ()
logDebugB = Logger e () -> Logger e ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
Logger e () -> Logger e ()
logDebugA (Logger e () -> Logger e ())
-> (ByteString -> Logger e ()) -> ByteString -> Logger e ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> Logger e ()
forall e.
(HasLogHandles e, HasLock e) =>
ByteString -> ByteString -> Logger e ()
logOutB ByteString
"D: "

-- | Log debug message.
logDebugS :: (HasLock e, HasLogHandles e, HasVerbosity e) => String -> Logger e ()
logDebugS :: String -> Logger e ()
logDebugS = ByteString -> Logger e ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logDebugB (ByteString -> Logger e ())
-> (String -> ByteString) -> String -> Logger e ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
BL.pack

-- Perform warning action.
logWarnA :: (HasLogHandles e, HasVerbosity e) => Logger e () -> Logger e ()
logWarnA :: Logger e () -> Logger e ()
logWarnA Logger e ()
a = (e -> Verbosity) -> ReaderT e IO Verbosity
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
reader e -> Verbosity
forall s. HasVerbosity s => s -> Verbosity
getVerbosity ReaderT e IO Verbosity -> (Verbosity -> Logger e ()) -> Logger e ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Verbosity
v -> Bool -> Logger e () -> Logger e ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
v Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
Warn) Logger e ()
a

-- | Log warning message.
logWarnB :: (HasLock e, HasLogHandles e, HasVerbosity e) => BL.ByteString -> Logger e ()
logWarnB :: ByteString -> Logger e ()
logWarnB = Logger e () -> Logger e ()
forall e.
(HasLogHandles e, HasVerbosity e) =>
Logger e () -> Logger e ()
logWarnA (Logger e () -> Logger e ())
-> (ByteString -> Logger e ()) -> ByteString -> Logger e ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> Logger e ()
forall e.
(HasLogHandles e, HasLock e) =>
ByteString -> ByteString -> Logger e ()
logOutB ByteString
"W: "

-- | Log warning message.
logWarnS :: (HasLock e, HasLogHandles e, HasVerbosity e) => String -> Logger e ()
logWarnS :: String -> Logger e ()
logWarnS = ByteString -> Logger e ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logWarnB (ByteString -> Logger e ())
-> (String -> ByteString) -> String -> Logger e ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
BL.pack

-- Perform info action.
logInfoA :: (HasLogHandles e, HasVerbosity e) => Logger e () -> Logger e ()
logInfoA :: Logger e () -> Logger e ()
logInfoA Logger e ()
a = (e -> Verbosity) -> ReaderT e IO Verbosity
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
reader e -> Verbosity
forall s. HasVerbosity s => s -> Verbosity
getVerbosity ReaderT e IO Verbosity -> (Verbosity -> Logger e ()) -> Logger e ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Verbosity
v -> Bool -> Logger e () -> Logger e ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
v Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
Info) Logger e ()
a

-- | Log info message.
logInfoB :: (HasLock e, HasLogHandles e, HasVerbosity e) => BL.ByteString -> Logger e ()
logInfoB :: ByteString -> Logger e ()
logInfoB = Logger e () -> Logger e ()
forall e.
(HasLogHandles e, HasVerbosity e) =>
Logger e () -> Logger e ()
logInfoA (Logger e () -> Logger e ())
-> (ByteString -> Logger e ()) -> ByteString -> Logger e ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> Logger e ()
forall e.
(HasLogHandles e, HasLock e) =>
ByteString -> ByteString -> Logger e ()
logOutB ByteString
"   "

-- | Log info message.
logInfoS :: (HasLock e, HasLogHandles e, HasVerbosity e) => String -> Logger e ()
logInfoS :: String -> Logger e ()
logInfoS = ByteString -> Logger e ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logInfoB (ByteString -> Logger e ())
-> (String -> ByteString) -> String -> Logger e ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
BL.pack

-- | Log info header.
logInfoHeader :: (HasLock e, HasLogHandles e, HasVerbosity e) => Logger e ()
logInfoHeader :: Logger e ()
logInfoHeader = do
  String -> Logger e ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
String -> Logger e ()
logInfoS (Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
70 Char
'-')
  String -> Logger e ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
String -> Logger e ()
logInfoS (String
"MCMC sampler; version " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Version -> String
showVersion Version
version String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
".")
  String -> Logger e ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
String -> Logger e ()
logInfoS String
"Developed by: Dominik Schrempf."
  String -> Logger e ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
String -> Logger e ()
logInfoS String
"License: GPL-3.0-or-later."
  String -> Logger e ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
String -> Logger e ()
logInfoS (Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
70 Char
'-')

-- | Log starting time.
logInfoStartingTime :: (HasLock e, HasLogHandles e, HasStartingTime e, HasVerbosity e) => Logger e ()
logInfoStartingTime :: Logger e ()
logInfoStartingTime = do
  UTCTime
ti <- (e -> UTCTime) -> ReaderT e IO UTCTime
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
reader e -> UTCTime
forall s. HasStartingTime s => s -> UTCTime
getStartingTime
  String -> Logger e ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
String -> Logger e ()
logInfoS (String -> Logger e ()) -> String -> Logger e ()
forall a b. (a -> b) -> a -> b
$ String
"Starting time: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> UTCTime -> String
forall t. FormatTime t => t -> String
renderTime UTCTime
ti

-- | Log end time.
logInfoEndTime :: (HasLock e, HasLogHandles e, HasStartingTime e, HasVerbosity e) => Logger e ()
logInfoEndTime :: Logger e ()
logInfoEndTime = do
  UTCTime
ti <- (e -> UTCTime) -> ReaderT e IO UTCTime
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
reader e -> UTCTime
forall s. HasStartingTime s => s -> UTCTime
getStartingTime
  UTCTime
te <- IO UTCTime -> ReaderT e IO UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
  let dt :: NominalDiffTime
dt = UTCTime
te UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` UTCTime
ti
  ByteString -> Logger e ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logInfoB (ByteString -> Logger e ()) -> ByteString -> Logger e ()
forall a b. (a -> b) -> a -> b
$ ByteString
"Wall clock run time: " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> NominalDiffTime -> ByteString
renderDuration NominalDiffTime
dt ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"."
  String -> Logger e ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
String -> Logger e ()
logInfoS (String -> Logger e ()) -> String -> Logger e ()
forall a b. (a -> b) -> a -> b
$ String
"End time: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> UTCTime -> String
forall t. FormatTime t => t -> String
renderTime UTCTime
te