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

-- |
-- Module      :  ELynx.Tools.Logger
-- Description :  Monad logger utility functions
-- Copyright   :  2021 Dominik Schrempf
-- 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
  ( 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

-- | Verbosity levels.
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)

-- | 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 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" 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

-- Make sure that concurrent output is not scrambled.
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)

-- | Write to standard output and maybe to log file.
logOutB ::
  (HasLogHandles e, HasLock e) =>
  -- | Prefix.
  BL.ByteString ->
  -- | Message.
  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

-- Perform debug action.
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

-- | Log debug message.
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: "

-- | Log debug message.
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

-- Perform warning action.
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

-- | Log warning message.
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: "

-- | Log warning message.
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

-- Perform info action.
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

-- | Log info message.
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
"   "

-- | Log info message.
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

-- Be careful; it is necessary to synchronize the version numbers across packages.
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
              )
        )

-- | A short header to be used in executables. 'unlines' doesn't work here
-- because it adds an additional newline at the end.
logHeader :: [String]
logHeader :: [[Char]]
logHeader = [[Char]
versionString, [Char]
copyrightString, [Char]
compilationString]

-- For a given width, align string to the right; use given fill character.
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

-- Adapted from System.ProgressBar.renderDuration of package
-- [terminal-progressbar-0.4.1](https://hackage.haskell.org/package/terminal-progress-bar-0.4.1).
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
    -- Total amount of seconds
    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

-- Render a time stamp.
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."

-- | Log header.
logInfoHeader :: (HasLock e, HasLogHandles e, HasStartingTime e, HasVerbosity e) => String -> [String] -> Logger e ()
logInfoHeader :: forall e.
(HasLock e, HasLogHandles e, HasStartingTime e, HasVerbosity e) =>
[Char] -> [[Char]] -> Logger e ()
logInfoHeader [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
'-'

-- | Log footer.
logInfoFooter :: (HasLock e, HasLogHandles e, HasStartingTime e, HasVerbosity e) => Logger e ()
logInfoFooter :: forall e.
(HasLock e, HasLogHandles e, HasStartingTime e, HasVerbosity e) =>
Logger e ()
logInfoFooter = 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

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