aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/Text/Pandoc/Readers/HTML.hs331
1 files changed, 194 insertions, 137 deletions
diff --git a/src/Text/Pandoc/Readers/HTML.hs b/src/Text/Pandoc/Readers/HTML.hs
index 3bccf89fb..94f933c4d 100644
--- a/src/Text/Pandoc/Readers/HTML.hs
+++ b/src/Text/Pandoc/Readers/HTML.hs
@@ -1,5 +1,5 @@
{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses,
-ViewPatterns#-}
+ViewPatterns, OverloadedStrings #-}
{-
Copyright (C) 2006-2017 John MacFarlane <jgm@berkeley.edu>
@@ -34,6 +34,7 @@ module Text.Pandoc.Readers.HTML ( readHtml
, htmlInBalanced
, isInlineTag
, isBlockTag
+ , NamedTag(..)
, isTextTag
, isCommentTag
) where
@@ -43,7 +44,7 @@ import Text.HTML.TagSoup.Match
import Text.Pandoc.Definition
import qualified Text.Pandoc.Builder as B
import Text.Pandoc.Builder (Blocks, Inlines, trimInlines, HasMeta(..))
-import Text.Pandoc.Shared ( extractSpaces, renderTags', addMetaField
+import Text.Pandoc.Shared ( extractSpaces, addMetaField
, escapeURI, safeRead )
import Text.Pandoc.Options (ReaderOptions(readerExtensions), extensionEnabled,
Extension (Ext_epub_html_exts,
@@ -53,13 +54,14 @@ import Text.Pandoc.Parsing hiding ((<|>))
import Text.Pandoc.Walk
import qualified Data.Map as M
import Data.Maybe ( fromMaybe, isJust)
-import Data.List ( intercalate, isInfixOf, isPrefixOf )
+import Data.List ( intercalate, isPrefixOf )
import Data.Char ( isDigit, isLetter, isAlphaNum )
import Control.Monad ( guard, mzero, void, unless )
import Control.Arrow ((***))
import Control.Applicative ( (<|>) )
import Data.Monoid (First (..))
-import Data.Text (Text, unpack)
+import Data.Text (Text)
+import qualified Data.Text as T
import Text.TeXMath (readMathML, writeTeX)
import Data.Default (Default (..), def)
import Control.Monad.Reader (ask, asks, local, ReaderT, runReaderT, lift)
@@ -80,7 +82,7 @@ readHtml :: PandocMonad m
readHtml opts inp = do
let tags = stripPrefixes . canonicalizeTags $
parseTagsOptions parseOptions{ optTagPosition = True }
- (unpack inp)
+ inp
parseDoc = do
blocks <- (fixPlains False) . mconcat <$> manyTill block eof
meta <- stateMeta . parserState <$> getState
@@ -130,7 +132,7 @@ setInPlain = local (\s -> s {inPlain = True})
type HTMLParser m s = ParserT s HTMLState (ReaderT HTMLLocal m)
-type TagParser m = HTMLParser m [Tag String]
+type TagParser m = HTMLParser m [Tag Text]
pBody :: PandocMonad m => TagParser m Blocks
pBody = pInTags "body" block
@@ -140,12 +142,12 @@ pHead = pInTags "head" $ pTitle <|> pMetaTag <|> pBaseTag <|> (mempty <$ pAnyTag
where pTitle = pInTags "title" inline >>= setTitle . trimInlines
setTitle t = mempty <$ (updateState $ B.setMeta "title" t)
pMetaTag = do
- mt <- pSatisfy (~== TagOpen "meta" [])
- let name = fromAttrib "name" mt
+ mt <- pSatisfy (matchTagOpen "meta" [])
+ let name = T.unpack $ fromAttrib "name" mt
if null name
then return mempty
else do
- let content = fromAttrib "content" mt
+ let content = T.unpack $ fromAttrib "content" mt
updateState $ \s ->
let ps = parserState s in
s{ parserState = ps{
@@ -153,9 +155,9 @@ pHead = pInTags "head" $ pTitle <|> pMetaTag <|> pBaseTag <|> (mempty <$ pAnyTag
(stateMeta ps) } }
return mempty
pBaseTag = do
- bt <- pSatisfy (~== TagOpen "base" [])
+ bt <- pSatisfy (matchTagOpen "base" [])
updateState $ \st -> st{ baseHref =
- parseURIReference $ fromAttrib "href" bt }
+ parseURIReference $ T.unpack $ fromAttrib "href" bt }
return mempty
block :: PandocMonad m => TagParser m Blocks
@@ -195,29 +197,31 @@ eSwitch :: (PandocMonad m, Monoid a)
-> TagParser m a
eSwitch constructor parser = try $ do
guardEnabled Ext_epub_html_exts
- pSatisfy (~== TagOpen "switch" [])
+ pSatisfy (matchTagOpen "switch" [])
cases <- getFirst . mconcat <$>
manyTill (First <$> (eCase <* skipMany pBlank) )
- (lookAhead $ try $ pSatisfy (~== TagOpen "default" []))
+ (lookAhead $ try $ pSatisfy (matchTagOpen "default" []))
skipMany pBlank
fallback <- pInTags "default" (skipMany pBlank *> parser <* skipMany pBlank)
skipMany pBlank
- pSatisfy (~== TagClose "switch")
+ pSatisfy (matchTagClose "switch")
return $ maybe fallback constructor cases
eCase :: PandocMonad m => TagParser m (Maybe Inlines)
eCase = do
skipMany pBlank
- TagOpen _ attr <- lookAhead $ pSatisfy $ (~== TagOpen "case" [])
+ TagOpen _ attr' <- lookAhead $ pSatisfy $ (matchTagOpen "case" [])
+ let attr = toStringAttr attr'
case (flip lookup namespaces) =<< lookup "required-namespace" attr of
Just p -> Just <$> (pInTags "case" (skipMany pBlank *> p <* skipMany pBlank))
- Nothing -> Nothing <$ manyTill pAnyTag (pSatisfy (~== TagClose "case"))
+ Nothing -> Nothing <$ manyTill pAnyTag (pSatisfy (matchTagClose "case"))
eFootnote :: PandocMonad m => TagParser m ()
eFootnote = try $ do
let notes = ["footnote", "rearnote"]
guardEnabled Ext_epub_html_exts
- (TagOpen tag attr) <- lookAhead $ pAnyTag
+ (TagOpen tag attr') <- lookAhead $ pAnyTag
+ let attr = toStringAttr attr'
guard (maybe False (flip elem notes) (lookup "type" attr))
let ident = fromMaybe "" (lookup "id" attr)
content <- pInTags tag block
@@ -229,7 +233,8 @@ addNote uid cont = updateState (\s -> s {noteTable = (uid, cont) : (noteTable s)
eNoteref :: PandocMonad m => TagParser m Inlines
eNoteref = try $ do
guardEnabled Ext_epub_html_exts
- TagOpen tag attr <- lookAhead $ pAnyTag
+ TagOpen tag attr' <- lookAhead $ pAnyTag
+ let attr = toStringAttr attr'
guard (maybe False (== "noteref") (lookup "type" attr))
let ident = maybe "" (dropWhile (== '#')) (lookup "href" attr)
guard (not (null ident))
@@ -249,10 +254,10 @@ pList = pBulletList <|> pOrderedList <|> pDefinitionList
pBulletList :: PandocMonad m => TagParser m Blocks
pBulletList = try $ do
- pSatisfy (~== TagOpen "ul" [])
+ pSatisfy (matchTagOpen "ul" [])
let nonItem = pSatisfy (\t ->
not (tagOpen (`elem` ["li","ol","ul","dl"]) (const True) t) &&
- not (t ~== TagClose "ul"))
+ not (matchTagClose "ul" t))
-- note: if they have an <ol> or <ul> not in scope of a <li>,
-- treat it as a list item, though it's not valid xhtml...
skipMany nonItem
@@ -261,7 +266,8 @@ pBulletList = try $ do
pListItem :: PandocMonad m => TagParser m a -> TagParser m Blocks
pListItem nonItem = do
- TagOpen _ attr <- lookAhead $ pSatisfy (~== TagOpen "li" [])
+ TagOpen _ attr' <- lookAhead $ pSatisfy (matchTagOpen "li" [])
+ let attr = toStringAttr attr'
let addId ident bs = case B.toList bs of
(Plain ils:xs) -> B.fromList (Plain
[Span (ident, [], []) ils] : xs)
@@ -287,7 +293,8 @@ parseTypeAttr _ = DefaultStyle
pOrderedList :: PandocMonad m => TagParser m Blocks
pOrderedList = try $ do
- TagOpen _ attribs <- pSatisfy (~== TagOpen "ol" [])
+ TagOpen _ attribs' <- pSatisfy (matchTagOpen "ol" [])
+ let attribs = toStringAttr attribs'
let (start, style) = (sta', sty')
where sta = fromMaybe "1" $
lookup "start" attribs
@@ -309,7 +316,7 @@ pOrderedList = try $ do
]
let nonItem = pSatisfy (\t ->
not (tagOpen (`elem` ["li","ol","ul","dl"]) (const True) t) &&
- not (t ~== TagClose "ol"))
+ not (matchTagClose "ol" t))
-- note: if they have an <ol> or <ul> not in scope of a <li>,
-- treat it as a list item, though it's not valid xhtml...
skipMany nonItem
@@ -318,14 +325,14 @@ pOrderedList = try $ do
pDefinitionList :: PandocMonad m => TagParser m Blocks
pDefinitionList = try $ do
- pSatisfy (~== TagOpen "dl" [])
+ pSatisfy (matchTagOpen "dl" [])
items <- manyTill pDefListItem (pCloses "dl")
return $ B.definitionList items
pDefListItem :: PandocMonad m => TagParser m (Inlines, [Blocks])
pDefListItem = try $ do
- let nonItem = pSatisfy (\t -> not (t ~== TagOpen "dt" []) &&
- not (t ~== TagOpen "dd" []) && not (t ~== TagClose "dl"))
+ let nonItem = pSatisfy (\t -> not (matchTagOpen "dt" [] t) &&
+ not (matchTagOpen "dd" [] t) && not (matchTagClose "dl" t))
terms <- many1 (try $ skipMany nonItem >> pInTags "dt" inline)
defs <- many1 (try $ skipMany nonItem >> pInTags "dd" block)
skipMany nonItem
@@ -348,12 +355,12 @@ fixPlains inList bs = if any isParaish bs'
plainToPara x = x
bs' = B.toList bs
-pRawTag :: PandocMonad m => TagParser m String
+pRawTag :: PandocMonad m => TagParser m Text
pRawTag = do
tag <- pAnyTag
let ignorable x = x `elem` ["html","head","body","!DOCTYPE","?xml"]
if tagOpen ignorable (const True) tag || tagClose ignorable tag
- then return []
+ then return mempty
else return $ renderTags' [tag]
pDiv :: PandocMonad m => TagParser m Blocks
@@ -362,7 +369,8 @@ pDiv = try $ do
let isDivLike "div" = True
isDivLike "section" = True
isDivLike _ = False
- TagOpen tag attr <- lookAhead $ pSatisfy $ tagOpen isDivLike (const True)
+ TagOpen tag attr' <- lookAhead $ pSatisfy $ tagOpen isDivLike (const True)
+ let attr = toStringAttr attr'
contents <- pInTags tag block
let (ident, classes, kvs) = mkAttr attr
let classes' = if tag == "section"
@@ -372,7 +380,7 @@ pDiv = try $ do
pRawHtmlBlock :: PandocMonad m => TagParser m Blocks
pRawHtmlBlock = do
- raw <- pHtmlBlock "script" <|> pHtmlBlock "style" <|> pRawTag
+ raw <- T.unpack <$> (pHtmlBlock "script" <|> pHtmlBlock "style" <|> pRawTag)
exts <- getOption readerExtensions
if extensionEnabled Ext_raw_html exts && not (null raw)
then return $ B.rawBlock "html" raw
@@ -387,33 +395,35 @@ ignore raw = do
logMessage $ SkippedContent raw pos
return mempty
-pHtmlBlock :: PandocMonad m => String -> TagParser m String
+pHtmlBlock :: PandocMonad m => Text -> TagParser m Text
pHtmlBlock t = try $ do
- open <- pSatisfy (~== TagOpen t [])
- contents <- manyTill pAnyTag (pSatisfy (~== TagClose t))
- return $ renderTags' $ [open] ++ contents ++ [TagClose t]
+ open <- pSatisfy (matchTagOpen t [])
+ contents <- manyTill pAnyTag (pSatisfy (matchTagClose t))
+ return $ renderTags' $ [open] <> contents <> [TagClose t]
-- Sets chapter context
eSection :: PandocMonad m => TagParser m Blocks
eSection = try $ do
- let matchChapter as = maybe False (isInfixOf "chapter") (lookup "type" as)
+ let matchChapter as = maybe False (T.isInfixOf "chapter") (lookup "type" as)
let sectTag = tagOpen (`elem` sectioningContent) matchChapter
TagOpen tag _ <- lookAhead $ pSatisfy sectTag
setInChapter (pInTags tag block)
-headerLevel :: PandocMonad m => String -> TagParser m Int
+headerLevel :: PandocMonad m => Text -> TagParser m Int
headerLevel tagtype = do
- let level = read (drop 1 tagtype)
- (try $ do
- guardEnabled Ext_epub_html_exts
- asks inChapter >>= guard
- return (level - 1))
- <|>
- return level
+ case safeRead (T.unpack (T.drop 1 tagtype)) of
+ Just level ->
+ (try $ do
+ guardEnabled Ext_epub_html_exts
+ asks inChapter >>= guard
+ return (level - 1))
+ <|>
+ return level
+ Nothing -> fail "Could not retrieve header level"
eTitlePage :: PandocMonad m => TagParser m ()
eTitlePage = try $ do
- let isTitlePage as = maybe False (isInfixOf "titlepage") (lookup "type" as)
+ let isTitlePage as = maybe False (T.isInfixOf "titlepage") (lookup "type" as)
let groupTag = tagOpen (\x -> x `elem` groupingContent || x == "section")
isTitlePage
TagOpen tag _ <- lookAhead $ pSatisfy groupTag
@@ -421,19 +431,21 @@ eTitlePage = try $ do
pHeader :: PandocMonad m => TagParser m Blocks
pHeader = try $ do
- TagOpen tagtype attr <- pSatisfy $
+ TagOpen tagtype attr' <- pSatisfy $
tagOpen (`elem` ["h1","h2","h3","h4","h5","h6"])
(const True)
- let bodyTitle = TagOpen tagtype attr ~== TagOpen "h1" [("class","title")]
+ let attr = toStringAttr attr'
+ let bodyTitle = TagOpen tagtype attr' ~== TagOpen ("h1" :: Text)
+ [("class","title")]
level <- headerLevel tagtype
contents <- trimInlines . mconcat <$> manyTill inline (pCloses tagtype <|> eof)
let ident = fromMaybe "" $ lookup "id" attr
let classes = maybe [] words $ lookup "class" attr
let keyvals = [(k,v) | (k,v) <- attr, k /= "class", k /= "id"]
- attr' <- registerHeader (ident, classes, keyvals) contents
+ attr'' <- registerHeader (ident, classes, keyvals) contents
return $ if bodyTitle
then mempty -- skip a representation of the title in the body
- else B.headerWith attr' level contents
+ else B.headerWith attr'' level contents
pHrule :: PandocMonad m => TagParser m Blocks
pHrule = do
@@ -442,7 +454,7 @@ pHrule = do
pTable :: PandocMonad m => TagParser m Blocks
pTable = try $ do
- TagOpen _ _ <- pSatisfy (~== TagOpen "table" [])
+ TagOpen _ _ <- pSatisfy (matchTagOpen "table" [])
skipMany pBlank
caption <- option mempty $ pInTags "caption" inline <* skipMany pBlank
widths' <- (mconcat <$> many1 pColgroup) <|> many pCol
@@ -456,8 +468,8 @@ pTable = try $ do
else return head''
rowsLs <- many pTBody
rows' <- pOptInTag "tfoot" $ many pTr
- TagClose _ <- pSatisfy (~== TagClose "table")
- let rows'' = (concat rowsLs) ++ rows'
+ TagClose _ <- pSatisfy (matchTagClose "table")
+ let rows'' = (concat rowsLs) <> rows'
-- fail on empty table
guard $ not $ null head' && null rows''
let isSinglePlain x = case B.toList x of
@@ -468,7 +480,7 @@ pTable = try $ do
let cols = length $ if null head' then head rows'' else head'
-- add empty cells to short rows
let addEmpties r = case cols - length r of
- n | n > 0 -> r ++ replicate n mempty
+ n | n > 0 -> r <> replicate n mempty
| otherwise -> r
let rows = map addEmpties rows''
let aligns = replicate cols AlignDefault
@@ -481,15 +493,16 @@ pTable = try $ do
pCol :: PandocMonad m => TagParser m Double
pCol = try $ do
- TagOpen _ attribs <- pSatisfy (~== TagOpen "col" [])
+ TagOpen _ attribs' <- pSatisfy (matchTagOpen "col" [])
+ let attribs = toStringAttr attribs'
skipMany pBlank
- optional $ pSatisfy (~== TagClose "col")
+ optional $ pSatisfy (matchTagClose "col")
skipMany pBlank
return $ case lookup "width" attribs of
Nothing -> case lookup "style" attribs of
Just ('w':'i':'d':'t':'h':':':xs) | '%' `elem` xs ->
fromMaybe 0.0 $ safeRead ('0':'.':filter
- (`notElem` " \t\r\n%'\";") xs)
+ (`notElem` (" \t\r\n%'\";" :: [Char])) xs)
_ -> 0.0
Just x | not (null x) && last x == '%' ->
fromMaybe 0.0 $ safeRead ('0':'.':init x)
@@ -497,18 +510,18 @@ pCol = try $ do
pColgroup :: PandocMonad m => TagParser m [Double]
pColgroup = try $ do
- pSatisfy (~== TagOpen "colgroup" [])
+ pSatisfy (matchTagOpen "colgroup" [])
skipMany pBlank
manyTill pCol (pCloses "colgroup" <|> eof) <* skipMany pBlank
-noColOrRowSpans :: Tag String -> Bool
+noColOrRowSpans :: Tag Text -> Bool
noColOrRowSpans t = isNullOrOne "colspan" && isNullOrOne "rowspan"
where isNullOrOne x = case fromAttrib x t of
"" -> True
"1" -> True
_ -> False
-pCell :: PandocMonad m => String -> TagParser m [Blocks]
+pCell :: PandocMonad m => Text -> TagParser m [Blocks]
pCell celltype = try $ do
skipMany pBlank
res <- pInTags' celltype noColOrRowSpans block
@@ -534,7 +547,8 @@ pPara = do
pCodeBlock :: PandocMonad m => TagParser m Blocks
pCodeBlock = try $ do
- TagOpen _ attr <- pSatisfy (~== TagOpen "pre" [])
+ TagOpen _ attr' <- pSatisfy (matchTagOpen "pre" [])
+ let attr = toStringAttr attr'
contents <- manyTill pAnyTag (pCloses "pre" <|> eof)
let rawText = concatMap tagToString contents
-- drop leading newline if any
@@ -547,8 +561,8 @@ pCodeBlock = try $ do
_ -> result'
return $ B.codeBlockWith (mkAttr attr) result
-tagToString :: Tag String -> String
-tagToString (TagText s) = s
+tagToString :: Tag Text -> String
+tagToString (TagText s) = T.unpack s
tagToString (TagOpen "br" _) = "\n"
tagToString _ = ""
@@ -577,20 +591,20 @@ pLocation = do
(TagPosition r c) <- pSat isTagPosition
setPosition $ newPos "input" r c
-pSat :: PandocMonad m => (Tag String -> Bool) -> TagParser m (Tag String)
+pSat :: PandocMonad m => (Tag Text -> Bool) -> TagParser m (Tag Text)
pSat f = do
pos <- getPosition
token show (const pos) (\x -> if f x then Just x else Nothing)
-pSatisfy :: PandocMonad m => (Tag String -> Bool) -> TagParser m (Tag String)
+pSatisfy :: PandocMonad m => (Tag Text -> Bool) -> TagParser m (Tag Text)
pSatisfy f = try $ optional pLocation >> pSat f
-pAnyTag :: PandocMonad m => TagParser m (Tag String)
+pAnyTag :: PandocMonad m => TagParser m (Tag Text)
pAnyTag = pSatisfy (const True)
pSelfClosing :: PandocMonad m
- => (String -> Bool) -> ([Attribute String] -> Bool)
- -> TagParser m (Tag String)
+ => (Text -> Bool) -> ([Attribute Text] -> Bool)
+ -> TagParser m (Tag Text)
pSelfClosing f g = do
open <- pSatisfy (tagOpen f g)
optional $ pSatisfy (tagClose f)
@@ -628,7 +642,7 @@ pStrikeout = do
pInlinesInTags "s" B.strikeout <|>
pInlinesInTags "strike" B.strikeout <|>
pInlinesInTags "del" B.strikeout <|>
- try (do pSatisfy (~== TagOpen "span" [("class","strikeout")])
+ try (do pSatisfy (matchTagOpen "span" [("class","strikeout")])
contents <- mconcat <$> manyTill inline (pCloses "span")
return $ B.strikeout contents)
@@ -639,17 +653,19 @@ pLineBreak = do
-- Unlike fromAttrib from tagsoup, this distinguishes
-- between a missing attribute and an attribute with empty content.
-maybeFromAttrib :: String -> Tag String -> Maybe String
-maybeFromAttrib name (TagOpen _ attrs) = lookup name attrs
+maybeFromAttrib :: String -> Tag Text -> Maybe String
+maybeFromAttrib name (TagOpen _ attrs) =
+ T.unpack <$> lookup (T.pack name) attrs
maybeFromAttrib _ _ = Nothing
pLink :: PandocMonad m => TagParser m Inlines
pLink = try $ do
tag <- pSatisfy $ tagOpenLit "a" (const True)
- let title = fromAttrib "title" tag
+ let title = T.unpack $ fromAttrib "title" tag
-- take id from id attribute if present, otherwise name
- let uid = maybe (fromAttrib "name" tag) id $ maybeFromAttrib "id" tag
- let cls = words $ fromAttrib "class" tag
+ let uid = maybe (T.unpack $ fromAttrib "name" tag) id $
+ maybeFromAttrib "id" tag
+ let cls = words $ T.unpack $ fromAttrib "class" tag
lab <- trimInlines . mconcat <$> manyTill inline (pCloses "a")
-- check for href; if href, then a link, otherwise a span
case maybeFromAttrib "href" tag of
@@ -667,30 +683,33 @@ pImage :: PandocMonad m => TagParser m Inlines
pImage = do
tag <- pSelfClosing (=="img") (isJust . lookup "src")
mbBaseHref <- baseHref <$> getState
- let url' = fromAttrib "src" tag
+ let url' = T.unpack $ fromAttrib "src" tag
let url = case (parseURIReference url', mbBaseHref) of
(Just rel, Just bs) -> show (rel `nonStrictRelativeTo` bs)
_ -> url'
- let title = fromAttrib "title" tag
- let alt = fromAttrib "alt" tag
- let uid = fromAttrib "id" tag
- let cls = words $ fromAttrib "class" tag
+ let title = T.unpack $ fromAttrib "title" tag
+ let alt = T.unpack $ fromAttrib "alt" tag
+ let uid = T.unpack $ fromAttrib "id" tag
+ let cls = words $ T.unpack $ fromAttrib "class" tag
let getAtt k = case fromAttrib k tag of
"" -> []
- v -> [(k, v)]
+ v -> [(T.unpack k, T.unpack v)]
let kvs = concat $ map getAtt ["width", "height", "sizes", "srcset"]
return $ B.imageWith (uid, cls, kvs) (escapeURI url) title (B.text alt)
pCode :: PandocMonad m => TagParser m Inlines
pCode = try $ do
- (TagOpen open attr) <- pSatisfy $ tagOpen (`elem` ["code","tt"]) (const True)
+ (TagOpen open attr') <- pSatisfy $ tagOpen (`elem` ["code","tt"]) (const True)
+ let attr = toStringAttr attr'
result <- manyTill pAnyTag (pCloses open)
- return $ B.codeWith (mkAttr attr) $ intercalate " " $ lines $ innerText result
+ return $ B.codeWith (mkAttr attr) $ intercalate " " $ lines $ T.unpack $
+ innerText result
pSpan :: PandocMonad m => TagParser m Inlines
pSpan = try $ do
guardEnabled Ext_native_spans
- TagOpen _ attr <- lookAhead $ pSatisfy $ tagOpen (=="span") (const True)
+ TagOpen _ attr' <- lookAhead $ pSatisfy $ tagOpen (=="span") (const True)
+ let attr = toStringAttr attr'
contents <- pInTags "span" inline
let isSmallCaps = fontVariant == "small-caps" || "smallcaps" `elem` classes
where styleAttr = fromMaybe "" $ lookup "style" attr
@@ -708,7 +727,7 @@ pRawHtmlInline = do
then pSatisfy (not . isBlockTag)
else pSatisfy isInlineTag
exts <- getOption readerExtensions
- let raw = renderTags' [result]
+ let raw = T.unpack $ renderTags' [result]
if extensionEnabled Ext_raw_html exts
then return $ B.rawInline "html" raw
else ignore raw
@@ -716,32 +735,38 @@ pRawHtmlInline = do
mathMLToTeXMath :: String -> Either String String
mathMLToTeXMath s = writeTeX <$> readMathML s
+toStringAttr :: [(Text, Text)] -> [(String, String)]
+toStringAttr = map go
+ where go (x,y) = (T.unpack x, T.unpack y)
+
pMath :: PandocMonad m => Bool -> TagParser m Inlines
pMath inCase = try $ do
- open@(TagOpen _ attr) <- pSatisfy $ tagOpen (=="math") (const True)
+ open@(TagOpen _ attr') <- pSatisfy $ tagOpen (=="math") (const True)
-- we'll assume math tags are MathML unless specially marked
-- otherwise...
+ let attr = toStringAttr attr'
unless inCase $
guard (maybe True (== mathMLNamespace) (lookup "xmlns" attr))
- contents <- manyTill pAnyTag (pSatisfy (~== TagClose "math"))
- case mathMLToTeXMath (renderTags $ [open] ++ contents ++ [TagClose "math"]) of
+ contents <- manyTill pAnyTag (pSatisfy (matchTagClose "math"))
+ case mathMLToTeXMath (T.unpack $ renderTags $
+ [open] <> contents <> [TagClose "math"]) of
Left _ -> return $ B.spanWith ("",["math"],attr) $ B.text $
- innerText contents
+ T.unpack $ innerText contents
Right [] -> return mempty
Right x -> return $ case lookup "display" attr of
Just "block" -> B.displayMath x
_ -> B.math x
-pInlinesInTags :: PandocMonad m => String -> (Inlines -> Inlines)
+pInlinesInTags :: PandocMonad m => Text -> (Inlines -> Inlines)
-> TagParser m Inlines
pInlinesInTags tagtype f = extractSpaces f <$> pInTags tagtype inline
-pInTags :: (PandocMonad m, Monoid a) => String -> TagParser m a -> TagParser m a
+pInTags :: (PandocMonad m, Monoid a) => Text -> TagParser m a -> TagParser m a
pInTags tagtype parser = pInTags' tagtype (const True) parser
pInTags' :: (PandocMonad m, Monoid a)
- => String
- -> (Tag String -> Bool)
+ => Text
+ -> (Tag Text -> Bool)
-> TagParser m a
-> TagParser m a
pInTags' tagtype tagtest parser = try $ do
@@ -750,18 +775,18 @@ pInTags' tagtype tagtest parser = try $ do
-- parses p, preceeded by an optional opening tag
-- and followed by an optional closing tags
-pOptInTag :: PandocMonad m => String -> TagParser m a -> TagParser m a
+pOptInTag :: PandocMonad m => Text -> TagParser m a -> TagParser m a
pOptInTag tagtype p = try $ do
skipMany pBlank
- optional $ pSatisfy (~== TagOpen tagtype [])
+ optional $ pSatisfy (matchTagOpen tagtype [])
skipMany pBlank
x <- p
skipMany pBlank
- optional $ pSatisfy (~== TagClose tagtype)
+ optional $ pSatisfy (matchTagClose tagtype)
skipMany pBlank
return x
-pCloses :: PandocMonad m => String -> TagParser m ()
+pCloses :: PandocMonad m => Text -> TagParser m ()
pCloses tagtype = try $ do
t <- lookAhead $ pSatisfy $ \tag -> isTagClose tag || isTagOpen tag
case t of
@@ -782,15 +807,15 @@ pTagText = try $ do
parsed <- lift $ lift $
flip runReaderT qu $ runParserT (many pTagContents) st "text" str
case parsed of
- Left _ -> throwError $ PandocParseError $ "Could not parse `" ++ str ++ "'"
+ Left _ -> throwError $ PandocParseError $ "Could not parse `" <> T.unpack str <> "'"
Right result -> return $ mconcat result
pBlank :: PandocMonad m => TagParser m ()
pBlank = try $ do
(TagText str) <- pSatisfy isTagText
- guard $ all isSpace str
+ guard $ T.all isSpace str
-type InlinesParser m = HTMLParser m String
+type InlinesParser m = HTMLParser m Text
pTagContents :: PandocMonad m => InlinesParser m Inlines
pTagContents =
@@ -871,13 +896,13 @@ pSpace = many1 (satisfy isSpace) >>= \xs ->
-- Constants
--
-eitherBlockOrInline :: Set.Set String
+eitherBlockOrInline :: Set.Set Text
eitherBlockOrInline = Set.fromList
["audio", "applet", "button", "iframe", "embed",
"del", "ins", "progress", "map", "area", "noscript", "script",
"object", "svg", "video", "source"]
-blockHtmlTags :: Set.Set String
+blockHtmlTags :: Set.Set Text
blockHtmlTags = Set.fromList
["?xml", "!DOCTYPE", "address", "article", "aside",
"blockquote", "body", "canvas",
@@ -893,7 +918,7 @@ blockHtmlTags = Set.fromList
-- We want to allow raw docbook in markdown documents, so we
-- include docbook block tags here too.
-blockDocBookTags :: Set.Set String
+blockDocBookTags :: Set.Set Text
blockDocBookTags = Set.fromList
["calloutlist", "bibliolist", "glosslist", "itemizedlist",
"orderedlist", "segmentedlist", "simplelist",
@@ -908,37 +933,52 @@ blockDocBookTags = Set.fromList
"classsynopsis", "blockquote", "epigraph", "msgset",
"sidebar", "title"]
-epubTags :: Set.Set String
+epubTags :: Set.Set Text
epubTags = Set.fromList ["case", "switch", "default"]
-blockTags :: Set.Set String
+blockTags :: Set.Set Text
blockTags = Set.unions [blockHtmlTags, blockDocBookTags, epubTags]
-isInlineTag :: Tag String -> Bool
-isInlineTag t = tagOpen isInlineTagName (const True) t ||
- tagClose isInlineTagName t ||
- tagComment (const True) t
- where isInlineTagName x = x `Set.notMember` blockTags
-
-isBlockTag :: Tag String -> Bool
-isBlockTag t = tagOpen isBlockTagName (const True) t ||
- tagClose isBlockTagName t ||
- tagComment (const True) t
- where isBlockTagName ('?':_) = True
- isBlockTagName ('!':_) = True
- isBlockTagName x = x `Set.member` blockTags
- || x `Set.member`
- eitherBlockOrInline
-
-isTextTag :: Tag String -> Bool
+class NamedTag a where
+ getTagName :: a -> Maybe Text
+
+instance NamedTag (Tag Text) where
+ getTagName (TagOpen t _) = Just t
+ getTagName (TagClose t) = Just t
+ getTagName _ = Nothing
+
+instance NamedTag (Tag String) where
+ getTagName (TagOpen t _) = Just (T.pack t)
+ getTagName (TagClose t) = Just (T.pack t)
+ getTagName _ = Nothing
+
+isInlineTag :: NamedTag (Tag a) => Tag a -> Bool
+isInlineTag t = isInlineTagName || isCommentTag t
+ where isInlineTagName = case getTagName t of
+ Just x -> x
+ `Set.notMember` blockTags
+ Nothing -> False
+
+isBlockTag :: NamedTag (Tag a) => Tag a -> Bool
+isBlockTag t = isBlockTagName || isTagComment t
+ where isBlockTagName =
+ case getTagName t of
+ Just x
+ | "?" `T.isPrefixOf` x -> True
+ | "!" `T.isPrefixOf` x -> True
+ | otherwise -> x `Set.member` blockTags
+ || x `Set.member` eitherBlockOrInline
+ Nothing -> False
+
+isTextTag :: Tag a -> Bool
isTextTag = tagText (const True)
-isCommentTag :: Tag String -> Bool
+isCommentTag :: Tag a -> Bool
isCommentTag = tagComment (const True)
-- taken from HXT and extended
-- See http://www.w3.org/TR/html5/syntax.html sec 8.1.2.4 optional tags
-closes :: String -> String -> Bool
+closes :: Text -> Text -> Bool
_ `closes` "body" = False
_ `closes` "html" = False
"body" `closes` "head" = True
@@ -1000,8 +1040,11 @@ htmlInBalanced f = try $ do
let cs = ec - sc
lscontents <- unlines <$> count ls anyLine
cscontents <- count cs anyChar
- (_,closetag) <- htmlTag (~== TagClose tn)
- return (lscontents ++ cscontents ++ closetag)
+ closetag <- do
+ x <- many (satisfy (/='>'))
+ char '>'
+ return (x <> ">")
+ return (lscontents <> cscontents <> closetag)
_ -> mzero
_ -> mzero
@@ -1019,7 +1062,7 @@ htmlInBalanced' tagname ts = fromMaybe [] $ go 0 ts
go n (t:ts') = (t :) <$> go n ts'
go _ [] = mzero
-hasTagWarning :: [Tag String] -> Bool
+hasTagWarning :: [Tag a] -> Bool
hasTagWarning (TagWarning _:_) = True
hasTagWarning _ = False
@@ -1047,47 +1090,48 @@ htmlTag f = try $ do
-- basic sanity check, since the parser is very forgiving
-- and finds tags in stuff like x<y)
guard $ isName tagname
+ guard $ not $ null tagname
-- <https://example.org> should NOT be a tag either.
-- tagsoup will parse it as TagOpen "https:" [("example.org","")]
guard $ last tagname /= ':'
rendered <- manyTill anyChar (char '>')
- return (next, rendered ++ ">")
+ return (next, rendered <> ">")
case next of
TagComment s
| "<!--" `isPrefixOf` inp -> do
count (length s + 4) anyChar
skipMany (satisfy (/='>'))
char '>'
- return (next, "<!--" ++ s ++ "-->")
+ return (next, "<!--" <> s <> "-->")
| otherwise -> fail "bogus comment mode, HTML5 parse error"
TagOpen tagname attr -> do
guard $ all (isName . fst) attr
handleTag tagname
- TagClose tagname -> handleTag tagname
+ TagClose tagname ->
+ handleTag tagname
_ -> mzero
mkAttr :: [(String, String)] -> Attr
mkAttr attr = (attribsId, attribsClasses, attribsKV)
where attribsId = fromMaybe "" $ lookup "id" attr
- attribsClasses = (words $ fromMaybe "" $ lookup "class" attr) ++ epubTypes
+ attribsClasses = (words $ fromMaybe "" $ lookup "class" attr) <> epubTypes
attribsKV = filter (\(k,_) -> k /= "class" && k /= "id") attr
epubTypes = words $ fromMaybe "" $ lookup "epub:type" attr
-- Strip namespace prefixes
-stripPrefixes :: [Tag String] -> [Tag String]
+stripPrefixes :: [Tag Text] -> [Tag Text]
stripPrefixes = map stripPrefix
-stripPrefix :: Tag String -> Tag String
+stripPrefix :: Tag Text -> Tag Text
stripPrefix (TagOpen s as) =
TagOpen (stripPrefix' s) (map (stripPrefix' *** id) as)
stripPrefix (TagClose s) = TagClose (stripPrefix' s)
stripPrefix x = x
-stripPrefix' :: String -> String
+stripPrefix' :: Text -> Text
stripPrefix' s =
- case span (/= ':') s of
- (_, "") -> s
- (_, (_:ts)) -> ts
+ if T.null t then s else T.drop 1 t
+ where (_, t) = T.span (/= ':') s
isSpace :: Char -> Bool
isSpace ' ' = True
@@ -1130,19 +1174,32 @@ instance HasLastStrPosition HTMLState where
setLastStrPos s st = st {parserState = setLastStrPos s (parserState st)}
getLastStrPos = getLastStrPos . parserState
+-- For now we need a special verison here; the one in Shared has String type
+renderTags' :: [Tag Text] -> Text
+renderTags' = renderTagsOptions
+ renderOptions{ optMinimize = matchTags ["hr", "br", "img",
+ "meta", "link"]
+ , optRawTag = matchTags ["script", "style"] }
+ where matchTags = \tags -> flip elem tags . T.toLower
+
-- EPUB Specific
--
--
-sectioningContent :: [String]
+sectioningContent :: [Text]
sectioningContent = ["article", "aside", "nav", "section"]
-groupingContent :: [String]
+groupingContent :: [Text]
groupingContent = ["p", "hr", "pre", "blockquote", "ol"
, "ul", "li", "dl", "dt", "dt", "dd"
, "figure", "figcaption", "div", "main"]
+matchTagClose :: Text -> (Tag Text -> Bool)
+matchTagClose t = (~== TagClose t)
+
+matchTagOpen :: Text -> [(Text, Text)] -> (Tag Text -> Bool)
+matchTagOpen t as = (~== TagOpen t as)
{-
@@ -1150,7 +1207,7 @@ types :: [(String, ([String], Int))]
types = -- Document divisions
map (\s -> (s, (["section", "body"], 0)))
["volume", "part", "chapter", "division"]
- ++ -- Document section and components
+ <> -- Document section and components
[
("abstract", ([], 0))]
-}