{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

-- |
-- Module      : $header$
-- Copyright   : (c) Laurent P René de Cotret, 2019 - present
-- License     : GNU GPL, version 2 or above
-- Maintainer  : laurent.decotret@outlook.com
-- Stability   : internal
-- Portability : portable
--
-- Logging primitives.
module Text.Pandoc.Filter.Plot.Monad.Logging
  ( MonadLogger (..),
    Verbosity (..),
    LogSink (..),
    Logger (..),
    withLogger,
    terminateLogging,

    -- * Logging messages
    debug,
    err,
    warning,
    info,
    strict,
  )
where

import Control.Concurrent (forkIO)
import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar)
import Control.Monad (forM_, forever, void, when)
import Control.Monad.IO.Class (MonadIO (..))
import Data.Char (toLower)
import Data.List (intercalate)
import Data.String (IsString (..))
import Data.Text (Text, unpack)
import qualified Data.Text as T
import Data.Text.IO as TIO (appendFile, hPutStr)
import Data.Yaml (FromJSON (parseJSON), Value (String))
import System.IO (stderr)
import Prelude hiding (log)

-- | Verbosity of the logger.
data Verbosity
  = -- | Log all messages, including debug messages.
    Debug
  | -- | Log information, warning, and error messages.
    Info
  | -- | Log warning and error messages.
    Warning
  | -- | Only log errors.
    Error
  | -- | Don't log anything.
    Silent
  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, 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, 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
forall a. a -> a -> Bounded a
maxBound :: Verbosity
$cmaxBound :: Verbosity
minBound :: Verbosity
$cminBound :: Verbosity
Bounded)

-- | Description of the possible ways to sink log messages.
data LogSink
  = -- | Standard error stream.
    StdErr
  | -- | Appended to file.
    LogFile FilePath
  deriving (LogSink -> LogSink -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LogSink -> LogSink -> Bool
$c/= :: LogSink -> LogSink -> Bool
== :: LogSink -> LogSink -> Bool
$c== :: LogSink -> LogSink -> Bool
Eq, Int -> LogSink -> ShowS
[LogSink] -> ShowS
LogSink -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LogSink] -> ShowS
$cshowList :: [LogSink] -> ShowS
show :: LogSink -> String
$cshow :: LogSink -> String
showsPrec :: Int -> LogSink -> ShowS
$cshowsPrec :: Int -> LogSink -> ShowS
Show)

-- | The logging implementation is very similar to Hakyll's.
data Logger = Logger
  { Logger -> Verbosity
lVerbosity :: Verbosity, -- Verbosity level below which to ignore messages
    Logger -> Chan Command
lChannel :: Chan Command, -- Queue of logging commands
    Logger -> Text -> IO ()
lSink :: Text -> IO (), -- Action to perform with log messages
    Logger -> MVar ()
lSync :: MVar () -- Synchronization variable
  }

data Command
  = LogMessage Text
  | EndLogging

class Monad m => MonadLogger m where
  askLogger :: m Logger

-- | Ensure that all log messages are flushed, and stop logging
terminateLogging :: Logger -> IO ()
terminateLogging :: Logger -> IO ()
terminateLogging Logger
logger = do
  -- Flushing the logger
  -- To signal to the logger that logging duties are over,
  -- we append Nothing to the channel, and wait for it to finish
  -- dealing with all items in the channel.
  forall a. Chan a -> a -> IO ()
writeChan (Logger -> Chan Command
lChannel Logger
logger) Command
EndLogging
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> IO a
takeMVar (Logger -> MVar ()
lSync Logger
logger)

-- | Perform an IO action with a logger. Using this function
-- ensures that logging will be gracefully shut down.
withLogger :: Verbosity -> LogSink -> (Logger -> IO a) -> IO a
withLogger :: forall a. Verbosity -> LogSink -> (Logger -> IO a) -> IO a
withLogger Verbosity
v LogSink
s Logger -> IO a
f = do
  Logger
logger <-
    Verbosity -> Chan Command -> (Text -> IO ()) -> MVar () -> Logger
Logger Verbosity
v
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IO (Chan a)
newChan
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure (LogSink -> Text -> IO ()
sink LogSink
s)
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. IO (MVar a)
newEmptyMVar

  -- The logger either logs messages (if Just "message"),
  -- or stops working on Nothing.
  ThreadId
_ <-
    IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$
      forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$
        forall a. Chan a -> IO a
readChan (Logger -> Chan Command
lChannel Logger
logger)
          forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Command
EndLogging -> forall a. MVar a -> a -> IO ()
putMVar (Logger -> MVar ()
lSync Logger
logger) ()
            LogMessage Text
