{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
module ELynx.Tools.Logger
( Verbosity (..),
HasLock (..),
HasLogHandles (..),
HasStartingTime (..),
HasVerbosity (..),
Logger,
logOutB,
logDebugB,
logDebugS,
logWarnB,
logWarnS,
logInfoB,
logInfoS,
logHeader,
logInfoHeader,
logInfoFooter,
logInfoNewSection,
)
where
import Control.Concurrent.MVar
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Reader
import Data.Aeson.TH
import qualified Data.ByteString.Builder as BB
import qualified Data.ByteString.Lazy.Char8 as BL
import Data.List
import Data.Time
import Data.Version
import GHC.Generics
import Language.Haskell.TH
import Paths_elynx_tools
import System.Environment
import System.IO
data Verbosity = Quiet | Warn | Info | Debug
deriving (Verbosity
forall a. a -> a -> Bounded a
maxBound :: Verbosity
$cmaxBound :: Verbosity
minBound :: Verbosity
$cminBound :: Verbosity
Bounded, Int -> Verbosity
Verbosity -> Int
Verbosity -> [Verbosity]
Verbosity -> Verbosity
Verbosity -> Verbosity -> [Verbosity]
Verbosity -> Verbosity -> Verbosity -> [Verbosity]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Verbosity -> Verbosity -> Verbosity -> [Verbosity]
$cenumFromThenTo :: Verbosity -> Verbosity -> Verbosity -> [Verbosity]
enumFromTo :: Verbosity -> Verbosity -> [Verbosity]
$cenumFromTo :: Verbosity -> Verbosity -> [Verbosity]
enumFromThen :: Verbosity -> Verbosity -> [Verbosity]
$cenumFromThen :: Verbosity -> Verbosity -> [Verbosity]
enumFrom :: Verbosity -> [Verbosity]
$cenumFrom :: Verbosity -> [Verbosity]
fromEnum :: Verbosity -> Int
$cfromEnum :: Verbosity -> Int
toEnum :: Int -> Verbosity
$ctoEnum :: Int -> Verbosity
pred :: Verbosity -> Verbosity
$cpred :: Verbosity -> Verbosity
succ :: Verbosity -> Verbosity
$csucc :: Verbosity -> Verbosity
Enum, 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, forall x. Rep Verbosity x -> Verbosity
forall x. Verbosity -> Rep Verbosity x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Verbosity x -> Verbosity
$cfrom :: forall x. Verbosity -> Rep Verbosity x
Generic, 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 -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Verbosity] -> ShowS
$cshowList :: [Verbosity] -> ShowS
show :: Verbosity -> [Char]
$cshow :: Verbosity -> [Char]
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 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) =>
[Char] -> 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
. [Char] -> 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) =>
[Char] -> 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
. [Char] -> 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) =>
[Char] -> 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
. [Char] -> ByteString
BL.pack
versionString :: String
versionString :: [Char]
versionString = [Char]
"ELynx Suite version " forall a. [a] -> [a] -> [a]
++ Version -> [Char]
showVersion Version
version forall a. [a] -> [a] -> [a]
++ [Char]
"."
copyrightString :: String
copyrightString :: [Char]
copyrightString = [Char]
"Developed by Dominik Schrempf."
compilationString :: String
compilationString :: [Char]
compilationString =
[Char]
"Compiled on "
forall a. [a] -> [a] -> [a]
++ $( stringE
=<< runIO
( formatTime defaultTimeLocale "%B %-e, %Y, at %H:%M %P, %Z."
`fmap` getCurrentTime
)
)
logHeader :: [String]
= [[Char]
versionString, [Char]
copyrightString, [Char]
compilationString]
alignRightWithNoTrim :: Char -> Int -> BL.ByteString -> BL.ByteString
alignRightWithNoTrim :: Char -> Int -> ByteString -> ByteString
alignRightWithNoTrim Char
c Int
n ByteString
s = Int64 -> Char -> ByteString
BL.replicate (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n forall a. Num a => a -> a -> a
- Int64
l) Char
c forall a. Semigroup a => a -> a -> a
<> ByteString
s
where
l :: Int64
l = ByteString -> Int64
BL.length ByteString
s
renderDuration :: NominalDiffTime -> BL.ByteString
renderDuration :: NominalDiffTime -> ByteString
renderDuration NominalDiffTime
dt = ByteString
hTxt forall a. Semigroup a => a -> a -> a
<> ByteString
mTxt forall a. Semigroup a => a -> a -> a
<> ByteString
sTxt
where
hTxt :: ByteString
hTxt = Int -> ByteString
renderDecimal Int
h forall a. Semigroup a => a -> a -> a
<> ByteString
":"
mTxt :: ByteString
mTxt = Int -> ByteString
renderDecimal Int
m forall a. Semigroup a => a -> a -> a
<> ByteString
":"
sTxt :: ByteString
sTxt = Int -> ByteString
renderDecimal Int
s
(Int
h, Int
hRem) = Int
ts forall a. Integral a => a -> a -> (a, a)
`quotRem` Int
3600
(Int
m, Int
s) = Int
hRem forall a. Integral a => a -> a -> (a, a)
`quotRem` Int
60
ts :: Int
ts :: Int
ts = forall a b. (RealFrac a, Integral b) => a -> b
round NominalDiffTime
dt
renderDecimal :: Int -> ByteString
renderDecimal Int
n = Char -> Int -> ByteString -> ByteString
alignRightWithNoTrim Char
'0' Int
2 forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
BB.toLazyByteString forall a b. (a -> b) -> a -> b
$ Int -> Builder
BB.intDec Int
n
renderTime :: FormatTime t => t -> String
renderTime :: forall t. FormatTime t => t -> [Char]
renderTime = forall t. FormatTime t => TimeLocale -> [Char] -> t -> [Char]
formatTime TimeLocale
defaultTimeLocale [Char]
"%B %-e, %Y, at %H:%M %P, %Z."
logInfoHeader :: (HasLock e, HasLogHandles e, HasStartingTime e, HasVerbosity e) => String -> [String] -> Logger e ()
[Char]
cmdName [[Char]]
cmdDsc = do
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
[Char] -> Logger e ()
logInfoS [Char]
hline
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
[Char] -> Logger e ()
logInfoS forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"\n" [[Char]]
logHeader
[Char]
t <- forall t. FormatTime t => t -> [Char]
renderTime forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
reader forall s. HasStartingTime s => s -> UTCTime
getStartingTime
[Char]
p <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [Char]
getProgName
[[Char]]
as <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [[Char]]
getArgs
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
[Char] -> Logger e ()
logInfoS forall a b. (a -> b) -> a -> b
$
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"\n" forall a b. (a -> b) -> a -> b
$
[Char]
hline
forall a. a -> [a] -> [a]
: ([Char]
"Command name: " forall a. [a] -> [a] -> [a]
++ [Char]
cmdName)
forall a. a -> [a] -> [a]
: [[Char]]
cmdDsc
forall a. [a] -> [a] -> [a]
++ [[Char]
"Starting time: " forall a. [a] -> [a] -> [a]
++ [Char]
t, [Char]
"Command line: " forall a. [a] -> [a] -> [a]
++ [Char]
p forall a. [a] -> [a] -> [a]
++ [Char]
" " forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unwords [[Char]]
as]
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
[Char] -> Logger e ()
logInfoS [Char]
hline
where
hline :: [Char]
hline = forall a. Int -> a -> [a]
replicate Int
78 Char
'-'
logInfoFooter :: (HasLock e, HasLogHandles e, HasStartingTime e, HasVerbosity e) => Logger e ()
= 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) =>
[Char] -> Logger e ()
logInfoS forall a b. (a -> b) -> a -> b
$ [Char]
"End time: " forall a. Semigroup a => a -> a -> a
<> forall t. FormatTime t => t -> [Char]
renderTime UTCTime
te
logInfoNewSection :: (HasLock e, HasLogHandles e, HasVerbosity e) => String -> Logger e ()
logInfoNewSection :: forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
[Char] -> Logger e ()
logInfoNewSection [Char]
s = forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
[Char] -> Logger e ()
logInfoS forall a b. (a -> b) -> a -> b
$ [Char]
"== " forall a. Semigroup a => a -> a -> a
<> [Char]
s