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

{-|
Module      : $header$
Copyright   : (c) Laurent P René de Cotret, 2020
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 
    ( Verbosity(..)
    , LogSink(..)
    , Logger(..)
    , withLogger
    ) where


import           Control.Concurrent           (forkIO)
import           Control.Concurrent.Chan      (Chan, newChan, readChan, writeChan)
import           Control.Concurrent.MVar      (MVar, newEmptyMVar, putMVar, takeMVar)

import           Control.Monad                (forever)

import           Data.Char                    (toLower)
import           Data.String                  (IsString(..))
import           Data.Text                    (Text, unpack)
import           Data.Text.IO                 (hPutStr)
import           Data.Yaml

import           System.IO                    (stderr, withFile, IOMode (AppendMode) )



-- | Verbosity of the logger.

data Verbosity = Debug    -- ^ Log all messages, including debug messages.

               | Error    -- ^ Log information, warnings, and errors.

               | Warning  -- ^ Log information and warning messages.

               | Info     -- ^ Only log information messages.

               | Silent   -- ^ Don't log anything. 

               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)


-- | Description of the possible ways to sink log messages.

data LogSink = StdErr           -- ^ Standard error stream.

             | LogFile FilePath -- ^ Appended to file.

             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
    , Logger -> Chan (Maybe Text)
lChannel   :: Chan (Maybe Text)
    , Logger -> Text -> IO ()
lSink      :: Text -> IO ()
    , Logger -> MVar ()
lSync      :: MVar ()
    }


-- | 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 v :: Verbosity
v s :: LogSink
s f :: Logger -> IO a
f = do
    Logger
logger <- Verbosity
-> Chan (Maybe Text) -> (Text -> IO ()) -> MVar () -> Logger
Logger (Verbosity
 -> Chan (Maybe Text) -> (Text -> IO ()) -> MVar () -> Logger)
-> IO Verbosity
-> IO (Chan (Maybe Text) -> (Text -> IO ()) -> MVar () -> Logger)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Verbosity -> IO Verbosity
forall (f :: * -> *) a. Applicative f => a -> f a
pure Verbosity
v
                     IO (Chan (Maybe Text) -> (Text -> IO ()) -> MVar () -> Logger)
-> IO (Chan (Maybe Text))
-> IO ((Text -> IO ()) -> MVar () -> Logger)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO (Chan (Maybe Text))
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 (Maybe Text) -> IO (Maybe Text)
forall a. Chan a -> IO a
readChan (Logger -> Chan (Maybe Text)
lChannel Logger
logger) 
                IO (Maybe Text) -> (Maybe Text -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> (Text -> IO ()) -> Maybe Text -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar (Logger -> MVar ()
lSync Logger
logger) ()) (Logger -> Text -> IO ()
lSink Logger
logger)

    a
result <- Logger -> IO a
f Logger
logger
    
    -- 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 (Maybe Text) -> Maybe Text -> IO ()
forall a. Chan a -> a -> IO ()
writeChan (Logger -> Chan (Maybe Text)
lChannel Logger
logger) Maybe Text
forall a. Maybe a
Nothing
    () <- MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar (Logger -> MVar ()
lSync Logger
logger)

    a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
result

    where
        sink :: LogSink -> Text -> IO ()
sink StdErr       = Handle -> Text -> IO ()
hPutStr Handle
stderr
        sink (LogFile fp :: String
fp) = \t :: Text
t -> String -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
fp IOMode
AppendMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \h :: Handle
h -> Handle -> Text -> IO ()
hPutStr Handle
h Text
t


instance IsString Verbosity where
    fromString :: String -> Verbosity
fromString s :: String
s
        | String
ls String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "silent"  = Verbosity
Silent
        | String
ls String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "info"    = Verbosity
Info
        | String
ls String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "warning" = Verbosity
Warning
        | String
ls String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "error"   = Verbosity
Error
        | String
ls String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "debug"   = Verbosity
Debug
        | Bool
otherwise = String -> Verbosity
forall a. HasCallStack => String -> a
error (String -> Verbosity) -> String -> Verbosity
forall a b. (a -> b) -> a -> b
$ "Unrecognized verbosity " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
s
        where
            ls :: String
ls = Char -> Char
toLower (Char -> Char) -> ShowS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
s

instance FromJSON Verbosity where
    parseJSON :: Value -> Parser Verbosity
parseJSON (String t :: 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 _ = String -> Parser Verbosity
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser Verbosity) -> String -> Parser Verbosity
forall a b. (a -> b) -> a -> b
$ "Could not parse the logging verbosity."