{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
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
data LogMode = LogStdOutAndFile | LogStdOutOnly | LogFileOnly
deriving (LogMode -> LogMode -> Bool
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]
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
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)
data Verbosity = Quiet | Warn | Info | Debug
deriving (Verbosity -> Verbosity -> Bool
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
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
Ord, ReadPrec [Verbosity]
ReadPrec Verbosity
Int -> ReadS Verbosity
ReadS [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
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)
class HasLock e where
getLock :: e -> MVar ()
class HasLogHandles e where
getLogHandles :: e -> [Handle]
class HasStartingTime s where
getStartingTime :: s -> UTCTime
class HasLogMode s where
getLogMode :: s -> LogMode
class HasVerbosity s where
getVerbosity :: s -> Verbosity
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" forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> ByteString -> ByteString
BL.append ByteString
pref) forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
BL.lines ByteString
msg
atomicAction :: HasLock e => IO () -> Logger e ()
atomicAction :: forall e. HasLock e => IO () -> Logger e ()
atomicAction IO ()
a = do
MVar ()
l <- forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
reader forall e. HasLock e => e -> MVar ()
getLock
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
l (forall a b. a -> b -> a
const IO ()
a)
logOutB ::
(HasLogHandles e, HasLock e) =>
BL.ByteString ->
BL.ByteString ->
Logger e ()
logOutB :: forall e.
(HasLogHandles e, HasLock e) =>
ByteString -> ByteString -> Logger e ()
logOutB ByteString
pref ByteString
msg = do
[Handle]
hs <- forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
reader forall e. HasLogHandles e => e -> [Handle]
getLogHandles
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall e. HasLock e => IO () -> Logger e ()
atomicAction 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
logDebugA :: (HasLock e, HasLogHandles e, HasVerbosity e) => Logger e () -> Logger e ()
logDebugA :: forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
Logger e () -> Logger e ()
logDebugA Logger e ()
a = forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
reader forall s. HasVerbosity s => s -> Verbosity
getVerbosity forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Verbosity
v -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
v forall a. Ord a => a -> a -> Bool
>= Verbosity
Debug) Logger e ()
a
logDebugB :: (HasLock e, HasLogHandles e, HasVerbosity e) => BL.ByteString -> Logger e ()
logDebugB :: forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logDebugB = forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
Logger e () -> Logger e ()
logDebugA forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e.
(HasLogHandles e, HasLock e) =>
ByteString -> ByteString -> Logger e ()
logOutB ByteString
"D: "
logDebugS :: (HasLock e, HasLogHandles e, HasVerbosity e) => String -> Logger e ()
logDebugS :: forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
String -> Logger e ()
logDebugS = forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logDebugB forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
BL.pack
logWarnA :: (HasLogHandles e, HasVerbosity e) => Logger e () -> Logger e ()
logWarnA :: forall e.
(HasLogHandles e, HasVerbosity e) =>
Logger e () -> Logger e ()
logWarnA Logger e ()
a = forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
reader forall s. HasVerbosity s => s -> Verbosity
getVerbosity forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Verbosity
v -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
v forall a. Ord a => a -> a -> Bool
>= Verbosity
Warn) Logger e ()
a
logWarnB :: (HasLock e, HasLogHandles e, HasVerbosity e) => BL.ByteString -> Logger e ()
logWarnB :: forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logWarnB = forall e.
(HasLogHandles e, HasVerbosity e) =>
Logger e () -> Logger e ()
logWarnA forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e.
(HasLogHandles e, HasLock e) =>
ByteString -> ByteString -> Logger e ()
logOutB ByteString
"W: "
logWarnS :: (HasLock e, HasLogHandles e, HasVerbosity e) => String -> Logger e ()
logWarnS :: forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
String -> Logger e ()
logWarnS = forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logWarnB forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
BL.pack
logInfoA :: (HasLogHandles e, HasVerbosity e) => Logger e () -> Logger e ()
logInfoA :: forall e.
(HasLogHandles e, HasVerbosity e) =>
Logger e () -> Logger e ()
logInfoA Logger e ()
a = forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
reader forall s. HasVerbosity s => s -> Verbosity
getVerbosity forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Verbosity
v -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
v forall a. Ord a => a -> a -> Bool
>= Verbosity
Info) Logger e ()
a
logInfoB :: (HasLock e, HasLogHandles e, HasVerbosity e) => BL.ByteString -> Logger e ()
logInfoB :: forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logInfoB = forall e.
(HasLogHandles e, HasVerbosity e) =>
Logger e () -> Logger e ()
logInfoA forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e.
(HasLogHandles e, HasLock e) =>
ByteString -> ByteString -> Logger e ()
logOutB ByteString
" "
logInfoS :: (HasLock e, HasLogHandles e, HasVerbosity e) => String -> Logger e ()
logInfoS :: forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
String -> Logger e ()
logInfoS = forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logInfoB forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
BL.pack
logInfoHeader :: (HasLock e, HasLogHandles e, HasVerbosity e) => Logger e ()
= do
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
String -> Logger e ()
logInfoS (forall a. Int -> a -> [a]
replicate Int
70 Char
'-')
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
String -> Logger e ()
logInfoS (String
"MCMC sampler; version " forall a. [a] -> [a] -> [a]
++ Version -> String
showVersion Version
version forall a. Semigroup a => a -> a -> a
<> String
".")
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
String -> Logger e ()
logInfoS String
"Developed by: Dominik Schrempf."
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
String -> Logger e ()
logInfoS String
"License: GPL-3.0-or-later."
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
String -> Logger e ()
logInfoS (forall a. Int -> a -> [a]
replicate Int
70 Char
'-')
logInfoStartingTime :: (HasLock e, HasLogHandles e, HasStartingTime e, HasVerbosity e) => Logger e ()
logInfoStartingTime :: forall e.
(HasLock e, HasLogHandles e, HasStartingTime e, HasVerbosity e) =>
Logger e ()
logInfoStartingTime = do
UTCTime
ti <- forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
reader forall s. HasStartingTime s => s -> UTCTime
getStartingTime
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
String -> Logger e ()
logInfoS forall a b. (a -> b) -> a -> b
$ String
"Starting time: " forall a. Semigroup a => a -> a -> a
<> forall t. FormatTime t => t -> String
renderTime UTCTime
ti
logInfoEndTime :: (HasLock e, HasLogHandles e, HasStartingTime e, HasVerbosity e) => Logger e ()
logInfoEndTime :: forall e.
(HasLock e, HasLogHandles e, HasStartingTime e, HasVerbosity e) =>
Logger e ()
logInfoEndTime = do
UTCTime
ti <- forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
reader forall s. HasStartingTime s => s -> UTCTime
getStartingTime
UTCTime
te <- 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
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logInfoB forall a b. (a -> b) -> a -> b
$ ByteString
"Wall clock run time: " forall a. Semigroup a => a -> a -> a
<> NominalDiffTime -> ByteString
renderDuration NominalDiffTime
dt forall a. Semigroup a => a -> a -> a
<> ByteString
"."
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
String -> Logger e ()
logInfoS forall a b. (a -> b) -> a -> b
$ String
"End time: " forall a. Semigroup a => a -> a -> a
<> forall t. FormatTime t => t -> String
renderTime UTCTime
te