From bc7e846da61bdcd3ce6ef49e9d3e6bf4a0bd1a5d Mon Sep 17 00:00:00 2001 From: John MacFarlane Date: Sun, 22 Jan 2017 23:49:05 +0100 Subject: More logging-related changes. Class: * Removed getWarnings, withWarningsToStderr * Added report * Added logOutput to PandocMonad * Make logOutput streaming in PandocIO monad * Properly reverse getLog output Readers: * Replaced use of trace with report DEBUG. TWiki Reader: Put everything inside PandocMonad m. API changes. --- src/Text/Pandoc/Class.hs | 45 ++++++++++++++++++++++----------------------- 1 file changed, 22 insertions(+), 23 deletions(-) (limited to 'src/Text/Pandoc/Class.hs') diff --git a/src/Text/Pandoc/Class.hs b/src/Text/Pandoc/Class.hs index 1c21c7b7b..79c7316f1 100644 --- a/src/Text/Pandoc/Class.hs +++ b/src/Text/Pandoc/Class.hs @@ -42,7 +42,7 @@ module Text.Pandoc.Class ( PandocMonad(..) , getZonedTime , warning , warningWithPos - , getWarnings + , report , getLog , setVerbosity , getMediaBag @@ -59,7 +59,6 @@ module Text.Pandoc.Class ( PandocMonad(..) , runIOorExplode , runPure , withMediaBag - , withWarningsToStderr ) where import Prelude hiding (readFile) @@ -69,8 +68,8 @@ import Codec.Archive.Zip (Archive, fromArchive, emptyArchive) import Data.Unique (hashUnique) import qualified Data.Unique as IO (newUnique) import qualified Text.Pandoc.Shared as IO ( readDataFile - , warn , openURL ) +import qualified Text.Pandoc.UTF8 as UTF8 import Text.Pandoc.Compat.Time (UTCTime) import Text.Pandoc.Options (Verbosity(..)) import Text.Pandoc.Parsing (ParserT, SourcePos) @@ -102,10 +101,12 @@ import Control.Monad.RWS (RWST) import Data.Word (Word8) import Data.Default import System.IO.Error +import System.IO (stderr) import qualified Data.Map as M import Text.Pandoc.Error import Data.Monoid import Data.Maybe (catMaybes) +import Text.Printf (printf) class (Functor m, Applicative m, Monad m, MonadError PandocError m) => PandocMonad m where @@ -131,13 +132,7 @@ class (Functor m, Applicative m, Monad m, MonadError PandocError m) modifyCommonState :: (CommonState -> CommonState) -> m () modifyCommonState f = getCommonState >>= putCommonState . f - -- Can be overridden when you want log to be written to - -- stderr in a streaming fashion - report :: Verbosity -> String -> m () - report level msg = do - verbosity <- getsCommonState stVerbosity - when (level >= verbosity) $ - modifyCommonState $ \st -> st{ stLog = (level, msg) : stLog st } + logOutput :: Verbosity -> String -> m () -- Functions defined for all PandocMonad instances @@ -146,7 +141,7 @@ setVerbosity verbosity = modifyCommonState $ \st -> st{ stVerbosity = verbosity } getLog :: PandocMonad m => m [(Verbosity, String)] -getLog = getsCommonState stLog +getLog = reverse <$> getsCommonState stLog warning :: PandocMonad m => String -> m () warning msg = report WARNING msg @@ -157,11 +152,13 @@ warningWithPos :: PandocMonad m -> ParserT s st m () warningWithPos pos msg = lift $ warning $ msg ++ " " ++ show pos --- TODO get rid of this? -getWarnings :: PandocMonad m => m [String] -getWarnings = do - logs <- getLog - return [s | (WARNING, s) <- logs] +report :: PandocMonad m => Verbosity -> String -> m () +report level msg = do + verbosity <- getsCommonState stVerbosity + when (level <= verbosity) $ do + logOutput verbosity msg + unless (level == DEBUG) $ + modifyCommonState $ \st -> st{ stLog = (level, msg) : stLog st } setMediaBag :: PandocMonad m => MediaBag -> m () setMediaBag mb = modifyCommonState $ @@ -255,12 +252,6 @@ runIO ma = flip evalStateT def $ runExceptT $ unPandocIO ma withMediaBag :: PandocMonad m => m a -> m (a, MediaBag) withMediaBag ma = ((,)) <$> ma <*> getMediaBag -withWarningsToStderr :: PandocIO a -> PandocIO a -withWarningsToStderr f = do - x <- f - getWarnings >>= mapM_ IO.warn - return x - runIOorExplode :: PandocIO a -> IO a runIOorExplode ma = runIO ma >>= handleError @@ -309,7 +300,8 @@ instance PandocMonad PandocIO where Left _ -> throwError $ PandocFileReadError fp getCommonState = PandocIO $ lift get putCommonState x = PandocIO $ lift $ put x - + logOutput level msg = + liftIO $ UTF8.hPutStrLn stderr $ printf "%-7s %s" (show level) msg -- | Specialized version of parseURIReference that disallows -- single-letter schemes. Reason: these are usually windows absolute @@ -508,6 +500,8 @@ instance PandocMonad PandocPure where getCommonState = PandocPure $ lift $ get putCommonState x = PandocPure $ lift $ put x + logOutput _level _msg = return () + instance PandocMonad m => PandocMonad (ParserT s st m) where lookupEnv = lift . lookupEnv getCurrentTime = lift getCurrentTime @@ -522,6 +516,7 @@ instance PandocMonad m => PandocMonad (ParserT s st m) where getModificationTime = lift . getModificationTime getCommonState = lift getCommonState putCommonState = lift . putCommonState + logOutput lvl = lift . logOutput lvl instance PandocMonad m => PandocMonad (ReaderT r m) where lookupEnv = lift . lookupEnv @@ -537,6 +532,7 @@ instance PandocMonad m => PandocMonad (ReaderT r m) where getModificationTime = lift . getModificationTime getCommonState = lift getCommonState putCommonState = lift . putCommonState + logOutput lvl = lift . logOutput lvl instance (PandocMonad m, Monoid w) => PandocMonad (WriterT w m) where lookupEnv = lift . lookupEnv @@ -552,6 +548,7 @@ instance (PandocMonad m, Monoid w) => PandocMonad (WriterT w m) where getModificationTime = lift . getModificationTime getCommonState = lift getCommonState putCommonState = lift . putCommonState + logOutput lvl = lift . report lvl instance (PandocMonad m, Monoid w) => PandocMonad (RWST r w st m) where lookupEnv = lift . lookupEnv @@ -567,6 +564,7 @@ instance (PandocMonad m, Monoid w) => PandocMonad (RWST r w st m) where getModificationTime = lift . getModificationTime getCommonState = lift getCommonState putCommonState = lift . putCommonState + logOutput lvl = lift . logOutput lvl instance PandocMonad m => PandocMonad (StateT st m) where lookupEnv = lift . lookupEnv @@ -582,4 +580,5 @@ instance PandocMonad m => PandocMonad (StateT st m) where getModificationTime = lift . getModificationTime getCommonState = lift getCommonState putCommonState = lift . putCommonState + logOutput lvl = lift . logOutput lvl -- cgit v1.2.3