@@ -1,5 +1,5 @@
11{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses,
2−ViewPatterns#-}
2+ViewPatterns, OverloadedStrings #-}
33{-
44Copyright (C) 2006-2017 John MacFarlane <jgm@berkeley.edu>
55
@@ -34,6 +34,7 @@ module Text.Pandoc.Readers.HTML ( readHtml
3434 , htmlInBalanced
3535 , isInlineTag
3636 , isBlockTag
37+ , NamedTag(..)
3738 , isTextTag
3839 , isCommentTag
3940 ) where
@@ -43,7 +44,7 @@ import Text.HTML.TagSoup.Match
4344import Text.Pandoc.Definition
4445import qualified Text.Pandoc.Builder as B
4546import Text.Pandoc.Builder (Blocks, Inlines, trimInlines, HasMeta(..))
46−import Text.Pandoc.Shared ( extractSpaces, renderTags', addMetaField
47+import Text.Pandoc.Shared ( extractSpaces, addMetaField
4748 , escapeURI, safeRead )
4849import Text.Pandoc.Options (ReaderOptions(readerExtensions), extensionEnabled,
4950 Extension (Ext_epub_html_exts,
@@ -53,13 +54,14 @@ import Text.Pandoc.Parsing hiding ((<|>))
5354import Text.Pandoc.Walk
5455import qualified Data.Map as M
5556import Data.Maybe ( fromMaybe, isJust)
56−import Data.List ( intercalate, isInfixOf, isPrefixOf )
57+import Data.List ( intercalate, isPrefixOf )
5758import Data.Char ( isDigit, isLetter, isAlphaNum )
5859import Control.Monad ( guard, mzero, void, unless )
5960import Control.Arrow ((***))
6061import Control.Applicative ( (<|>) )
6162import Data.Monoid (First (..))
62−import Data.Text (Text, unpack)
63+import Data.Text (Text)
64+import qualified Data.Text as T
6365import Text.TeXMath (readMathML, writeTeX)
6466import Data.Default (Default (..), def)
6567import Control.Monad.Reader (ask, asks, local, ReaderT, runReaderT, lift)
@@ -80,7 +82,7 @@ readHtml :: PandocMonad m
8082readHtml opts inp = do
8183 let tags = stripPrefixes . canonicalizeTags $
8284 parseTagsOptions parseOptions{ optTagPosition = True }
83− (unpack inp)
85+ inp
8486 parseDoc = do
8587 blocks <- (fixPlains False) . mconcat <$> manyTill block eof
8688 meta <- stateMeta . parserState <$> getState
@@ -130,7 +132,7 @@ setInPlain = local (\s -> s {inPlain = True})
130132
131133type HTMLParser m s = ParserT s HTMLState (ReaderT HTMLLocal m)
132134
133−type TagParser m = HTMLParser m [Tag String]
135+type TagParser m = HTMLParser m [Tag Text]
134136
135137pBody :: PandocMonad m => TagParser m Blocks
136138pBody = pInTags "body" block
@@ -140,12 +142,12 @@ pHead = pInTags "head" $ pTitle <|> pMetaTag <|> pBaseTag <|> (mempty <$ pAnyTag
140142 where pTitle = pInTags "title" inline >>= setTitle . trimInlines
141143 setTitle t = mempty <$ (updateState $ B.setMeta "title" t)
142144 pMetaTag = do
143− mt <- pSatisfy (~== TagOpen "meta" [])
144− let name = fromAttrib "name" mt
145+ mt <- pSatisfy (matchTagOpen "meta" [])
146+ let name = T.unpack $ fromAttrib "name" mt
145147 if null name
146148 then return mempty
147149 else do
148− let content = fromAttrib "content" mt
150+ let content = T.unpack $ fromAttrib "content" mt
149151 updateState $ \s ->
150152 let ps = parserState s in
151153 s{ parserState = ps{
@@ -153,9 +155,9 @@ pHead = pInTags "head" $ pTitle <|> pMetaTag <|> pBaseTag <|> (mempty <$ pAnyTag
153155 (stateMeta ps) } }
154156 return mempty
155157 pBaseTag = do
156− bt <- pSatisfy (~== TagOpen "base" [])
158+ bt <- pSatisfy (matchTagOpen "base" [])
157159 updateState $ \st -> st{ baseHref =
158− parseURIReference $ fromAttrib "href" bt }
160+ parseURIReference $ T.unpack $ fromAttrib "href" bt }
159161 return mempty
160162
161163block :: PandocMonad m => TagParser m Blocks
@@ -195,29 +197,31 @@ eSwitch :: (PandocMonad m, Monoid a)
195197 -> TagParser m a
196198eSwitch constructor parser = try $ do
197199 guardEnabled Ext_epub_html_exts
198− pSatisfy (~== TagOpen "switch" [])
200+ pSatisfy (matchTagOpen "switch" [])
199201 cases <- getFirst . mconcat <$>
200202 manyTill (First <$> (eCase <* skipMany pBlank) )
201− (lookAhead $ try $ pSatisfy (~== TagOpen "default" []))
203+ (lookAhead $ try $ pSatisfy (matchTagOpen "default" []))
202204 skipMany pBlank
203205 fallback <- pInTags "default" (skipMany pBlank *> parser <* skipMany pBlank)
204206 skipMany pBlank
205− pSatisfy (~== TagClose "switch")
207+ pSatisfy (matchTagClose "switch")
206208 return $ maybe fallback constructor cases
207209
208210eCase :: PandocMonad m => TagParser m (Maybe Inlines)
209211eCase = do
210212 skipMany pBlank
211− TagOpen _ attr <- lookAhead $ pSatisfy $ (~== TagOpen "case" [])
213+ TagOpen _ attr' <- lookAhead $ pSatisfy $ (matchTagOpen "case" [])
214+ let attr = toStringAttr attr'
212215 case (flip lookup namespaces) =<< lookup "required-namespace" attr of
213216 Just p -> Just <$> (pInTags "case" (skipMany pBlank *> p <* skipMany pBlank))
214− Nothing -> Nothing <$ manyTill pAnyTag (pSatisfy (~== TagClose "case"))
217+ Nothing -> Nothing <$ manyTill pAnyTag (pSatisfy (matchTagClose "case"))
215218
216219eFootnote :: PandocMonad m => TagParser m ()
217220eFootnote = try $ do
218221 let notes = ["footnote", "rearnote"]
219222 guardEnabled Ext_epub_html_exts
220− (TagOpen tag attr) <- lookAhead $ pAnyTag
223+ (TagOpen tag attr') <- lookAhead $ pAnyTag
224+ let attr = toStringAttr attr'
221225 guard (maybe False (flip elem notes) (lookup "type" attr))
222226 let ident = fromMaybe "" (lookup "id" attr)
223227 content <- pInTags tag block
@@ -229,7 +233,8 @@ addNote uid cont = updateState (\s -> s {noteTable = (uid, cont) : (noteTable s)
229233eNoteref :: PandocMonad m => TagParser m Inlines
230234eNoteref = try $ do
231235 guardEnabled Ext_epub_html_exts
232− TagOpen tag attr <- lookAhead $ pAnyTag
236+ TagOpen tag attr' <- lookAhead $ pAnyTag
237+ let attr = toStringAttr attr'
233238 guard (maybe False (== "noteref") (lookup "type" attr))
234239 let ident = maybe "" (dropWhile (== '#')) (lookup "href" attr)
235240 guard (not (null ident))
@@ -249,10 +254,10 @@ pList = pBulletList <|> pOrderedList <|> pDefinitionList
249254
250255pBulletList :: PandocMonad m => TagParser m Blocks
251256pBulletList = try $ do
252− pSatisfy (~== TagOpen "ul" [])
257+ pSatisfy (matchTagOpen "ul" [])
253258 let nonItem = pSatisfy (\t ->
254259 not (tagOpen (`elem` ["li","ol","ul","dl"]) (const True) t) &&
255− not (t ~== TagClose "ul"))
260+ not (matchTagClose "ul" t))
256261 -- note: if they have an <ol> or <ul> not in scope of a <li>,
257262 -- treat it as a list item, though it's not valid xhtml...
258263 skipMany nonItem
@@ -261,7 +266,8 @@ pBulletList = try $ do
261266
262267pListItem :: PandocMonad m => TagParser m a -> TagParser m Blocks
263268pListItem nonItem = do
264− TagOpen _ attr <- lookAhead $ pSatisfy (~== TagOpen "li" [])
269+ TagOpen _ attr' <- lookAhead $ pSatisfy (matchTagOpen "li" [])
270+ let attr = toStringAttr attr'
265271 let addId ident bs = case B.toList bs of
266272 (Plain ils:xs) -> B.fromList (Plain
267273 [Span (ident, [], []) ils] : xs)
@@ -287,7 +293,8 @@ parseTypeAttr _ = DefaultStyle
287293
288294pOrderedList :: PandocMonad m => TagParser m Blocks
289295pOrderedList = try $ do
290− TagOpen _ attribs <- pSatisfy (~== TagOpen "ol" [])
296+ TagOpen _ attribs' <- pSatisfy (matchTagOpen "ol" [])
297+ let attribs = toStringAttr attribs'
291298 let (start, style) = (sta', sty')
292299 where sta = fromMaybe "1" $
293300 lookup "start" attribs
@@ -309,7 +316,7 @@ pOrderedList = try $ do
309316 ]
310317 let nonItem = pSatisfy (\t ->
311318 not (tagOpen (`elem` ["li","ol","ul","dl"]) (const True) t) &&
312− not (t ~== TagClose "ol"))
319+ not (matchTagClose "ol" t))
313320 -- note: if they have an <ol> or <ul> not in scope of a <li>,
314321 -- treat it as a list item, though it's not valid xhtml...
315322 skipMany nonItem
@@ -318,14 +325,14 @@ pOrderedList = try $ do
318325
319326pDefinitionList :: PandocMonad m => TagParser m Blocks
320327pDefinitionList = try $ do
321− pSatisfy (~== TagOpen "dl" [])
328+ pSatisfy (matchTagOpen "dl" [])
322329 items <- manyTill pDefListItem (pCloses "dl")
323330 return $ B.definitionList items
324331
325332pDefListItem :: PandocMonad m => TagParser m (Inlines, [Blocks])
326333pDefListItem = try $ do
327− let nonItem = pSatisfy (\t -> not (t ~== TagOpen "dt" []) &&
328− not (t ~== TagOpen "dd" []) && not (t ~== TagClose "dl"))
334+ let nonItem = pSatisfy (\t -> not (matchTagOpen "dt" [] t) &&
335+ not (matchTagOpen "dd" [] t) && not (matchTagClose "dl" t))
329336 terms <- many1 (try $ skipMany nonItem >> pInTags "dt" inline)
330337 defs <- many1 (try $ skipMany nonItem >> pInTags "dd" block)
331338 skipMany nonItem
@@ -348,12 +355,12 @@ fixPlains inList bs = if any isParaish bs'
348355 plainToPara x = x
349356 bs' = B.toList bs
350357
351−pRawTag :: PandocMonad m => TagParser m String
358+pRawTag :: PandocMonad m => TagParser m Text
352359pRawTag = do
353360 tag <- pAnyTag
354361 let ignorable x = x `elem` ["html","head","body","!DOCTYPE","?xml"]
355362 if tagOpen ignorable (const True) tag || tagClose ignorable tag
356− then return []
363+ then return mempty
357364 else return $ renderTags' [tag]
358365
359366pDiv :: PandocMonad m => TagParser m Blocks
@@ -362,7 +369,8 @@ pDiv = try $ do
362369 let isDivLike "div" = True
363370 isDivLike "section" = True
364371 isDivLike _ = False
365− TagOpen tag attr <- lookAhead $ pSatisfy $ tagOpen isDivLike (const True)
372+ TagOpen tag attr' <- lookAhead $ pSatisfy $ tagOpen isDivLike (const True)
373+ let attr = toStringAttr attr'
366374 contents <- pInTags tag block
367375 let (ident, classes, kvs) = mkAttr attr
368376 let classes' = if tag == "section"
@@ -372,7 +380,7 @@ pDiv = try $ do
372380
373381pRawHtmlBlock :: PandocMonad m => TagParser m Blocks
374382pRawHtmlBlock = do
375− raw <- pHtmlBlock "script" <|> pHtmlBlock "style" <|> pRawTag
383+ raw <- T.unpack <$> (pHtmlBlock "script" <|> pHtmlBlock "style" <|> pRawTag)
376384 exts <- getOption readerExtensions
377385 if extensionEnabled Ext_raw_html exts && not (null raw)
378386 then return $ B.rawBlock "html" raw
@@ -387,33 +395,35 @@ ignore raw = do
387395 logMessage $ SkippedContent raw pos
388396 return mempty
389397
390−pHtmlBlock :: PandocMonad m => String -> TagParser m String
398+pHtmlBlock :: PandocMonad m => Text -> TagParser m Text
391399pHtmlBlock t = try $ do
392− open <- pSatisfy (~== TagOpen t [])
393− contents <- manyTill pAnyTag (pSatisfy (~== TagClose t))
394− return $ renderTags' $ [open] ++ contents ++ [TagClose t]
400+ open <- pSatisfy (matchTagOpen t [])
401+ contents <- manyTill pAnyTag (pSatisfy (matchTagClose t))
402+ return $ renderTags' $ [open] <> contents <> [TagClose t]
395403
396404-- Sets chapter context
397405eSection :: PandocMonad m => TagParser m Blocks
398406eSection = try $ do
399− let matchChapter as = maybe False (isInfixOf "chapter") (lookup "type" as)
407+ let matchChapter as = maybe False (T.isInfixOf "chapter") (lookup "type" as)
400408 let sectTag = tagOpen (`elem` sectioningContent) matchChapter
401409 TagOpen tag _ <- lookAhead $ pSatisfy sectTag
402410 setInChapter (pInTags tag block)
403411
404−headerLevel :: PandocMonad m => String -> TagParser m Int
412+headerLevel :: PandocMonad m => Text -> TagParser m Int
405413headerLevel tagtype = do
406− let level = read (drop 1 tagtype)
407− (try $ do
408− guardEnabled Ext_epub_html_exts
409− asks inChapter >>= guard
410− return (level - 1))
411− <|>
412− return level
414+ case safeRead (T.unpack (T.drop 1 tagtype)) of
415+ Just level ->
416+ (try $ do
417+ guardEnabled Ext_epub_html_exts
418+ asks inChapter >>= guard
419+ return (level - 1))
420+ <|>
421+ return level
422+ Nothing -> fail "Could not retrieve header level"
413423
414424eTitlePage :: PandocMonad m => TagParser m ()
415425eTitlePage = try $ do
416− let isTitlePage as = maybe False (isInfixOf "titlepage") (lookup "type" as)
426+ let isTitlePage as = maybe False (T.isInfixOf "titlepage") (lookup "type" as)
417427 let groupTag = tagOpen (\x -> x `elem` groupingContent || x == "section")
418428 isTitlePage
419429 TagOpen tag _ <- lookAhead $ pSatisfy groupTag
@@ -421,19 +431,21 @@ eTitlePage = try $ do
421431
422432pHeader :: PandocMonad m => TagParser m Blocks
423433pHeader = try $ do
424− TagOpen tagtype attr <- pSatisfy $
434+ TagOpen tagtype attr' <- pSatisfy $
425435 tagOpen (`elem` ["h1","h2","h3","h4","h5","h6"])
426436 (const True)
427− let bodyTitle = TagOpen tagtype attr ~== TagOpen "h1" [("class","title")]
437+ let attr = toStringAttr attr'
438+ let bodyTitle = TagOpen tagtype attr' ~== TagOpen ("h1" :: Text)
439+ [("class","title")]
428440 level <- headerLevel tagtype
429441 contents <- trimInlines . mconcat <$> manyTill inline (pCloses tagtype <|> eof)
430442 let ident = fromMaybe "" $ lookup "id" attr
431443 let classes = maybe [] words $ lookup "class" attr
432444 let keyvals = [(k,v) | (k,v) <- attr, k /= "class", k /= "id"]
433− attr' <- registerHeader (ident, classes, keyvals) contents
445+ attr'' <- registerHeader (ident, classes, keyvals) contents
434446 return $ if bodyTitle
435447 then mempty -- skip a representation of the title in the body
436− else B.headerWith attr' level contents
448+ else B.headerWith attr'' level contents
437449
438450pHrule :: PandocMonad m => TagParser m Blocks
439451pHrule = do
@@ -442,7 +454,7 @@ pHrule = do
442454
443455pTable :: PandocMonad m => TagParser m Blocks
444456pTable = try $ do
445− TagOpen _ _ <- pSatisfy (~== TagOpen "table" [])
457+ TagOpen _ _ <- pSatisfy (matchTagOpen "table" [])
446458 skipMany pBlank
447459 caption <- option mempty $ pInTags "caption" inline <* skipMany pBlank
448460 widths' <- (mconcat <$> many1 pColgroup) <|> many pCol
@@ -456,8 +468,8 @@ pTable = try $ do
456468 else return head''
457469 rowsLs <- many pTBody
458470 rows' <- pOptInTag "tfoot" $ many pTr
459− TagClose _ <- pSatisfy (~== TagClose "table")
460− let rows'' = (concat rowsLs) ++ rows'
471+ TagClose _ <- pSatisfy (matchTagClose "table")
472+ let rows'' = (concat rowsLs) <> rows'
461473 -- fail on empty table
462474 guard $ not $ null head' && null rows''
463475 let isSinglePlain x = case B.toList x of
@@ -468,7 +480,7 @@ pTable = try $ do
468480 let cols = length $ if null head' then head rows'' else head'
469481 -- add empty cells to short rows
470482 let addEmpties r = case cols - length r of
471− n | n > 0 -> r ++ replicate n mempty
483+ n | n > 0 -> r <> replicate n mempty
472484 | otherwise -> r
473485 let rows = map addEmpties rows''
474486 let aligns = replicate cols AlignDefault
@@ -481,15 +493,16 @@ pTable = try $ do
481493
482494pCol :: PandocMonad m => TagParser m Double
483495pCol = try $ do
484− TagOpen _ attribs <- pSatisfy (~== TagOpen "col" [])
496+ TagOpen _ attribs' <- pSatisfy (matchTagOpen "col" [])
497+ let attribs = toStringAttr attribs'
485498 skipMany pBlank
486− optional $ pSatisfy (~== TagClose "col")
499+ optional $ pSatisfy (matchTagClose "col")
487500 skipMany pBlank
488501 return $ case lookup "width" attribs of
489502 Nothing -> case lookup "style" attribs of
490503 Just ('w':'i':'d':'t':'h':':':xs) | '%' `elem` xs ->
491504 fromMaybe 0.0 $ safeRead ('0':'.':filter
492− (`notElem` " \t\r\n%'\";") xs)
505+ (`notElem` (" \t\r\n%'\";" :: [Char])) xs)
493506 _ -> 0.0
494507 Just x | not (null x) && last x == '%' ->
495508 fromMaybe 0.0 $ safeRead ('0':'.':init x)
@@ -497,18 +510,18 @@ pCol = try $ do
497510
498511pColgroup :: PandocMonad m => TagParser m [Double]
499512pColgroup = try $ do
500− pSatisfy (~== TagOpen "colgroup" [])
513+ pSatisfy (matchTagOpen "colgroup" [])
501514 skipMany pBlank
502515 manyTill pCol (pCloses "colgroup" <|> eof) <* skipMany pBlank
503516
504−noColOrRowSpans :: Tag String -> Bool
517+noColOrRowSpans :: Tag Text -> Bool
505518noColOrRowSpans t = isNullOrOne "colspan" && isNullOrOne "rowspan"
506519 where isNullOrOne x = case fromAttrib x t of
507520 "" -> True
508521 "1" -> True
509522 _ -> False
510523
511−pCell :: PandocMonad m => String -> TagParser m [Blocks]
524+pCell :: PandocMonad m => Text -> TagParser m [Blocks]
512525pCell celltype = try $ do
513526 skipMany pBlank
514527 res <- pInTags' celltype noColOrRowSpans block
@@ -534,7 +547,8 @@ pPara = do
534547
535548pCodeBlock :: PandocMonad m => TagParser m Blocks
536549pCodeBlock = try $ do
537− TagOpen _ attr <- pSatisfy (~== TagOpen "pre" [])
550+ TagOpen _ attr' <- pSatisfy (matchTagOpen "pre" [])
551+ let attr = toStringAttr attr'
538552 contents <- manyTill pAnyTag (pCloses "pre" <|> eof)
539553 let rawText = concatMap tagToString contents
540554 -- drop leading newline if any
@@ -547,8 +561,8 @@ pCodeBlock = try $ do
547561 _ -> result'
548562 return $ B.codeBlockWith (mkAttr attr) result
549563
550−tagToString :: Tag String -> String
551−tagToString (TagText s) = s
564+tagToString :: Tag Text -> String
565+tagToString (TagText s) = T.unpack s
552566tagToString (TagOpen "br" _) = "\n"
553567tagToString _ = ""
554568
@@ -577,20 +591,20 @@ pLocation = do
577591 (TagPosition r c) <- pSat isTagPosition
578592 setPosition $ newPos "input" r c
579593
580−pSat :: PandocMonad m => (Tag String -> Bool) -> TagParser m (Tag String)
594+pSat :: PandocMonad m => (Tag Text -> Bool) -> TagParser m (Tag Text)
581595pSat f = do
582596 pos <- getPosition
583597 token show (const pos) (\x -> if f x then Just x else Nothing)
584598
585−pSatisfy :: PandocMonad m => (Tag String -> Bool) -> TagParser m (Tag String)
599+pSatisfy :: PandocMonad m => (Tag Text -> Bool) -> TagParser m (Tag Text)
586600pSatisfy f = try $ optional pLocation >> pSat f
587601
588−pAnyTag :: PandocMonad m => TagParser m (Tag String)
602+pAnyTag :: PandocMonad m => TagParser m (Tag Text)
589603pAnyTag = pSatisfy (const True)
590604
591605pSelfClosing :: PandocMonad m
592− => (String -> Bool) -> ([Attribute String] -> Bool)
593− -> TagParser m (Tag String)
606+ => (Text -> Bool) -> ([Attribute Text] -> Bool)
607+ -> TagParser m (Tag Text)
594608pSelfClosing f g = do
595609 open <- pSatisfy (tagOpen f g)
596610 optional $ pSatisfy (tagClose f)
@@ -628,7 +642,7 @@ pStrikeout = do
628642 pInlinesInTags "s" B.strikeout <|>
629643 pInlinesInTags "strike" B.strikeout <|>
630644 pInlinesInTags "del" B.strikeout <|>
631− try (do pSatisfy (~== TagOpen "span" [("class","strikeout")])
645+ try (do pSatisfy (matchTagOpen "span" [("class","strikeout")])
632646 contents <- mconcat <$> manyTill inline (pCloses "span")
633647 return $ B.strikeout contents)
634648
@@ -639,17 +653,19 @@ pLineBreak = do
639653
640654-- Unlike fromAttrib from tagsoup, this distinguishes
641655-- between a missing attribute and an attribute with empty content.
642−maybeFromAttrib :: String -> Tag String -> Maybe String
643−maybeFromAttrib name (TagOpen _ attrs) = lookup name attrs
656+maybeFromAttrib :: String -> Tag Text -> Maybe String
657+maybeFromAttrib name (TagOpen _ attrs) =
658+ T.unpack <$> lookup (T.pack name) attrs
644659maybeFromAttrib _ _ = Nothing
645660
646661pLink :: PandocMonad m => TagParser m Inlines
647662pLink = try $ do
648663 tag <- pSatisfy $ tagOpenLit "a" (const True)
649− let title = fromAttrib "title" tag
664+ let title = T.unpack $ fromAttrib "title" tag
650665 -- take id from id attribute if present, otherwise name
651− let uid = maybe (fromAttrib "name" tag) id $ maybeFromAttrib "id" tag
652− let cls = words $ fromAttrib "class" tag
666+ let uid = maybe (T.unpack $ fromAttrib "name" tag) id $
667+ maybeFromAttrib "id" tag
668+ let cls = words $ T.unpack $ fromAttrib "class" tag
653669 lab <- trimInlines . mconcat <$> manyTill inline (pCloses "a")
654670 -- check for href; if href, then a link, otherwise a span
655671 case maybeFromAttrib "href" tag of
@@ -667,30 +683,33 @@ pImage :: PandocMonad m => TagParser m Inlines
667683pImage = do
668684 tag <- pSelfClosing (=="img") (isJust . lookup "src")
669685 mbBaseHref <- baseHref <$> getState
670− let url' = fromAttrib "src" tag
686+ let url' = T.unpack $ fromAttrib "src" tag
671687 let url = case (parseURIReference url', mbBaseHref) of
672688 (Just rel, Just bs) -> show (rel `nonStrictRelativeTo` bs)
673689 _ -> url'
674− let title = fromAttrib "title" tag
675− let alt = fromAttrib "alt" tag
676− let uid = fromAttrib "id" tag
677− let cls = words $ fromAttrib "class" tag
690+ let title = T.unpack $ fromAttrib "title" tag
691+ let alt = T.unpack $ fromAttrib "alt" tag
692+ let uid = T.unpack $ fromAttrib "id" tag
693+ let cls = words $ T.unpack $ fromAttrib "class" tag
678694 let getAtt k = case fromAttrib k tag of
679695 "" -> []
680− v -> [(k, v)]
696+ v -> [(T.unpack k, T.unpack v)]
681697 let kvs = concat $ map getAtt ["width", "height", "sizes", "srcset"]
682698 return $ B.imageWith (uid, cls, kvs) (escapeURI url) title (B.text alt)
683699
684700pCode :: PandocMonad m => TagParser m Inlines
685701pCode = try $ do
686− (TagOpen open attr) <- pSatisfy $ tagOpen (`elem` ["code","tt"]) (const True)
702+ (TagOpen open attr') <- pSatisfy $ tagOpen (`elem` ["code","tt"]) (const True)
703+ let attr = toStringAttr attr'
687704 result <- manyTill pAnyTag (pCloses open)
688− return $ B.codeWith (mkAttr attr) $ intercalate " " $ lines $ innerText result
705+ return $ B.codeWith (mkAttr attr) $ intercalate " " $ lines $ T.unpack $
706+ innerText result
689707
690708pSpan :: PandocMonad m => TagParser m Inlines
691709pSpan = try $ do
692710 guardEnabled Ext_native_spans
693− TagOpen _ attr <- lookAhead $ pSatisfy $ tagOpen (=="span") (const True)
711+ TagOpen _ attr' <- lookAhead $ pSatisfy $ tagOpen (=="span") (const True)
712+ let attr = toStringAttr attr'
694713 contents <- pInTags "span" inline
695714 let isSmallCaps = fontVariant == "small-caps" || "smallcaps" `elem` classes
696715 where styleAttr = fromMaybe "" $ lookup "style" attr
@@ -708,7 +727,7 @@ pRawHtmlInline = do
708727 then pSatisfy (not . isBlockTag)
709728 else pSatisfy isInlineTag
710729 exts <- getOption readerExtensions
711− let raw = renderTags' [result]
730+ let raw = T.unpack $ renderTags' [result]
712731 if extensionEnabled Ext_raw_html exts
713732 then return $ B.rawInline "html" raw
714733 else ignore raw
@@ -716,32 +735,38 @@ pRawHtmlInline = do
716735mathMLToTeXMath :: String -> Either String String
717736mathMLToTeXMath s = writeTeX <$> readMathML s
718737
738+toStringAttr :: [(Text, Text)] -> [(String, String)]
739+toStringAttr = map go
740+ where go (x,y) = (T.unpack x, T.unpack y)
741+
719742pMath :: PandocMonad m => Bool -> TagParser m Inlines
720743pMath inCase = try $ do
721− open@(TagOpen _ attr) <- pSatisfy $ tagOpen (=="math") (const True)
744+ open@(TagOpen _ attr') <- pSatisfy $ tagOpen (=="math") (const True)
722745 -- we'll assume math tags are MathML unless specially marked
723746 -- otherwise...
747+ let attr = toStringAttr attr'
724748 unless inCase $
725749 guard (maybe True (== mathMLNamespace) (lookup "xmlns" attr))
726− contents <- manyTill pAnyTag (pSatisfy (~== TagClose "math"))
727− case mathMLToTeXMath (renderTags $ [open] ++ contents ++ [TagClose "math"]) of
750+ contents <- manyTill pAnyTag (pSatisfy (matchTagClose "math"))
751+ case mathMLToTeXMath (T.unpack $ renderTags $
752+ [open] <> contents <> [TagClose "math"]) of
728753 Left _ -> return $ B.spanWith ("",["math"],attr) $ B.text $
729− innerText contents
754+ T.unpack $ innerText contents
730755 Right [] -> return mempty
731756 Right x -> return $ case lookup "display" attr of
732757 Just "block" -> B.displayMath x
733758 _ -> B.math x
734759
735−pInlinesInTags :: PandocMonad m => String -> (Inlines -> Inlines)
760+pInlinesInTags :: PandocMonad m => Text -> (Inlines -> Inlines)
736761 -> TagParser m Inlines
737762pInlinesInTags tagtype f = extractSpaces f <$> pInTags tagtype inline
738763
739−pInTags :: (PandocMonad m, Monoid a) => String -> TagParser m a -> TagParser m a
764+pInTags :: (PandocMonad m, Monoid a) => Text -> TagParser m a -> TagParser m a
740765pInTags tagtype parser = pInTags' tagtype (const True) parser
741766
742767pInTags' :: (PandocMonad m, Monoid a)
743− => String
744− -> (Tag String -> Bool)
768+ => Text
769+ -> (Tag Text -> Bool)
745770 -> TagParser m a
746771 -> TagParser m a
747772pInTags' tagtype tagtest parser = try $ do
@@ -750,18 +775,18 @@ pInTags' tagtype tagtest parser = try $ do
750775
751776-- parses p, preceeded by an optional opening tag
752777-- and followed by an optional closing tags
753−pOptInTag :: PandocMonad m => String -> TagParser m a -> TagParser m a
778+pOptInTag :: PandocMonad m => Text -> TagParser m a -> TagParser m a
754779pOptInTag tagtype p = try $ do
755780 skipMany pBlank
756− optional $ pSatisfy (~== TagOpen tagtype [])
781+ optional $ pSatisfy (matchTagOpen tagtype [])
757782 skipMany pBlank
758783 x <- p
759784 skipMany pBlank
760− optional $ pSatisfy (~== TagClose tagtype)
785+ optional $ pSatisfy (matchTagClose tagtype)
761786 skipMany pBlank
762787 return x
763788
764−pCloses :: PandocMonad m => String -> TagParser m ()
789+pCloses :: PandocMonad m => Text -> TagParser m ()
765790pCloses tagtype = try $ do
766791 t <- lookAhead $ pSatisfy $ \tag -> isTagClose tag || isTagOpen tag
767792 case t of
@@ -782,15 +807,15 @@ pTagText = try $ do
782807 parsed <- lift $ lift $
783808 flip runReaderT qu $ runParserT (many pTagContents) st "text" str
784809 case parsed of
785− Left _ -> throwError $ PandocParseError $ "Could not parse `" ++ str ++ "'"
810+ Left _ -> throwError $ PandocParseError $ "Could not parse `" <> T.unpack str <> "'"
786811 Right result -> return $ mconcat result
787812
788813pBlank :: PandocMonad m => TagParser m ()
789814pBlank = try $ do
790815 (TagText str) <- pSatisfy isTagText
791− guard $ all isSpace str
816+ guard $ T.all isSpace str
792817
793−type InlinesParser m = HTMLParser m String
818+type InlinesParser m = HTMLParser m Text
794819
795820pTagContents :: PandocMonad m => InlinesParser m Inlines
796821pTagContents =
@@ -871,13 +896,13 @@ pSpace = many1 (satisfy isSpace) >>= \xs ->
871896-- Constants
872897--
873898
874−eitherBlockOrInline :: Set.Set String
899+eitherBlockOrInline :: Set.Set Text
875900eitherBlockOrInline = Set.fromList
876901 ["audio", "applet", "button", "iframe", "embed",
877902 "del", "ins", "progress", "map", "area", "noscript", "script",
878903 "object", "svg", "video", "source"]
879904
880−blockHtmlTags :: Set.Set String
905+blockHtmlTags :: Set.Set Text
881906blockHtmlTags = Set.fromList
882907 ["?xml", "!DOCTYPE", "address", "article", "aside",
883908 "blockquote", "body", "canvas",
@@ -893,7 +918,7 @@ blockHtmlTags = Set.fromList
893918
894919-- We want to allow raw docbook in markdown documents, so we
895920-- include docbook block tags here too.
896−blockDocBookTags :: Set.Set String
921+blockDocBookTags :: Set.Set Text
897922blockDocBookTags = Set.fromList
898923 ["calloutlist", "bibliolist", "glosslist", "itemizedlist",
899924 "orderedlist", "segmentedlist", "simplelist",
@@ -908,37 +933,52 @@ blockDocBookTags = Set.fromList
908933 "classsynopsis", "blockquote", "epigraph", "msgset",
909934 "sidebar", "title"]
910935
911−epubTags :: Set.Set String
936+epubTags :: Set.Set Text
912937epubTags = Set.fromList ["case", "switch", "default"]
913938
914−blockTags :: Set.Set String
939+blockTags :: Set.Set Text
915940blockTags = Set.unions [blockHtmlTags, blockDocBookTags, epubTags]
916941
917−isInlineTag :: Tag String -> Bool
918−isInlineTag t = tagOpen isInlineTagName (const True) t ||
919− tagClose isInlineTagName t ||
920− tagComment (const True) t
921− where isInlineTagName x = x `Set.notMember` blockTags
922−
923−isBlockTag :: Tag String -> Bool
924−isBlockTag t = tagOpen isBlockTagName (const True) t ||
925− tagClose isBlockTagName t ||
926− tagComment (const True) t
927− where isBlockTagName ('?':_) = True
928− isBlockTagName ('!':_) = True
929− isBlockTagName x = x `Set.member` blockTags
930− || x `Set.member`
931− eitherBlockOrInline
932−
933−isTextTag :: Tag String -> Bool
942+class NamedTag a where
943+ getTagName :: a -> Maybe Text
944+
945+instance NamedTag (Tag Text) where
946+ getTagName (TagOpen t _) = Just t
947+ getTagName (TagClose t) = Just t
948+ getTagName _ = Nothing
949+
950+instance NamedTag (Tag String) where
951+ getTagName (TagOpen t _) = Just (T.pack t)
952+ getTagName (TagClose t) = Just (T.pack t)
953+ getTagName _ = Nothing
954+
955+isInlineTag :: NamedTag (Tag a) => Tag a -> Bool
956+isInlineTag t = isInlineTagName || isCommentTag t
957+ where isInlineTagName = case getTagName t of
958+ Just x -> x
959+ `Set.notMember` blockTags
960+ Nothing -> False
961+
962+isBlockTag :: NamedTag (Tag a) => Tag a -> Bool
963+isBlockTag t = isBlockTagName || isTagComment t
964+ where isBlockTagName =
965+ case getTagName t of
966+ Just x
967+ | "?" `T.isPrefixOf` x -> True
968+ | "!" `T.isPrefixOf` x -> True
969+ | otherwise -> x `Set.member` blockTags
970+ || x `Set.member` eitherBlockOrInline
971+ Nothing -> False
972+
973+isTextTag :: Tag a -> Bool
934974isTextTag = tagText (const True)
935975
936−isCommentTag :: Tag String -> Bool
976+isCommentTag :: Tag a -> Bool
937977isCommentTag = tagComment (const True)
938978
939979-- taken from HXT and extended
940980-- See http://www.w3.org/TR/html5/syntax.html sec 8.1.2.4 optional tags
941−closes :: String -> String -> Bool
981+closes :: Text -> Text -> Bool
942982_ `closes` "body" = False
943983_ `closes` "html" = False
944984"body" `closes` "head" = True
@@ -1000,8 +1040,11 @@ htmlInBalanced f = try $ do
10001040 let cs = ec - sc
10011041 lscontents <- unlines <$> count ls anyLine
10021042 cscontents <- count cs anyChar
1003− (_,closetag) <- htmlTag (~== TagClose tn)
1004− return (lscontents ++ cscontents ++ closetag)
1043+ closetag <- do
1044+ x <- many (satisfy (/='>'))
1045+ char '>'
1046+ return (x <> ">")
1047+ return (lscontents <> cscontents <> closetag)
10051048 _ -> mzero
10061049 _ -> mzero
10071050
@@ -1019,7 +1062,7 @@ htmlInBalanced' tagname ts = fromMaybe [] $ go 0 ts
10191062 go n (t:ts') = (t :) <$> go n ts'
10201063 go _ [] = mzero
10211064
1022−hasTagWarning :: [Tag String] -> Bool
1065+hasTagWarning :: [Tag a] -> Bool
10231066hasTagWarning (TagWarning _:_) = True
10241067hasTagWarning _ = False
10251068
@@ -1047,47 +1090,48 @@ htmlTag f = try $ do
10471090 -- basic sanity check, since the parser is very forgiving
10481091 -- and finds tags in stuff like x<y)
10491092 guard $ isName tagname
1093+ guard $ not $ null tagname
10501094 -- <https://example.org> should NOT be a tag either.
10511095 -- tagsoup will parse it as TagOpen "https:" [("example.org","")]
10521096 guard $ last tagname /= ':'
10531097 rendered <- manyTill anyChar (char '>')
1054− return (next, rendered ++ ">")
1098+ return (next, rendered <> ">")
10551099 case next of
10561100 TagComment s
10571101 | "<!--" `isPrefixOf` inp -> do
10581102 count (length s + 4) anyChar
10591103 skipMany (satisfy (/='>'))
10601104 char '>'
1061− return (next, "<!--" ++ s ++ "-->")
1105+ return (next, "<!--" <> s <> "-->")
10621106 | otherwise -> fail "bogus comment mode, HTML5 parse error"
10631107 TagOpen tagname attr -> do
10641108 guard $ all (isName . fst) attr
10651109 handleTag tagname
1066− TagClose tagname -> handleTag tagname
1110+ TagClose tagname ->
1111+ handleTag tagname
10671112 _ -> mzero
10681113
10691114mkAttr :: [(String, String)] -> Attr
10701115mkAttr attr = (attribsId, attribsClasses, attribsKV)
10711116 where attribsId = fromMaybe "" $ lookup "id" attr
1072− attribsClasses = (words $ fromMaybe "" $ lookup "class" attr) ++ epubTypes
1117+ attribsClasses = (words $ fromMaybe "" $ lookup "class" attr) <> epubTypes
10731118 attribsKV = filter (\(k,_) -> k /= "class" && k /= "id") attr
10741119 epubTypes = words $ fromMaybe "" $ lookup "epub:type" attr
10751120
10761121-- Strip namespace prefixes
1077−stripPrefixes :: [Tag String] -> [Tag String]
1122+stripPrefixes :: [Tag Text] -> [Tag Text]
10781123stripPrefixes = map stripPrefix
10791124
1080−stripPrefix :: Tag String -> Tag String
1125+stripPrefix :: Tag Text -> Tag Text
10811126stripPrefix (TagOpen s as) =
10821127 TagOpen (stripPrefix' s) (map (stripPrefix' *** id) as)
10831128stripPrefix (TagClose s) = TagClose (stripPrefix' s)
10841129stripPrefix x = x
10851130
1086−stripPrefix' :: String -> String
1131+stripPrefix' :: Text -> Text
10871132stripPrefix' s =
1088− case span (/= ':') s of
1089− (_, "") -> s
1090− (_, (_:ts)) -> ts
1133+ if T.null t then s else T.drop 1 t
1134+ where (_, t) = T.span (/= ':') s
10911135
10921136isSpace :: Char -> Bool
10931137isSpace ' ' = True
@@ -1130,19 +1174,32 @@ instance HasLastStrPosition HTMLState where
11301174 setLastStrPos s st = st {parserState = setLastStrPos s (parserState st)}
11311175 getLastStrPos = getLastStrPos . parserState
11321176
1177+-- For now we need a special verison here; the one in Shared has String type
1178+renderTags' :: [Tag Text] -> Text
1179+renderTags' = renderTagsOptions
1180+ renderOptions{ optMinimize = matchTags ["hr", "br", "img",
1181+ "meta", "link"]
1182+ , optRawTag = matchTags ["script", "style"] }
1183+ where matchTags = \tags -> flip elem tags . T.toLower
1184+
11331185
11341186-- EPUB Specific
11351187--
11361188--
1137−sectioningContent :: [String]
1189+sectioningContent :: [Text]
11381190sectioningContent = ["article", "aside", "nav", "section"]
11391191
11401192
1141−groupingContent :: [String]
1193+groupingContent :: [Text]
11421194groupingContent = ["p", "hr", "pre", "blockquote", "ol"
11431195 , "ul", "li", "dl", "dt", "dt", "dd"
11441196 , "figure", "figcaption", "div", "main"]
11451197
1198+matchTagClose :: Text -> (Tag Text -> Bool)
1199+matchTagClose t = (~== TagClose t)
1200+
1201+matchTagOpen :: Text -> [(Text, Text)] -> (Tag Text -> Bool)
1202+matchTagOpen t as = (~== TagOpen t as)
11461203
11471204{-
11481205
@@ -1150,7 +1207,7 @@ types :: [(String, ([String], Int))]
11501207types = -- Document divisions
11511208 map (\s -> (s, (["section", "body"], 0)))
11521209 ["volume", "part", "chapter", "division"]
1153− ++ -- Document section and components
1210+ <> -- Document section and components
11541211 [
11551212 ("abstract", ([], 0))]
11561213-}