{-# 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
(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, 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, Int -> Verbosity
Verbosity -> Int
Verbosity -> [Verbosity]
Verbosity -> Verbosity
Verbosity -> Verbosity -> [Verbosity]
Verbosity -> Verbosity -> Verbosity -> [Verbosity]
(Verbosity -> Verbosity)
-> (Verbosity -> Verbosity)
-> (Int -> Verbosity)
-> (Verbosity -> Int)
-> (Verbosity -> [Verbosity])
-> (Verbosity -> Verbosity -> [Verbosity])
-> (Verbosity -> Verbosity -> [Verbosity])
-> (Verbosity -> Verbosity -> Verbosity -> [Verbosity])
-> Enum 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 -> Verbosity -> Bounded 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
(LogSink -> LogSink -> Bool)
-> (LogSink -> LogSink -> Bool) -> Eq LogSink
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
(Int -> LogSink -> ShowS)
-> (LogSink -> String) -> ([LogSink] -> ShowS) -> Show LogSink
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.

  Chan Command -> Command -> IO ()
forall a. Chan a -> a -> IO ()
writeChan (Logger -> Chan Command
lChannel Logger
logger) Command
EndLogging
  IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ MVar () -> IO ()
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 :: 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
      (Chan Command -> (Text -> IO ()) -> MVar () -> Logger)
-> IO (Chan Command) -> IO ((Text -> IO ()) -> MVar () -> Logger)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Chan Command)
forall a. IO (Chan a)
newChan
      IO ((Text -> IO ()) -> MVar () -> Logger)
-> IO (Text -> IO ()) -> IO (MVar () -> Logger)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Text -> IO ()) -> IO (Text -> IO ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LogSink -> Text -> IO ()
sink LogSink
s)
      IO (MVar () -> Logger) -> IO (MVar ()) -> IO Logger
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar

  -- The logger either logs messages (if Just "message"),

  -- or stops working on Nothing.

  ThreadId
_ <-
    IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$
      IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Chan Command -> IO Command
forall a. Chan a -> IO a
readChan (Logger -> Chan Command
lChannel Logger
logger)
          IO Command -> (Command -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Command
EndLogging -> MVar () -> () -> IO ()
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

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

debug, err, strict, warning, info :: (MonadLogger m, MonadIO m) => Text -> m ()
debug :: Text -> m ()
debug = Text -> Verbosity -> Text -> m ()
forall (m :: * -> *).
(MonadLogger m, MonadIO m) =>
Text -> Verbosity -> Text -> m ()
log Text
"[pandoc-plot] DEBUG | " Verbosity
Debug
err :: Text -> m ()
err = Text -> Verbosity -> Text -> m ()
forall (m :: * -> *).
(MonadLogger m, MonadIO m) =>
Text -> Verbosity -> Text -> m ()
log Text
"[pandoc-plot] ERROR | " Verbosity
Error
strict :: Text -> m ()
strict = Text -> Verbosity -> Text -> m ()
forall (m :: * -> *).
(MonadLogger m, MonadIO m) =>
Text -> Verbosity -> Text -> m ()
log Text
"[pandoc-plot] STRICT MODE | " Verbosity
Error
warning :: Text -> m ()
warning = Text -> Verbosity -> Text -> m ()
forall (m :: * -> *).
(MonadLogger m, MonadIO m) =>
Text -> Verbosity -> Text -> m ()
log Text
"[pandoc-plot] WARN  | " Verbosity
Warning
info :: Text -> m ()
info = Text -> Verbosity -> Text -> m ()
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 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"silent" = Verbosity
Silent
    | String
ls String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"info" = Verbosity
Info
    | String
ls String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"warning" = Verbosity
Warning
    | String
ls String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"error" = Verbosity
Error
    | String
ls String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"debug" = Verbosity
Debug
    | Bool
otherwise = String -> Verbosity
forall a. String -> a
errorWithoutStackTrace (String -> Verbosity) -> String -> Verbosity
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. Monoid a => [a] -> a
mconcat [String
"Unrecognized verbosity '", String
s, String
"'. Valid choices are: "] String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
choices
    where
      ls :: String
ls = Char -> Char
toLower (Char -> Char) -> ShowS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
s
      choices :: String
choices =
        String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate
          String
", "
          ( (Char -> Char) -> ShowS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Char -> Char
toLower ShowS -> (Verbosity -> String) -> Verbosity -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Verbosity -> String
forall a. Show a => a -> String
show
              (Verbosity -> String) -> [Verbosity] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Verbosity -> Verbosity -> [Verbosity]
forall a. Enum a => a -> a -> [a]
enumFromTo Verbosity
forall a. Bounded a => a
minBound (Verbosity
forall a. Bounded a => a
maxBound :: Verbosity)
          )

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