mirror of
https://github.com/jgm/pandoc.git
synced 2026-08-28 19:26:45 +00:00
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.
This commit is contained in:
John MacFarlane
@@ -35,8 +35,7 @@ import Text.Pandoc.Builder (setMeta)
|
||||
import Text.Pandoc.PDF (makePDF)
|
||||
import Text.Pandoc.Walk (walk)
|
||||
import Text.Pandoc.Shared ( tabFilter, readDataFileUTF8, readDataFile,
|
||||
safeRead, headerShift, err, warn,
|
||||
openURL )
|
||||
safeRead, headerShift, err, openURL )
|
||||
import Text.Pandoc.MediaBag ( mediaDirectory, extractMediaBag, MediaBag )
|
||||
import Text.Pandoc.XML ( toEntities )
|
||||
import Text.Pandoc.SelfContained ( makeSelfContained )
|
||||
@@ -75,7 +74,7 @@ import System.Posix.Terminal (queryTerminal)
|
||||
import System.Posix.IO (stdOutput)
|
||||
#endif
|
||||
import Control.Monad.Trans
|
||||
import Text.Pandoc.Class (withMediaBag, PandocIO, getWarnings)
|
||||
import Text.Pandoc.Class (withMediaBag, PandocIO, getLog, setVerbosity)
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
@@ -354,14 +353,14 @@ convertWithOpts opts args = do
|
||||
|
||||
let runIO' :: PandocIO a -> IO a
|
||||
runIO' f = do
|
||||
(res, warnings) <- runIOorExplode $ do
|
||||
(res, reports) <- runIOorExplode $ do
|
||||
setVerbosity verbosity
|
||||
x <- f
|
||||
ws <- getWarnings
|
||||
return (x, ws)
|
||||
when (not (null warnings)) $ do
|
||||
-- TODO make these streaming
|
||||
when (verbosity >= WARNING) $ mapM_ warn warnings
|
||||
when failIfWarnings $
|
||||
rs <- getLog
|
||||
return (x, rs)
|
||||
let isWarning (WARNING, _) = True
|
||||
isWarning _ = False
|
||||
when (failIfWarnings && any isWarning reports) $
|
||||
err 3 "Failing because there were warnings."
|
||||
return res
|
||||
|
||||
|
||||
+22
-23
@@ -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
|
||||
|
||||
|
||||
@@ -45,7 +45,7 @@ import qualified Text.Pandoc.Builder as B
|
||||
import Text.Pandoc.Builder (Blocks, Inlines, trimInlines, HasMeta(..))
|
||||
import Text.Pandoc.Shared ( extractSpaces, renderTags', addMetaField
|
||||
, escapeURI, safeRead )
|
||||
import Text.Pandoc.Options (ReaderOptions(readerParseRaw, readerVerbosity),
|
||||
import Text.Pandoc.Options (ReaderOptions(readerParseRaw),
|
||||
Verbosity(..), Extension (Ext_epub_html_exts,
|
||||
Ext_native_divs, Ext_native_spans))
|
||||
import Text.Pandoc.Parsing hiding ((<|>))
|
||||
@@ -54,12 +54,11 @@ import qualified Data.Map as M
|
||||
import Data.Maybe ( fromMaybe, isJust)
|
||||
import Data.List ( intercalate, isInfixOf, isPrefixOf )
|
||||
import Data.Char ( isDigit )
|
||||
import Control.Monad ( guard, when, mzero, void, unless )
|
||||
import Control.Monad ( guard, mzero, void, unless )
|
||||
import Control.Arrow ((***))
|
||||
import Control.Applicative ( (<|>) )
|
||||
import Data.Monoid (First (..))
|
||||
import Text.Printf (printf)
|
||||
import Debug.Trace (trace)
|
||||
import Text.TeXMath (readMathML, writeTeX)
|
||||
import Data.Default (Default (..), def)
|
||||
import Control.Monad.Reader (ask, asks, local, ReaderT, runReaderT, lift)
|
||||
@@ -69,7 +68,7 @@ import Data.Monoid ((<>))
|
||||
import Text.Parsec.Error
|
||||
import qualified Data.Set as Set
|
||||
import Text.Pandoc.Error
|
||||
import Text.Pandoc.Class (PandocMonad)
|
||||
import Text.Pandoc.Class (PandocMonad, report)
|
||||
import Control.Monad.Except (throwError)
|
||||
|
||||
|
||||
@@ -96,8 +95,6 @@ readHtml opts inp = do
|
||||
case result of
|
||||
Right doc -> return doc
|
||||
Left err -> throwError $ PandocParseError $ getError err
|
||||
|
||||
where
|
||||
|
||||
replaceNotes :: PandocMonad m => [Block] -> TagParser m [Block]
|
||||
replaceNotes = walkM replaceNotes'
|
||||
@@ -160,7 +157,6 @@ pHead = pInTags "head" $ pTitle <|> pMetaTag <|> pBaseTag <|> (mempty <$ pAnyTag
|
||||
|
||||
block :: PandocMonad m => TagParser m Blocks
|
||||
block = do
|
||||
tr <- (== DEBUG) <$> getOption readerVerbosity
|
||||
pos <- getPosition
|
||||
res <- choice
|
||||
[ eSection
|
||||
@@ -181,8 +177,8 @@ block = do
|
||||
, pPlain
|
||||
, pRawHtmlBlock
|
||||
]
|
||||
when tr $ trace (printf "line %d: %s" (sourceLine pos)
|
||||
(take 60 $ show $ B.toList res)) (return ())
|
||||
report DEBUG $ printf "line %d: %s"
|
||||
(sourceLine pos) (take 60 $ show $ B.toList res)
|
||||
return res
|
||||
|
||||
namespaces :: PandocMonad m => [(String, TagParser m Inlines)]
|
||||
|
||||
@@ -62,11 +62,10 @@ import Control.Monad
|
||||
import System.FilePath (takeExtension, addExtension)
|
||||
import Text.HTML.TagSoup
|
||||
import Text.Printf (printf)
|
||||
import Debug.Trace (trace)
|
||||
import Data.Monoid ((<>))
|
||||
import Control.Monad.Trans (lift)
|
||||
import Control.Monad.Except (throwError, catchError)
|
||||
import Text.Pandoc.Class (PandocMonad)
|
||||
import Text.Pandoc.Class (PandocMonad, report)
|
||||
import qualified Text.Pandoc.Class as P
|
||||
|
||||
type MarkdownParser m = ParserT [Char] ParserState m
|
||||
@@ -490,7 +489,6 @@ parseBlocks = mconcat <$> manyTill block eof
|
||||
|
||||
block :: PandocMonad m => MarkdownParser m (F Blocks)
|
||||
block = do
|
||||
tr <- (== DEBUG) <$> getOption readerVerbosity
|
||||
pos <- getPosition
|
||||
res <- choice [ mempty <$ blanklines
|
||||
, codeBlockFenced
|
||||
@@ -517,10 +515,8 @@ block = do
|
||||
, para
|
||||
, plain
|
||||
] <?> "block"
|
||||
when tr $ do
|
||||
st <- getState
|
||||
trace (printf "line %d: %s" (sourceLine pos)
|
||||
(take 60 $ show $ B.toList $ runF res st)) (return ())
|
||||
report DEBUG $ printf "line %d: %s" (sourceLine pos)
|
||||
(take 60 $ show $ B.toList $ runF res defaultParserState)
|
||||
return res
|
||||
|
||||
--
|
||||
|
||||
@@ -56,9 +56,8 @@ import qualified Data.Set as Set
|
||||
import Data.Char (isDigit, isSpace)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Text.Printf (printf)
|
||||
import Debug.Trace (trace)
|
||||
import Control.Monad.Except (throwError)
|
||||
import Text.Pandoc.Class (PandocMonad)
|
||||
import Text.Pandoc.Class (PandocMonad, report)
|
||||
|
||||
-- | Read mediawiki from an input string and return a Pandoc document.
|
||||
readMediaWiki :: PandocMonad m
|
||||
@@ -194,7 +193,6 @@ parseMediaWiki = do
|
||||
|
||||
block :: PandocMonad m => MWParser m Blocks
|
||||
block = do
|
||||
tr <- (== DEBUG) <$> getOption readerVerbosity
|
||||
pos <- getPosition
|
||||
res <- mempty <$ skipMany1 blankline
|
||||
<|> table
|
||||
@@ -208,9 +206,8 @@ block = do
|
||||
<|> blockTag
|
||||
<|> (B.rawBlock "mediawiki" <$> template)
|
||||
<|> para
|
||||
when tr $
|
||||
trace (printf "line %d: %s" (sourceLine pos)
|
||||
(take 60 $ show $ B.toList res)) (return ())
|
||||
report DEBUG $ printf "line %d: %s" (sourceLine pos)
|
||||
(take 60 $ show $ B.toList res)
|
||||
return res
|
||||
|
||||
para :: PandocMonad m => MWParser m Blocks
|
||||
|
||||
@@ -39,39 +39,38 @@ import Text.Pandoc.Parsing hiding (enclosed, macro, nested)
|
||||
import Text.Pandoc.Readers.HTML (htmlTag, isCommentTag)
|
||||
import Control.Monad
|
||||
import Text.Printf (printf)
|
||||
import Debug.Trace (trace)
|
||||
import Text.Pandoc.XML (fromEntities)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Text.HTML.TagSoup
|
||||
import Data.Char (isAlphaNum)
|
||||
import qualified Data.Foldable as F
|
||||
import Control.Monad.Except (throwError)
|
||||
import Text.Pandoc.Class (PandocMonad)
|
||||
import Text.Pandoc.Class (PandocMonad, report)
|
||||
|
||||
-- | Read twiki from an input string and return a Pandoc document.
|
||||
readTWiki :: PandocMonad m
|
||||
=> ReaderOptions
|
||||
-> String
|
||||
-> m Pandoc
|
||||
readTWiki opts s =
|
||||
case (readWith parseTWiki) def{ stateOptions = opts } (s ++ "\n\n") of
|
||||
readTWiki opts s = do
|
||||
res <- readWithM parseTWiki def{ stateOptions = opts } (s ++ "\n\n")
|
||||
case res of
|
||||
Left e -> throwError e
|
||||
Right d -> return d
|
||||
|
||||
|
||||
type TWParser = Parser [Char] ParserState
|
||||
type TWParser = ParserT [Char] ParserState
|
||||
|
||||
--
|
||||
-- utility functions
|
||||
--
|
||||
|
||||
tryMsg :: String -> TWParser a -> TWParser a
|
||||
tryMsg :: String -> TWParser m a -> TWParser m a
|
||||
tryMsg msg p = try p <?> msg
|
||||
|
||||
skip :: TWParser a -> TWParser ()
|
||||
skip :: TWParser m a -> TWParser m ()
|
||||
skip parser = parser >> return ()
|
||||
|
||||
nested :: TWParser a -> TWParser a
|
||||
nested :: PandocMonad m => TWParser m a -> TWParser m a
|
||||
nested p = do
|
||||
nestlevel <- stateMaxNestingLevel <$> getState
|
||||
guard $ nestlevel > 0
|
||||
@@ -80,7 +79,7 @@ nested p = do
|
||||
updateState $ \st -> st{ stateMaxNestingLevel = nestlevel }
|
||||
return res
|
||||
|
||||
htmlElement :: String -> TWParser (Attr, String)
|
||||
htmlElement :: PandocMonad m => String -> TWParser m (Attr, String)
|
||||
htmlElement tag = tryMsg tag $ do
|
||||
(TagOpen _ attr, _) <- htmlTag (~== TagOpen tag [])
|
||||
content <- manyTill anyChar (endtag <|> endofinput)
|
||||
@@ -97,7 +96,8 @@ htmlAttrToPandoc attrs = (ident, classes, keyvals)
|
||||
classes = maybe [] words $ lookup "class" attrs
|
||||
keyvals = [(k,v) | (k,v) <- attrs, k /= "id" && k /= "class"]
|
||||
|
||||
parseHtmlContentWithAttrs :: String -> TWParser a -> TWParser (Attr, [a])
|
||||
parseHtmlContentWithAttrs :: PandocMonad m
|
||||
=> String -> TWParser m a -> TWParser m (Attr, [a])
|
||||
parseHtmlContentWithAttrs tag parser = do
|
||||
(attr, content) <- htmlElement tag
|
||||
parsedContent <- try $ parseContent content
|
||||
@@ -106,14 +106,14 @@ parseHtmlContentWithAttrs tag parser = do
|
||||
parseContent = parseFromString $ nested $ manyTill parser endOfContent
|
||||
endOfContent = try $ skipMany blankline >> skipSpaces >> eof
|
||||
|
||||
parseHtmlContent :: String -> TWParser a -> TWParser [a]
|
||||
parseHtmlContent :: PandocMonad m => String -> TWParser m a -> TWParser m [a]
|
||||
parseHtmlContent tag p = parseHtmlContentWithAttrs tag p >>= return . snd
|
||||
|
||||
--
|
||||
-- main parser
|
||||
--
|
||||
|
||||
parseTWiki :: TWParser Pandoc
|
||||
parseTWiki :: PandocMonad m => TWParser m Pandoc
|
||||
parseTWiki = do
|
||||
bs <- mconcat <$> many block
|
||||
spaces
|
||||
@@ -125,20 +125,18 @@ parseTWiki = do
|
||||
-- block parsers
|
||||
--
|
||||
|
||||
block :: TWParser B.Blocks
|
||||
block :: PandocMonad m => TWParser m B.Blocks
|
||||
block = do
|
||||
tr <- (== DEBUG) <$> getOption readerVerbosity
|
||||
pos <- getPosition
|
||||
res <- mempty <$ skipMany1 blankline
|
||||
<|> blockElements
|
||||
<|> para
|
||||
skipMany blankline
|
||||
when tr $
|
||||
trace (printf "line %d: %s" (sourceLine pos)
|
||||
(take 60 $ show $ B.toList res)) (return ())
|
||||
report DEBUG $ printf "line %d: %s" (sourceLine pos)
|
||||
(take 60 $ show $ B.toList res)
|
||||
return res
|
||||
|
||||
blockElements :: TWParser B.Blocks
|
||||
blockElements :: PandocMonad m => TWParser m B.Blocks
|
||||
blockElements = choice [ separator
|
||||
, header
|
||||
, verbatim
|
||||
@@ -149,10 +147,10 @@ blockElements = choice [ separator
|
||||
, noautolink
|
||||
]
|
||||
|
||||
separator :: TWParser B.Blocks
|
||||
separator :: PandocMonad m => TWParser m B.Blocks
|
||||
separator = tryMsg "separator" $ string "---" >> newline >> return B.horizontalRule
|
||||
|
||||
header :: TWParser B.Blocks
|
||||
header :: PandocMonad m => TWParser m B.Blocks
|
||||
header = tryMsg "header" $ do
|
||||
string "---"
|
||||
level <- many1 (char '+') >>= return . length
|
||||
@@ -163,43 +161,45 @@ header = tryMsg "header" $ do
|
||||
attr <- registerHeader ("", classes, []) content
|
||||
return $ B.headerWith attr level $ content
|
||||
|
||||
verbatim :: TWParser B.Blocks
|
||||
verbatim :: PandocMonad m => TWParser m B.Blocks
|
||||
verbatim = (htmlElement "verbatim" <|> htmlElement "pre")
|
||||
>>= return . (uncurry B.codeBlockWith)
|
||||
|
||||
literal :: TWParser B.Blocks
|
||||
literal :: PandocMonad m => TWParser m B.Blocks
|
||||
literal = htmlElement "literal" >>= return . rawBlock
|
||||
where
|
||||
format (_, _, kvs) = fromMaybe "html" $ lookup "format" kvs
|
||||
rawBlock (attrs, content) = B.rawBlock (format attrs) content
|
||||
|
||||
list :: String -> TWParser B.Blocks
|
||||
list :: PandocMonad m => String -> TWParser m B.Blocks
|
||||
list prefix = choice [ bulletList prefix
|
||||
, orderedList prefix
|
||||
, definitionList prefix]
|
||||
|
||||
definitionList :: String -> TWParser B.Blocks
|
||||
definitionList :: PandocMonad m => String -> TWParser m B.Blocks
|
||||
definitionList prefix = tryMsg "definitionList" $ do
|
||||
indent <- lookAhead $ string prefix *> (many1 $ string " ") <* string "$ "
|
||||
elements <- many $ parseDefinitionListItem (prefix ++ concat indent)
|
||||
return $ B.definitionList elements
|
||||
where
|
||||
parseDefinitionListItem :: String -> TWParser (B.Inlines, [B.Blocks])
|
||||
parseDefinitionListItem :: PandocMonad m
|
||||
=> String -> TWParser m (B.Inlines, [B.Blocks])
|
||||
parseDefinitionListItem indent = do
|
||||
string (indent ++ "$ ") >> skipSpaces
|
||||
term <- many1Till inline $ string ": "
|
||||
line <- listItemLine indent $ string "$ "
|
||||
return $ (mconcat term, [line])
|
||||
|
||||
bulletList :: String -> TWParser B.Blocks
|
||||
bulletList :: PandocMonad m => String -> TWParser m B.Blocks
|
||||
bulletList prefix = tryMsg "bulletList" $
|
||||
parseList prefix (char '*') (char ' ')
|
||||
|
||||
orderedList :: String -> TWParser B.Blocks
|
||||
orderedList :: PandocMonad m => String -> TWParser m B.Blocks
|
||||
orderedList prefix = tryMsg "orderedList" $
|
||||
parseList prefix (oneOf "1iIaA") (string ". ")
|
||||
|
||||
parseList :: String -> TWParser Char -> TWParser a -> TWParser B.Blocks
|
||||
parseList :: PandocMonad m
|
||||
=> String -> TWParser m Char -> TWParser m a -> TWParser m B.Blocks
|
||||
parseList prefix marker delim = do
|
||||
(indent, style) <- lookAhead $ string prefix *> listStyle <* delim
|
||||
blocks <- many $ parseListItem (prefix ++ indent) (char style <* delim)
|
||||
@@ -216,10 +216,12 @@ parseList prefix marker delim = do
|
||||
style <- marker
|
||||
return (concat indent, style)
|
||||
|
||||
parseListItem :: Show a => String -> TWParser a -> TWParser B.Blocks
|
||||
parseListItem :: (PandocMonad m, Show a)
|
||||
=> String -> TWParser m a -> TWParser m B.Blocks
|
||||
parseListItem prefix marker = string prefix >> marker >> listItemLine prefix marker
|
||||
|
||||
listItemLine :: Show a => String -> TWParser a -> TWParser B.Blocks
|
||||
listItemLine :: (PandocMonad m, Show a)
|
||||
=> String -> TWParser m a -> TWParser m B.Blocks
|
||||
listItemLine prefix marker = lineContent >>= parseContent >>= return . mconcat
|
||||
where
|
||||
lineContent = do
|
||||
@@ -236,7 +238,7 @@ listItemLine prefix marker = lineContent >>= parseContent >>= return . mconcat
|
||||
lastNewline = try $ char '\n' <* eof
|
||||
newlineBeforeNestedList = try $ char '\n' <* lookAhead nestedList
|
||||
|
||||
table :: TWParser B.Blocks
|
||||
table :: PandocMonad m => TWParser m B.Blocks
|
||||
table = try $ do
|
||||
tableHead <- optionMaybe $ many1Till tableParseHeader newline >>= return . unzip
|
||||
rows <- many1 tableParseRow
|
||||
@@ -248,7 +250,7 @@ table = try $ do
|
||||
columns rows = replicate (columCount rows) mempty
|
||||
columCount rows = length $ head rows
|
||||
|
||||
tableParseHeader :: TWParser ((Alignment, Double), B.Blocks)
|
||||
tableParseHeader :: PandocMonad m => TWParser m ((Alignment, Double), B.Blocks)
|
||||
tableParseHeader = try $ do
|
||||
char '|'
|
||||
leftSpaces <- many spaceChar >>= return . length
|
||||
@@ -264,27 +266,27 @@ tableParseHeader = try $ do
|
||||
| left > right = (AlignRight, 0)
|
||||
| otherwise = (AlignLeft, 0)
|
||||
|
||||
tableParseRow :: TWParser [B.Blocks]
|
||||
tableParseRow :: PandocMonad m => TWParser m [B.Blocks]
|
||||
tableParseRow = many1Till tableParseColumn newline
|
||||
|
||||
tableParseColumn :: TWParser B.Blocks
|
||||
tableParseColumn :: PandocMonad m => TWParser m B.Blocks
|
||||
tableParseColumn = char '|' *> skipSpaces *>
|
||||
tableColumnContent (skipSpaces >> char '|')
|
||||
<* skipSpaces <* optional tableEndOfRow
|
||||
|
||||
tableEndOfRow :: TWParser Char
|
||||
tableEndOfRow :: PandocMonad m => TWParser m Char
|
||||
tableEndOfRow = lookAhead (try $ char '|' >> char '\n') >> char '|'
|
||||
|
||||
tableColumnContent :: TWParser a -> TWParser B.Blocks
|
||||
tableColumnContent :: PandocMonad m => TWParser m a -> TWParser m B.Blocks
|
||||
tableColumnContent end = manyTill content (lookAhead $ try end) >>= return . B.plain . mconcat
|
||||
where
|
||||
content = continuation <|> inline
|
||||
continuation = try $ char '\\' >> newline >> return mempty
|
||||
|
||||
blockQuote :: TWParser B.Blocks
|
||||
blockQuote :: PandocMonad m => TWParser m B.Blocks
|
||||
blockQuote = parseHtmlContent "blockquote" block >>= return . B.blockQuote . mconcat
|
||||
|
||||
noautolink :: TWParser B.Blocks
|
||||
noautolink :: PandocMonad m => TWParser m B.Blocks
|
||||
noautolink = do
|
||||
(_, content) <- htmlElement "noautolink"
|
||||
st <- getState
|
||||
@@ -295,7 +297,7 @@ noautolink = do
|
||||
where
|
||||
parseContent = parseFromString $ many $ block
|
||||
|
||||
para :: TWParser B.Blocks
|
||||
para :: PandocMonad m => TWParser m B.Blocks
|
||||
para = many1Till inline endOfParaElement >>= return . result . mconcat
|
||||
where
|
||||
endOfParaElement = lookAhead $ endOfInput <|> endOfPara <|> newBlockElement
|
||||
@@ -311,7 +313,7 @@ para = many1Till inline endOfParaElement >>= return . result . mconcat
|
||||
-- inline parsers
|
||||
--
|
||||
|
||||
inline :: TWParser B.Inlines
|
||||
inline :: PandocMonad m => TWParser m B.Inlines
|
||||
inline = choice [ whitespace
|
||||
, br
|
||||
, macro
|
||||
@@ -332,36 +334,39 @@ inline = choice [ whitespace
|
||||
, symbol
|
||||
] <?> "inline"
|
||||
|
||||
whitespace :: TWParser B.Inlines
|
||||
whitespace :: PandocMonad m => TWParser m B.Inlines
|
||||
whitespace = (lb <|> regsp) >>= return
|
||||
where lb = try $ skipMany spaceChar >> linebreak >> return B.space
|
||||
regsp = try $ skipMany1 spaceChar >> return B.space
|
||||
|
||||
br :: TWParser B.Inlines
|
||||
br :: PandocMonad m => TWParser m B.Inlines
|
||||
br = try $ string "%BR%" >> return B.linebreak
|
||||
|
||||
linebreak :: TWParser B.Inlines
|
||||
linebreak :: PandocMonad m => TWParser m B.Inlines
|
||||
linebreak = newline >> notFollowedBy newline >> (lastNewline <|> innerNewline)
|
||||
where lastNewline = eof >> return mempty
|
||||
innerNewline = return B.space
|
||||
|
||||
between :: (Monoid c) => TWParser a -> TWParser b -> (TWParser b -> TWParser c) -> TWParser c
|
||||
between :: (Monoid c, PandocMonad m)
|
||||
=> TWParser m a -> TWParser m b -> (TWParser m b -> TWParser m c)
|
||||
-> TWParser m c
|
||||
between start end p =
|
||||
mconcat <$> try (start >> notFollowedBy whitespace >> many1Till (p end) end)
|
||||
|
||||
enclosed :: (Monoid b) => TWParser a -> (TWParser a -> TWParser b) -> TWParser b
|
||||
enclosed :: (Monoid b, PandocMonad m)
|
||||
=> TWParser m a -> (TWParser m a -> TWParser m b) -> TWParser m b
|
||||
enclosed sep p = between sep (try $ sep <* endMarker) p
|
||||
where
|
||||
endMarker = lookAhead $ skip endSpace <|> skip (oneOf ".,!?:)|") <|> eof
|
||||
endSpace = (spaceChar <|> newline) >> return B.space
|
||||
|
||||
macro :: TWParser B.Inlines
|
||||
macro :: PandocMonad m => TWParser m B.Inlines
|
||||
macro = macroWithParameters <|> withoutParameters
|
||||
where
|
||||
withoutParameters = enclosed (char '%') (\_ -> macroName) >>= return . emptySpan
|
||||
emptySpan name = buildSpan name [] mempty
|
||||
|
||||
macroWithParameters :: TWParser B.Inlines
|
||||
macroWithParameters :: PandocMonad m => TWParser m B.Inlines
|
||||
macroWithParameters = try $ do
|
||||
char '%'
|
||||
name <- macroName
|
||||
@@ -376,13 +381,13 @@ buildSpan className kvs = B.spanWith attrs
|
||||
additionalClasses = maybe [] words $ lookup "class" kvs
|
||||
kvsWithoutClasses = [(k,v) | (k,v) <- kvs, k /= "class"]
|
||||
|
||||
macroName :: TWParser String
|
||||
macroName :: PandocMonad m => TWParser m String
|
||||
macroName = do
|
||||
first <- letter
|
||||
rest <- many $ alphaNum <|> char '_'
|
||||
return (first:rest)
|
||||
|
||||
attributes :: TWParser (String, [(String, String)])
|
||||
attributes :: PandocMonad m => TWParser m (String, [(String, String)])
|
||||
attributes = char '{' *> spnl *> many (attribute <* spnl) <* char '}' >>=
|
||||
return . foldr (either mkContent mkKvs) ([], [])
|
||||
where
|
||||
@@ -391,7 +396,7 @@ attributes = char '{' *> spnl *> many (attribute <* spnl) <* char '}' >>=
|
||||
mkContent c (rest, kvs) = (c ++ " " ++ rest, kvs)
|
||||
mkKvs kv (cont, rest) = (cont, (kv : rest))
|
||||
|
||||
attribute :: TWParser (Either String (String, String))
|
||||
attribute :: PandocMonad m => TWParser m (Either String (String, String))
|
||||
attribute = withKey <|> withoutKey
|
||||
where
|
||||
withKey = try $ do
|
||||
@@ -405,49 +410,51 @@ attribute = withKey <|> withoutKey
|
||||
| allowSpaces == True = many1 $ noneOf "}"
|
||||
| otherwise = many1 $ noneOf " }"
|
||||
|
||||
nestedInlines :: Show a => TWParser a -> TWParser B.Inlines
|
||||
nestedInlines :: (Show a, PandocMonad m)
|
||||
=> TWParser m a -> TWParser m B.Inlines
|
||||
nestedInlines end = innerSpace <|> nestedInline
|
||||
where
|
||||
innerSpace = try $ whitespace <* (notFollowedBy end)
|
||||
nestedInline = notFollowedBy whitespace >> nested inline
|
||||
|
||||
strong :: TWParser B.Inlines
|
||||
strong :: PandocMonad m => TWParser m B.Inlines
|
||||
strong = try $ enclosed (char '*') nestedInlines >>= return . B.strong
|
||||
|
||||
strongHtml :: TWParser B.Inlines
|
||||
strongHtml :: PandocMonad m => TWParser m B.Inlines
|
||||
strongHtml = (parseHtmlContent "strong" inline <|> parseHtmlContent "b" inline)
|
||||
>>= return . B.strong . mconcat
|
||||
|
||||
strongAndEmph :: TWParser B.Inlines
|
||||
strongAndEmph :: PandocMonad m => TWParser m B.Inlines
|
||||
strongAndEmph = try $ enclosed (string "__") nestedInlines >>= return . B.emph . B.strong
|
||||
|
||||
emph :: TWParser B.Inlines
|
||||
emph :: PandocMonad m => TWParser m B.Inlines
|
||||
emph = try $ enclosed (char '_') nestedInlines >>= return . B.emph
|
||||
|
||||
emphHtml :: TWParser B.Inlines
|
||||
emphHtml :: PandocMonad m => TWParser m B.Inlines
|
||||
emphHtml = (parseHtmlContent "em" inline <|> parseHtmlContent "i" inline)
|
||||
>>= return . B.emph . mconcat
|
||||
|
||||
nestedString :: Show a => TWParser a -> TWParser String
|
||||
nestedString :: (Show a, PandocMonad m)
|
||||
=> TWParser m a -> TWParser m String
|
||||
nestedString end = innerSpace <|> (count 1 nonspaceChar)
|
||||
where
|
||||
innerSpace = try $ many1 spaceChar <* notFollowedBy end
|
||||
|
||||
boldCode :: TWParser B.Inlines
|
||||
boldCode :: PandocMonad m => TWParser m B.Inlines
|
||||
boldCode = try $ enclosed (string "==") nestedString >>= return . B.strong . B.code . fromEntities
|
||||
|
||||
htmlComment :: TWParser B.Inlines
|
||||
htmlComment :: PandocMonad m => TWParser m B.Inlines
|
||||
htmlComment = htmlTag isCommentTag >> return mempty
|
||||
|
||||
code :: TWParser B.Inlines
|
||||
code :: PandocMonad m => TWParser m B.Inlines
|
||||
code = try $ enclosed (char '=') nestedString >>= return . B.code . fromEntities
|
||||
|
||||
codeHtml :: TWParser B.Inlines
|
||||
codeHtml :: PandocMonad m => TWParser m B.Inlines
|
||||
codeHtml = do
|
||||
(attrs, content) <- parseHtmlContentWithAttrs "code" anyChar
|
||||
return $ B.codeWith attrs $ fromEntities content
|
||||
|
||||
autoLink :: TWParser B.Inlines
|
||||
autoLink :: PandocMonad m => TWParser m B.Inlines
|
||||
autoLink = try $ do
|
||||
state <- getState
|
||||
guard $ stateAllowLinks state
|
||||
@@ -461,20 +468,20 @@ autoLink = try $ do
|
||||
| c == '/' = True
|
||||
| otherwise = isAlphaNum c
|
||||
|
||||
str :: TWParser B.Inlines
|
||||
str :: PandocMonad m => TWParser m B.Inlines
|
||||
str = (many1 alphaNum <|> count 1 characterReference) >>= return . B.str
|
||||
|
||||
nop :: TWParser B.Inlines
|
||||
nop :: PandocMonad m => TWParser m B.Inlines
|
||||
nop = try $ (skip exclamation <|> skip nopTag) >> followContent
|
||||
where
|
||||
exclamation = char '!'
|
||||
nopTag = stringAnyCase "<nop>"
|
||||
followContent = many1 nonspaceChar >>= return . B.str . fromEntities
|
||||
|
||||
symbol :: TWParser B.Inlines
|
||||
symbol :: PandocMonad m => TWParser m B.Inlines
|
||||
symbol = count 1 nonspaceChar >>= return . B.str
|
||||
|
||||
smart :: TWParser B.Inlines
|
||||
smart :: PandocMonad m => TWParser m B.Inlines
|
||||
smart = do
|
||||
guardEnabled Ext_smart
|
||||
doubleQuoted <|> singleQuoted <|>
|
||||
@@ -483,14 +490,14 @@ smart = do
|
||||
, ellipses
|
||||
]
|
||||
|
||||
singleQuoted :: TWParser B.Inlines
|
||||
singleQuoted :: PandocMonad m => TWParser m B.Inlines
|
||||
singleQuoted = try $ do
|
||||
singleQuoteStart
|
||||
withQuoteContext InSingleQuote $
|
||||
many1Till inline singleQuoteEnd >>=
|
||||
(return . B.singleQuoted . B.trimInlines . mconcat)
|
||||
|
||||
doubleQuoted :: TWParser B.Inlines
|
||||
doubleQuoted :: PandocMonad m => TWParser m B.Inlines
|
||||
doubleQuoted = try $ do
|
||||
doubleQuoteStart
|
||||
contents <- mconcat <$> many (try $ notFollowedBy doubleQuoteEnd >> inline)
|
||||
@@ -498,7 +505,7 @@ doubleQuoted = try $ do
|
||||
return (B.doubleQuoted $ B.trimInlines contents))
|
||||
<|> (return $ (B.str "\8220") B.<> contents)
|
||||
|
||||
link :: TWParser B.Inlines
|
||||
link :: PandocMonad m => TWParser m B.Inlines
|
||||
link = try $ do
|
||||
st <- getState
|
||||
guard $ stateAllowLinks st
|
||||
@@ -507,7 +514,7 @@ link = try $ do
|
||||
setState $ st{ stateAllowLinks = True }
|
||||
return $ B.link url title content
|
||||
|
||||
linkText :: TWParser (String, String, B.Inlines)
|
||||
linkText :: PandocMonad m => TWParser m (String, String, B.Inlines)
|
||||
linkText = do
|
||||
string "[["
|
||||
url <- many1Till anyChar (char ']')
|
||||
|
||||
@@ -64,11 +64,10 @@ import Text.HTML.TagSoup (fromAttrib, Tag(..))
|
||||
import Text.HTML.TagSoup.Match
|
||||
import Data.List ( intercalate, transpose, intersperse )
|
||||
import Data.Char ( digitToInt, isUpper )
|
||||
import Control.Monad ( guard, liftM, when )
|
||||
import Control.Monad ( guard, liftM )
|
||||
import Data.Monoid ((<>))
|
||||
import Text.Printf
|
||||
import Debug.Trace (trace)
|
||||
import Text.Pandoc.Class (PandocMonad)
|
||||
import Text.Pandoc.Class (PandocMonad, report)
|
||||
import Control.Monad.Except (throwError)
|
||||
|
||||
-- | Parse a Textile text and return a Pandoc document.
|
||||
@@ -147,10 +146,8 @@ block :: PandocMonad m => ParserT [Char] ParserState m Blocks
|
||||
block = do
|
||||
res <- choice blockParsers <?> "block"
|
||||
pos <- getPosition
|
||||
tr <- (== DEBUG) <$> getOption readerVerbosity
|
||||
when tr $
|
||||
trace (printf "line %d: %s" (sourceLine pos)
|
||||
(take 60 $ show $ B.toList res)) (return ())
|
||||
report DEBUG $ printf "line %d: %s" (sourceLine pos)
|
||||
(take 60 $ show $ B.toList res)
|
||||
return res
|
||||
|
||||
commentBlock :: PandocMonad m => ParserT [Char] ParserState m Blocks
|
||||
|
||||
Reference in New Issue
Block a user