t -> Logger -> Text -> IO ()
lSink Logger
logger Text
t

  a
result <- Logger -> IO a
f Logger
logger

  Logger -> IO ()
terminateLogging Logger
logger

  forall (m :: * -> *) a. Monad m => a -> m a
return a
result
  where
    sink :: LogSink -> Text -> IO ()
    sink :: LogSink -> Text -> IO ()
sink LogSink
StdErr = Handle -> Text -> IO ()
TIO.hPutStr Handle
stderr
    sink (LogFile String
fp) = String -> Text -> IO ()
TIO.appendFile String
fp

-- | General purpose logging function.
log ::
  (MonadLogger m, MonadIO m) =>
  Text -> -- Header
  Verbosity ->
  Text ->
  m ()
log :: forall (m :: * -> *).
(MonadLogger m, MonadIO m) =>
Text -> Verbosity -> Text -> m ()
log Text
h Verbosity
v Text
t = do
  Logger
logger <- forall (m :: * -> *). MonadLogger m => m Logger
askLogger
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
v forall a. Ord a => a -> a -> Bool
>= Logger -> Verbosity
lVerbosity Logger
logger) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Text -> [Text]
T.lines Text
t) forall a b. (a -> b) -> a -> b
$ \Text
l -> forall a. Chan a -> a -> IO ()
writeChan (Logger -> Chan Command
lChannel Logger
logger) (Text -> Command
LogMessage (Text
h forall a. Semigroup a => a -> a -> a
<> Text
l forall a. Semigroup a => a -> a -> a
<> Text
"\n"))

debug, err, strict, warning, info :: (MonadLogger m, MonadIO m) => Text -> m ()
debug :: forall (m :: * -> *). (MonadLogger m, MonadIO m) => Text -> m ()
debug = forall (m :: * -> *).
(MonadLogger m, MonadIO m) =>
Text -> Verbosity -> Text -> m ()
log Text
"[pandoc-plot] DEBUG | " Verbosity
Debug
err :: forall (m :: * -> *). (MonadLogger m, MonadIO m) => Text -> m ()
err = forall (m :: * -> *).
(MonadLogger m, MonadIO m) =>
Text -> Verbosity -> Text -> m ()
log Text
"[pandoc-plot] ERROR | " Verbosity
Error
strict :: forall (m :: * -> *). (MonadLogger m, MonadIO m) => Text -> m ()
strict = forall (m :: * -> *).
(MonadLogger m, MonadIO m) =>
Text -> Verbosity -> Text -> m ()
log Text
"[pandoc-plot] STRICT MODE | " Verbosity
Error
warning :: forall (m :: * -> *). (MonadLogger m, MonadIO m) => Text -> m ()
warning = forall (m :: * -> *).
(MonadLogger m, MonadIO m) =>
Text -> Verbosity -> Text -> m ()
log Text
"[pandoc-plot] WARN  | " Verbosity
Warning
info :: forall (m :: * -> *). (MonadLogger m, MonadIO m) => Text -> m ()
info = forall (m :: * -> *).
(MonadLogger m, MonadIO m) =>
Text -> Verbosity -> Text -> m ()
log Text
"[pandoc-plot] INFO  | " Verbosity
Info

instance IsString Verbosity where
  fromString :: String -> Verbosity
fromString String
s
    | String
ls forall a. Eq a => a -> a -> Bool
== String
"silent" = Verbosity
Silent
    | String
ls forall a. Eq a => a -> a -> Bool
== String
"info" = Verbosity
Info
    | String
ls forall a. Eq a => a -> a -> Bool
== String
"warning" = Verbosity
Warning
    | String
ls forall a. Eq a => a -> a -> Bool
== String
"error" = Verbosity
Error
    | String
ls forall a. Eq a => a -> a -> Bool
== String
"debug" = Verbosity
Debug
    | Bool
otherwise = forall a. String -> a
errorWithoutStackTrace forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat [String
"Unrecognized verbosity '", String
s, String
"'. Valid choices are: "] forall a. Semigroup a => a -> a -> a
<> String
choices
    where
      ls :: String
ls = Char -> Char
toLower forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
s
      choices :: String
choices =
        forall a. [a] -> [[a]] -> [a]
intercalate
          String
", "
          ( forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Char -> Char
toLower forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show
              forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Enum a => a -> a -> [a]
enumFromTo forall a. Bounded a => a
minBound (forall a. Bounded a => a
maxBound :: Verbosity)
          )

instance FromJSON Verbosity where
  parseJSON :: Value -> Parser Verbosity
parseJSON (String Text
t) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
unpack forall a b. (a -> b) -> a -> b
$ Text
t
  parseJSON Value
_ = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Could not parse the logging verbosity."