{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
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.List (intercalate)
import Data.String (IsString(..))
import Data.Text (Text, unpack)
import Data.Text.IO (hPutStr)
import Data.Yaml
import System.IO (stderr, withFile, IOMode (AppendMode) )
data Verbosity = Debug
| Info
| Warning
| Error
| Silent
deriving (Eq, Ord, Show, Enum, Bounded)
data LogSink = StdErr
| LogFile FilePath
deriving (Eq, Show)
data Logger = Logger
{ lVerbosity :: Verbosity
, lChannel :: Chan (Maybe Text)
, lSink :: Text -> IO ()
, lSync :: MVar ()
}
withLogger :: Verbosity -> LogSink -> (Logger -> IO a) -> IO a
withLogger v s f = do
logger <- Logger <$> pure v
<*> newChan
<*> pure (sink s)
<*> newEmptyMVar
_ <- forkIO $ forever $
readChan (lChannel logger)
>>= maybe (putMVar (lSync logger) ()) (lSink logger)
result <- f logger
writeChan (lChannel logger) Nothing
() <- takeMVar (lSync logger)
return result
where
sink StdErr = hPutStr stderr
sink (LogFile fp) = \t -> withFile fp AppendMode $ \h -> hPutStr h t
instance IsString Verbosity where
fromString s
| ls == "silent" = Silent
| ls == "info" = Info
| ls == "warning" = Warning
| ls == "error" = Error
| ls == "debug" = Debug
| otherwise = errorWithoutStackTrace $ mconcat ["Unrecognized verbosity '", s, "'. Valid choices are: " ] <> choices
where
ls = toLower <$> s
choices = intercalate ", "
$ fmap (fmap toLower . show)
$ enumFromTo minBound (maxBound::Verbosity)
instance FromJSON Verbosity where
parseJSON (String t) = pure $ fromString . unpack $ t
parseJSON _ = fail $ "Could not parse the logging verbosity."