diff options
| -rw-r--r-- | pandoc.hs | 19 | ||||
| -rw-r--r-- | src/Text/Pandoc/Class.hs | 45 | ||||
| -rw-r--r-- | src/Text/Pandoc/Readers/HTML.hs | 14 | ||||
| -rw-r--r-- | src/Text/Pandoc/Readers/Markdown.hs | 10 | ||||
| -rw-r--r-- | src/Text/Pandoc/Readers/MediaWiki.hs | 9 | ||||
| -rw-r--r-- | src/Text/Pandoc/Readers/TWiki.hs | 149 | ||||
| -rw-r--r-- | src/Text/Pandoc/Readers/Textile.hs | 11 |
7 files changed, 124 insertions, 133 deletions
@@ -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 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 diff --git a/src/Text/Pandoc/Readers/HTML.hs b/src/Text/Pandoc/Readers/HTML.hs index d602f7303..0bb837ba9 100644 --- a/src/Text/Pandoc/Readers/HTML.hs +++ b/src/Text/Pandoc/Readers/HTML.hs @@ -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)] diff --git a/src/Text/Pandoc/Readers/Markdown.hs b/src/Text/Pandoc/Readers/Markdown.hs index e0036f708..5052f52bf 100644 --- a/src/Text/Pandoc/Readers/Markdown.hs +++ b/src/Text/Pandoc/Readers/Markdown.hs @@ -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 -- diff --git a/src/Text/Pandoc/Readers/MediaWiki.hs b/src/Text/Pandoc/Readers/MediaWiki.hs index 38a9e3f4f..b81d0f3e4 100644 --- a/src/Text/Pandoc/Readers/MediaWiki.hs +++ b/src/Text/Pandoc/Readers/MediaWiki.hs @@ -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 diff --git a/src/Text/Pandoc/Readers/TWiki.hs b/src/Text/Pandoc/Readers/TWiki.hs index b54eec735..1a827bcd9 100644 --- a/src/Text/Pandoc/Readers/TWiki.hs +++ b/src/Text/Pandoc/Readers/TWiki.hs @@ -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 ']') diff --git a/src/Text/Pandoc/Readers/Textile.hs b/src/Text/Pandoc/Readers/Textile.hs index b3a1a208f..804ee39aa 100644 --- a/src/Text/Pandoc/Readers/Textile.hs +++ b/src/Text/Pandoc/Readers/Textile.hs @@ -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 |