{-# 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.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)
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 = error $ "Unrecognized verbosity " <> s
where
ls = toLower <$> s
instance FromJSON Verbosity where
parseJSON (String t) = pure $ fromString . unpack $ t
parseJSON _ = fail $ "Could not parse the logging verbosity."