git.iko.soy/typeable/pandoc
on master help sign in
HTML reader: extract submodules
f925837Albert Krewinkel
pandoc.cabal+3
compare with master
unifiedsplit
@@ -599,6 +599,9 @@ library
599 Text.Pandoc.Readers.Docx.Parse.Styles,
599 Text.Pandoc.Readers.Docx.Parse.Styles,
600 Text.Pandoc.Readers.Docx.Util,
600 Text.Pandoc.Readers.Docx.Util,
601 Text.Pandoc.Readers.Docx.Fields,
601 Text.Pandoc.Readers.Docx.Fields,
602+ Text.Pandoc.Readers.HTML.Parsing,
603+ Text.Pandoc.Readers.HTML.TagCategories,
604+ Text.Pandoc.Readers.HTML.Types,
602 Text.Pandoc.Readers.LaTeX.Parsing,
605 Text.Pandoc.Readers.LaTeX.Parsing,
603 Text.Pandoc.Readers.LaTeX.Lang,
606 Text.Pandoc.Readers.LaTeX.Lang,
604 Text.Pandoc.Readers.LaTeX.SIunitx,
607 Text.Pandoc.Readers.LaTeX.SIunitx,
src/Text/Pandoc/Readers/HTML.hs+11−239
@@ -1,7 +1,6 @@
1−{-# LANGUAGE LambdaCase #-}
2−{-# LANGUAGE FlexibleContexts #-}
1+{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleInstances #-}
2{-# LANGUAGE FlexibleInstances #-}
4−{-# LANGUAGE MultiParamTypeClasses #-}
3+{-# LANGUAGE LambdaCase #-}
5{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE OverloadedStrings #-}
6{-# LANGUAGE ViewPatterns #-}
5{-# LANGUAGE ViewPatterns #-}
7{- |
6{- |
@@ -29,7 +28,8 @@ import Control.Applicative ((<|>))
29import Control.Arrow (first)
28import Control.Arrow (first)
30import Control.Monad (guard, mplus, msum, mzero, unless, void)
29import Control.Monad (guard, mplus, msum, mzero, unless, void)
31import Control.Monad.Except (throwError)
30import Control.Monad.Except (throwError)
32−import Control.Monad.Reader (ReaderT, ask, asks, lift, local, runReaderT)
31+import Control.Monad.Reader (ask, asks, lift, local, runReaderT)
32+import Data.ByteString.Base64 (encode)
33import Data.Char (isAlphaNum, isLetter)
33import Data.Char (isAlphaNum, isLetter)
34import Data.Default (Default (..), def)
34import Data.Default (Default (..), def)
35import Data.Foldable (for_)
35import Data.Foldable (for_)
@@ -40,17 +40,19 @@ import Data.Monoid (First (..))
40import qualified Data.Set as Set
40import qualified Data.Set as Set
41import Data.Text (Text)
41import Data.Text (Text)
42import qualified Data.Text as T
42import qualified Data.Text as T
43−import Network.URI (URI, nonStrictRelativeTo, parseURIReference)
43+import Network.URI (nonStrictRelativeTo, parseURIReference)
44import Text.HTML.TagSoup
44import Text.HTML.TagSoup
45import Text.HTML.TagSoup.Match
45import Text.HTML.TagSoup.Match
46−import Text.Pandoc.Builder (Blocks, HasMeta (..), Inlines, trimInlines)
46+import Text.Pandoc.Builder (Blocks, Inlines, trimInlines)
47import qualified Text.Pandoc.Builder as B
47import qualified Text.Pandoc.Builder as B
48import Text.Pandoc.Class.PandocMonad (PandocMonad (..))
48import Text.Pandoc.Class.PandocMonad (PandocMonad (..))
49import Text.Pandoc.CSS (foldOrElse, pickStyleAttrProps)
49import Text.Pandoc.CSS (foldOrElse, pickStyleAttrProps)
50import qualified Text.Pandoc.UTF8 as UTF8
50import qualified Text.Pandoc.UTF8 as UTF8
51import Text.Pandoc.Definition
51import Text.Pandoc.Definition
52+import Text.Pandoc.Readers.HTML.Parsing
53+import Text.Pandoc.Readers.HTML.TagCategories
54+import Text.Pandoc.Readers.HTML.Types
52import Text.Pandoc.Readers.LaTeX (rawLaTeXInline)
55import Text.Pandoc.Readers.LaTeX (rawLaTeXInline)
53−import Text.Pandoc.Readers.LaTeX.Types (Macro)
54import Text.Pandoc.XML (html5Attributes, html4Attributes, rdfaAttributes)
56import Text.Pandoc.XML (html5Attributes, html4Attributes, rdfaAttributes)
55import Text.Pandoc.Error
57import Text.Pandoc.Error
56import Text.Pandoc.Logging
58import Text.Pandoc.Logging
@@ -66,7 +68,6 @@ import Text.Pandoc.Shared (addMetaField, blocksToInlines', crFilter, escapeURI,
66import Text.Pandoc.Walk
68import Text.Pandoc.Walk
67import Text.Parsec.Error
69import Text.Parsec.Error
68import Text.TeXMath (readMathML, writeTeX)
70import Text.TeXMath (readMathML, writeTeX)
69−import Data.ByteString.Base64 (encode)
70
71
71-- | Convert HTML-formatted string to 'Pandoc' document.
72-- | Convert HTML-formatted string to 'Pandoc' document.
72readHtml :: PandocMonad m
73readHtml :: PandocMonad m
@@ -105,32 +106,12 @@ replaceNotes' noteTbl (RawInline (Format "noteref") ref) =
105 maybe (Str "") (Note . B.toList) $ lookup ref noteTbl
106 maybe (Str "") (Note . B.toList) $ lookup ref noteTbl
106replaceNotes' _ x = x
107replaceNotes' _ x = x
107
108
108−data HTMLState =
109− HTMLState
110− { parserState :: ParserState,
111− noteTable :: [(Text, Blocks)],
112− baseHref :: Maybe URI,
113− identifiers :: Set.Set Text,
114− logMessages :: [LogMessage],
115− macros :: M.Map Text Macro,
116− readerOpts :: ReaderOptions
117− }
118−
119−data HTMLLocal = HTMLLocal { quoteContext :: QuoteContext
120− , inChapter :: Bool -- ^ Set if in chapter section
121− , inPlain :: Bool -- ^ Set if in pPlain
122− }
123−
124setInChapter :: PandocMonad m => HTMLParser m s a -> HTMLParser m s a
109setInChapter :: PandocMonad m => HTMLParser m s a -> HTMLParser m s a
125setInChapter = local (\s -> s {inChapter = True})
110setInChapter = local (\s -> s {inChapter = True})
126
111
127setInPlain :: PandocMonad m => HTMLParser m s a -> HTMLParser m s a
112setInPlain :: PandocMonad m => HTMLParser m s a -> HTMLParser m s a
128setInPlain = local (\s -> s {inPlain = True})
113setInPlain = local (\s -> s {inPlain = True})
129
114
130−type HTMLParser m s = ParserT s HTMLState (ReaderT HTMLLocal m)
131−
132−type TagParser m = HTMLParser m [Tag Text]
133−
134pHtml :: PandocMonad m => TagParser m Blocks
115pHtml :: PandocMonad m => TagParser m Blocks
135pHtml = try $ do
116pHtml = try $ do
136 (TagOpen "html" attr) <- lookAhead pAny
117 (TagOpen "html" attr) <- lookAhead pAny
@@ -681,22 +662,6 @@ inline = choice
681 , pRawHtmlInline
662 , pRawHtmlInline
682 ]
663 ]
683
664
684−pLocation :: PandocMonad m => TagParser m ()
685−pLocation = do
686− (TagPosition r c) <- pSat isTagPosition
687− setPosition $ newPos "input" r c
688−
689−pSat :: PandocMonad m => (Tag Text -> Bool) -> TagParser m (Tag Text)
690−pSat f = do
691− pos <- getPosition
692− token tshow (const pos) (\x -> if f x then Just x else Nothing)
693−
694−pSatisfy :: PandocMonad m => (Tag Text -> Bool) -> TagParser m (Tag Text)
695−pSatisfy f = try $ optional pLocation >> pSat f
696−
697−pAny :: PandocMonad m => TagParser m (Tag Text)
698−pAny = pSatisfy (const True)
699−
700pSelfClosing :: PandocMonad m
665pSelfClosing :: PandocMonad m
701 => (Text -> Bool) -> ([Attribute Text] -> Bool)
666 => (Text -> Bool) -> ([Attribute Text] -> Bool)
702 -> TagParser m (Tag Text)
667 -> TagParser m (Tag Text)
@@ -924,49 +889,6 @@ pInlinesInTags :: PandocMonad m => Text -> (Inlines -> Inlines)
924 -> TagParser m Inlines
889 -> TagParser m Inlines
925pInlinesInTags tagtype f = extractSpaces f <$> pInTags tagtype inline
890pInlinesInTags tagtype f = extractSpaces f <$> pInTags tagtype inline
926
891
927−pInTags :: (PandocMonad m, Monoid a) => Text -> TagParser m a -> TagParser m a
928−pInTags tagtype parser = pInTags' tagtype (const True) parser
929−
930−pInTags' :: (PandocMonad m, Monoid a)
931− => Text
932− -> (Tag Text -> Bool)
933− -> TagParser m a
934− -> TagParser m a
935−pInTags' tagtype tagtest parser = try $ do
936− pSatisfy (\t -> t ~== TagOpen tagtype [] && tagtest t)
937− mconcat <$> manyTill parser (pCloses tagtype <|> eof)
938−
939−-- parses p, preceded by an opening tag (optional if tagsOptional)
940−-- and followed by a closing tag (optional if tagsOptional)
941−pInTag :: PandocMonad m => Bool -> Text -> TagParser m a -> TagParser m a
942−pInTag tagsOptional tagtype p = try $ do
943− skipMany pBlank
944− (if tagsOptional then optional else void) $ pSatisfy (matchTagOpen tagtype [])
945− skipMany pBlank
946− x <- p
947− skipMany pBlank
948− (if tagsOptional then optional else void) $ pSatisfy (matchTagClose tagtype)
949− skipMany pBlank
950− return x
951−
952−pCloses :: PandocMonad m => Text -> TagParser m ()
953−pCloses tagtype = try $ do
954− t <- lookAhead $ pSatisfy $ \tag -> isTagClose tag || isTagOpen tag
955− case t of
956− (TagClose t') | t' == tagtype -> void pAny
957− (TagOpen t' _) | t' `closes` tagtype -> return ()
958− (TagClose "ul") | tagtype == "li" -> return ()
959− (TagClose "ol") | tagtype == "li" -> return ()
960− (TagClose "dl") | tagtype == "dd" -> return ()
961− (TagClose "table") | tagtype == "td" -> return ()
962− (TagClose "table") | tagtype == "th" -> return ()
963− (TagClose "table") | tagtype == "tr" -> return ()
964− (TagClose "td") | tagtype `Set.member` blockHtmlTags -> return ()
965− (TagClose "th") | tagtype `Set.member` blockHtmlTags -> return ()
966− (TagClose t') | tagtype == "p" && t' `Set.member` blockHtmlTags
967− -> return () -- see #3794
968− _ -> mzero
969−
970pTagText :: PandocMonad m => TagParser m Inlines
892pTagText :: PandocMonad m => TagParser m Inlines
971pTagText = try $ do
893pTagText = try $ do
972 (TagText str) <- pSatisfy isTagText
894 (TagText str) <- pSatisfy isTagText
@@ -975,14 +897,10 @@ pTagText = try $ do
975 parsed <- lift $ lift $
897 parsed <- lift $ lift $
976 flip runReaderT qu $ runParserT (many pTagContents) st "text" str
898 flip runReaderT qu $ runParserT (many pTagContents) st "text" str
977 case parsed of
899 case parsed of
978− Left _ -> throwError $ PandocParseError $ "Could not parse `" <> str <> "'"
900+ Left _ -> throwError $ PandocParseError $
901+ "Could not parse `" <> str <> "'"
979 Right result -> return $ mconcat result
902 Right result -> return $ mconcat result
980
903
981−pBlank :: PandocMonad m => TagParser m ()
982−pBlank = try $ do
983− (TagText str) <- pSatisfy isTagText
984− guard $ T.all isSpace str
985−
986type InlinesParser m = HTMLParser m Text
904type InlinesParser m = HTMLParser m Text
987
905
988pTagContents :: PandocMonad m => InlinesParser m Inlines
906pTagContents :: PandocMonad m => InlinesParser m Inlines
@@ -1077,54 +995,6 @@ pSpace = many1 (satisfy isSpace) >>= \xs ->
1077 then return B.softbreak
995 then return B.softbreak
1078 else return B.space
996 else return B.space
1079
997
1080−--
1081−-- Constants
1082−--
1083−
1084−eitherBlockOrInline :: Set.Set Text
1085−eitherBlockOrInline = Set.fromList
1086− ["audio", "applet", "button", "iframe", "embed",
1087− "del", "ins", "progress", "map", "area", "noscript", "script",
1088− "object", "svg", "video", "source"]
1089−
1090−blockHtmlTags :: Set.Set Text
1091−blockHtmlTags = Set.fromList
1092− ["?xml", "!DOCTYPE", "address", "article", "aside",
1093− "blockquote", "body", "canvas",
1094− "caption", "center", "col", "colgroup", "dd", "details",
1095− "dir", "div", "dl", "dt", "fieldset", "figcaption", "figure",
1096− "footer", "form", "h1", "h2", "h3", "h4",
1097− "h5", "h6", "head", "header", "hgroup", "hr", "html",
1098− "isindex", "main", "menu", "meta", "noframes", "nav",
1099− "ol", "output", "p", "pre",
1100− "section", "summary", "table", "tbody", "textarea",
1101− "thead", "tfoot", "ul", "dd",
1102− "dt", "frameset", "li", "tbody", "td", "tfoot",
1103− "th", "thead", "tr", "script", "style"]
1104−
1105−-- We want to allow raw docbook in markdown documents, so we
1106−-- include docbook block tags here too.
1107−blockDocBookTags :: Set.Set Text
1108−blockDocBookTags = Set.fromList
1109− ["calloutlist", "bibliolist", "glosslist", "itemizedlist",
1110− "orderedlist", "segmentedlist", "simplelist",
1111− "variablelist", "caution", "important", "note", "tip",
1112− "warning", "address", "literallayout", "programlisting",
1113− "programlistingco", "screen", "screenco", "screenshot",
1114− "synopsis", "example", "informalexample", "figure",
1115− "informalfigure", "table", "informaltable", "para",
1116− "simpara", "formalpara", "equation", "informalequation",
1117− "figure", "screenshot", "mediaobject", "qandaset",
1118− "procedure", "task", "cmdsynopsis", "funcsynopsis",
1119− "classsynopsis", "blockquote", "epigraph", "msgset",
1120− "sidebar", "title"]
1121−
1122−epubTags :: Set.Set Text
1123−epubTags = Set.fromList ["case", "switch", "default"]
1124−
1125−blockTags :: Set.Set Text
1126−blockTags = Set.unions [blockHtmlTags, blockDocBookTags, epubTags]
1127−
1128class NamedTag a where
998class NamedTag a where
1129 getTagName :: a -> Maybe Text
999 getTagName :: a -> Maybe Text
1130
1000
@@ -1162,47 +1032,6 @@ isTextTag = tagText (const True)
1162isCommentTag :: Tag a -> Bool
1032isCommentTag :: Tag a -> Bool
1163isCommentTag = tagComment (const True)
1033isCommentTag = tagComment (const True)
1164
1034
1165−-- taken from HXT and extended
1166−-- See http://www.w3.org/TR/html5/syntax.html sec 8.1.2.4 optional tags
1167−closes :: Text -> Text -> Bool
1168−_ `closes` "body" = False
1169−_ `closes` "html" = False
1170−"body" `closes` "head" = True
1171−"a" `closes` "a" = True
1172−"li" `closes` "li" = True
1173−"th" `closes` t | t `elem` ["th","td"] = True
1174−"td" `closes` t | t `elem` ["th","td"] = True
1175−"tr" `closes` t | t `elem` ["th","td","tr"] = True
1176−"dd" `closes` t | t `elem` ["dt", "dd"] = True
1177−"dt" `closes` t | t `elem` ["dt","dd"] = True
1178−"rt" `closes` t | t `elem` ["rb", "rt", "rtc"] = True
1179−"optgroup" `closes` "optgroup" = True
1180−"optgroup" `closes` "option" = True
1181−"option" `closes` "option" = True
1182−-- https://html.spec.whatwg.org/multipage/syntax.html#optional-tags
1183−x `closes` "p" | x `elem` ["address", "article", "aside", "blockquote",
1184− "dir", "div", "dl", "fieldset", "footer", "form", "h1", "h2", "h3", "h4",
1185− "h5", "h6", "header", "hr", "main", "menu", "nav", "ol", "p", "pre", "section",
1186− "table", "ul"] = True
1187−_ `closes` "meta" = True
1188−"form" `closes` "form" = True
1189−"label" `closes` "label" = True
1190−"map" `closes` "map" = True
1191−"object" `closes` "object" = True
1192−_ `closes` t | t `elem` ["option","style","script","textarea","title"] = True
1193−t `closes` "select" | t /= "option" = True
1194−"thead" `closes` "colgroup" = True
1195−"tfoot" `closes` t | t `elem` ["thead","colgroup"] = True
1196−"tbody" `closes` t | t `elem` ["tbody","tfoot","thead","colgroup"] = True
1197−t `closes` t2 |
1198− t `elem` ["h1","h2","h3","h4","h5","h6","dl","ol","ul","table","div","main","p"] &&
1199− t2 `elem` ["h1","h2","h3","h4","h5","h6","p" ] = True -- not "div" or "main"
1200−t1 `closes` t2 |
1201− t1 `Set.member` blockTags &&
1202− t2 `Set.notMember` blockTags &&
1203− t2 `Set.notMember` eitherBlockOrInline = True
1204−_ `closes` _ = False
1205−
1206--- parsers for use in markdown, textile readers
1035--- parsers for use in markdown, textile readers
1207
1036
1208-- | Matches a stretch of HTML in balanced tags.
1037-- | Matches a stretch of HTML in balanced tags.
@@ -1347,13 +1176,6 @@ stripPrefix' s =
1347 if T.null t then s else T.drop 1 t
1176 if T.null t then s else T.drop 1 t
1348 where (_, t) = T.span (/= ':') s
1177 where (_, t) = T.span (/= ':') s
1349
1178
1350−isSpace :: Char -> Bool
1351−isSpace ' ' = True
1352−isSpace '\t' = True
1353−isSpace '\n' = True
1354−isSpace '\r' = True
1355−isSpace _ = False
1356−
1357-- Utilities
1179-- Utilities
1358
1180
1359-- | Adjusts a url according to the document's base URL.
1181-- | Adjusts a url according to the document's base URL.
@@ -1364,41 +1186,6 @@ canonicalizeUrl url = do
1364 (Just rel, Just bs) -> tshow (rel `nonStrictRelativeTo` bs)
1186 (Just rel, Just bs) -> tshow (rel `nonStrictRelativeTo` bs)
1365 _ -> url
1187 _ -> url
1366
1188
1367−
1368−-- Instances
1369−
1370−instance HasMacros HTMLState where
1371− extractMacros = macros
1372− updateMacros f st = st{ macros = f $ macros st }
1373−
1374−instance HasIdentifierList HTMLState where
1375− extractIdentifierList = identifiers
1376− updateIdentifierList f s = s{ identifiers = f (identifiers s) }
1377−
1378−instance HasLogMessages HTMLState where
1379− addLogMessage m s = s{ logMessages = m : logMessages s }
1380− getLogMessages = reverse . logMessages
1381−
1382−-- This signature should be more general
1383−-- MonadReader HTMLLocal m => HasQuoteContext st m
1384−instance PandocMonad m => HasQuoteContext HTMLState (ReaderT HTMLLocal m) where
1385− getQuoteContext = asks quoteContext
1386− withQuoteContext q = local (\s -> s{quoteContext = q})
1387−
1388−instance HasReaderOptions HTMLState where
1389− extractReaderOptions = extractReaderOptions . parserState
1390−
1391−instance HasMeta HTMLState where
1392− setMeta s b st = st {parserState = setMeta s b $ parserState st}
1393− deleteMeta s st = st {parserState = deleteMeta s $ parserState st}
1394−
1395−instance Default HTMLLocal where
1396− def = HTMLLocal NoQuote False False
1397−
1398−instance HasLastStrPosition HTMLState where
1399− setLastStrPos s st = st {parserState = setLastStrPos s (parserState st)}
1400− getLastStrPos = getLastStrPos . parserState
1401−
1402-- For now we need a special version here; the one in Shared has String type
1189-- For now we need a special version here; the one in Shared has String type
1403renderTags' :: [Tag Text] -> Text
1190renderTags' :: [Tag Text] -> Text
1404renderTags' = renderTagsOptions
1191renderTags' = renderTagsOptions
@@ -1411,21 +1198,6 @@ renderTags' = renderTagsOptions
1411-- EPUB Specific
1198-- EPUB Specific
1412--
1199--
1413--
1200--
1414−sectioningContent :: [Text]
1415−sectioningContent = ["article", "aside", "nav", "section"]
1416−
1417−
1418−groupingContent :: [Text]
1419−groupingContent = ["p", "hr", "pre", "blockquote", "ol"
1420− , "ul", "li", "dl", "dt", "dt", "dd"
1421− , "figure", "figcaption", "div", "main"]
1422−
1423−matchTagClose :: Text -> (Tag Text -> Bool)
1424−matchTagClose t = (~== TagClose t)
1425−
1426−matchTagOpen :: Text -> [(Text, Text)] -> (Tag Text -> Bool)
1427−matchTagOpen t as = (~== TagOpen t as)
1428−
1429{-
1201{-
1430
1202
1431types :: [(String, ([String], Int))]
1203types :: [(String, ([String], Int))]
src/Text/Pandoc/Readers/HTML/Parsing.hsnew file+156
@@ -0,0 +1,156 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+{- |
3+ Module : Text.Pandoc.Readers.HTML.Parsing
4+ Copyright : Copyright (C) 2006-2020 John MacFarlane
5+ License : GNU GPL, version 2 or above
6+
7+ Maintainer : John MacFarlane <jgm@berkeley.edu>
8+ Stability : alpha
9+ Portability : portable
10+
11+Parsing functions and utilities.
12+-}
13+module Text.Pandoc.Readers.HTML.Parsing
14+ ( pInTags
15+ , pInTags'
16+ , pInTag
17+ , pAny
18+ , pCloses
19+ , pSatisfy
20+ , pBlank
21+ , matchTagClose
22+ , matchTagOpen
23+ , isSpace
24+ )
25+where
26+
27+import Control.Monad (guard, void, mzero)
28+import Data.Text (Text)
29+import Text.HTML.TagSoup
30+import Text.Pandoc.Class.PandocMonad (PandocMonad (..))
31+import Text.Pandoc.Parsing
32+ ( (<|>), eof, getPosition, lookAhead, manyTill, newPos, optional
33+ , skipMany, setPosition, token, try)
34+import Text.Pandoc.Readers.HTML.TagCategories
35+import Text.Pandoc.Readers.HTML.Types
36+import Text.Pandoc.Shared (tshow)
37+import qualified Data.Set as Set
38+import qualified Data.Text as T
39+
40+pInTags :: (PandocMonad m, Monoid a) => Text -> TagParser m a -> TagParser m a
41+pInTags tagtype parser = pInTags' tagtype (const True) parser
42+
43+pInTags' :: (PandocMonad m, Monoid a)
44+ => Text
45+ -> (Tag Text -> Bool)
46+ -> TagParser m a
47+ -> TagParser m a
48+pInTags' tagtype tagtest parser = try $ do
49+ pSatisfy (\t -> t ~== TagOpen tagtype [] && tagtest t)
50+ mconcat <$> manyTill parser (pCloses tagtype <|> eof)
51+
52+-- parses p, preceded by an opening tag (optional if tagsOptional)
53+-- and followed by a closing tag (optional if tagsOptional)
54+pInTag :: PandocMonad m => Bool -> Text -> TagParser m a -> TagParser m a
55+pInTag tagsOptional tagtype p = try $ do
56+ skipMany pBlank
57+ (if tagsOptional then optional else void) $ pSatisfy (matchTagOpen tagtype [])
58+ skipMany pBlank
59+ x <- p
60+ skipMany pBlank
61+ (if tagsOptional then optional else void) $ pSatisfy (matchTagClose tagtype)
62+ skipMany pBlank
63+ return x
64+
65+pCloses :: PandocMonad m => Text -> TagParser m ()
66+pCloses tagtype = try $ do
67+ t <- lookAhead $ pSatisfy $ \tag -> isTagClose tag || isTagOpen tag
68+ case t of
69+ (TagClose t') | t' == tagtype -> void pAny
70+ (TagOpen t' _) | t' `closes` tagtype -> return ()
71+ (TagClose "ul") | tagtype == "li" -> return ()
72+ (TagClose "ol") | tagtype == "li" -> return ()
73+ (TagClose "dl") | tagtype == "dd" -> return ()
74+ (TagClose "table") | tagtype == "td" -> return ()
75+ (TagClose "table") | tagtype == "th" -> return ()
76+ (TagClose "table") | tagtype == "tr" -> return ()
77+ (TagClose "td") | tagtype `Set.member` blockHtmlTags -> return ()
78+ (TagClose "th") | tagtype `Set.member` blockHtmlTags -> return ()
79+ (TagClose t') | tagtype == "p" && t' `Set.member` blockHtmlTags
80+ -> return () -- see #3794
81+ _ -> mzero
82+
83+pBlank :: PandocMonad m => TagParser m ()
84+pBlank = try $ do
85+ (TagText str) <- pSatisfy isTagText
86+ guard $ T.all isSpace str
87+
88+pLocation :: PandocMonad m => TagParser m ()
89+pLocation = do
90+ (TagPosition r c) <- pSat isTagPosition
91+ setPosition $ newPos "input" r c
92+
93+pSat :: PandocMonad m => (Tag Text -> Bool) -> TagParser m (Tag Text)
94+pSat f = do
95+ pos <- getPosition
96+ token tshow (const pos) (\x -> if f x then Just x else Nothing)
97+
98+pSatisfy :: PandocMonad m => (Tag Text -> Bool) -> TagParser m (Tag Text)
99+pSatisfy f = try $ optional pLocation >> pSat f
100+
101+matchTagClose :: Text -> (Tag Text -> Bool)
102+matchTagClose t = (~== TagClose t)
103+
104+matchTagOpen :: Text -> [(Text, Text)] -> (Tag Text -> Bool)
105+matchTagOpen t as = (~== TagOpen t as)
106+
107+pAny :: PandocMonad m => TagParser m (Tag Text)
108+pAny = pSatisfy (const True)
109+
110+isSpace :: Char -> Bool
111+isSpace ' ' = True
112+isSpace '\t' = True
113+isSpace '\n' = True
114+isSpace '\r' = True
115+isSpace _ = False
116+
117+-- taken from HXT and extended
118+-- See http://www.w3.org/TR/html5/syntax.html sec 8.1.2.4 optional tags
119+closes :: Text -> Text -> Bool
120+_ `closes` "body" = False
121+_ `closes` "html" = False
122+"body" `closes` "head" = True
123+"a" `closes` "a" = True
124+"li" `closes` "li" = True
125+"th" `closes` t | t `elem` ["th","td"] = True
126+"td" `closes` t | t `elem` ["th","td"] = True
127+"tr" `closes` t | t `elem` ["th","td","tr"] = True
128+"dd" `closes` t | t `elem` ["dt", "dd"] = True
129+"dt" `closes` t | t `elem` ["dt","dd"] = True
130+"rt" `closes` t | t `elem` ["rb", "rt", "rtc"] = True
131+"optgroup" `closes` "optgroup" = True
132+"optgroup" `closes` "option" = True
133+"option" `closes` "option" = True
134+-- https://html.spec.whatwg.org/multipage/syntax.html#optional-tags
135+x `closes` "p" | x `elem` ["address", "article", "aside", "blockquote",
136+ "dir", "div", "dl", "fieldset", "footer", "form", "h1", "h2", "h3", "h4",
137+ "h5", "h6", "header", "hr", "main", "menu", "nav", "ol", "p", "pre", "section",
138+ "table", "ul"] = True
139+_ `closes` "meta" = True
140+"form" `closes` "form" = True
141+"label" `closes` "label" = True
142+"map" `closes` "map" = True
143+"object" `closes` "object" = True
144+_ `closes` t | t `elem` ["option","style","script","textarea","title"] = True
145+t `closes` "select" | t /= "option" = True
146+"thead" `closes` "colgroup" = True
147+"tfoot" `closes` t | t `elem` ["thead","colgroup"] = True
148+"tbody" `closes` t | t `elem` ["tbody","tfoot","thead","colgroup"] = True
149+t `closes` t2 |
150+ t `elem` ["h1","h2","h3","h4","h5","h6","dl","ol","ul","table","div","main","p"] &&
151+ t2 `elem` ["h1","h2","h3","h4","h5","h6","p" ] = True -- not "div" or "main"
152+t1 `closes` t2 |
153+ t1 `Set.member` blockTags &&
154+ t2 `Set.notMember` blockTags &&
155+ t2 `Set.notMember` eitherBlockOrInline = True
156+_ `closes` _ = False
src/Text/Pandoc/Readers/HTML/TagCategories.hsnew file+78
@@ -0,0 +1,78 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+{- |
3+ Module : Text.Pandoc.Readers.HTML.TagCategories
4+ Copyright : Copyright (C) 2006-2020 John MacFarlane
5+ License : GNU GPL, version 2 or above
6+
7+ Maintainer : John MacFarlane <jgm@berkeley.edu>
8+ Stability : alpha
9+ Portability : portable
10+
11+Categories of tags.
12+-}
13+module Text.Pandoc.Readers.HTML.TagCategories
14+ ( blockHtmlTags
15+ , blockDocBookTags
16+ , eitherBlockOrInline
17+ , epubTags
18+ , blockTags
19+ , sectioningContent
20+ , groupingContent
21+ )
22+where
23+
24+import Data.Set (Set, fromList, unions)
25+import Data.Text (Text)
26+
27+eitherBlockOrInline :: Set Text
28+eitherBlockOrInline = fromList
29+ ["audio", "applet", "button", "iframe", "embed",
30+ "del", "ins", "progress", "map", "area", "noscript", "script",
31+ "object", "svg", "video", "source"]
32+
33+blockHtmlTags :: Set Text
34+blockHtmlTags = fromList
35+ ["?xml", "!DOCTYPE", "address", "article", "aside",
36+ "blockquote", "body", "canvas",
37+ "caption", "center", "col", "colgroup", "dd", "details",
38+ "dir", "div", "dl", "dt", "fieldset", "figcaption", "figure",
39+ "footer", "form", "h1", "h2", "h3", "h4",
40+ "h5", "h6", "head", "header", "hgroup", "hr", "html",
41+ "isindex", "main", "menu", "meta", "noframes", "nav",
42+ "ol", "output", "p", "pre",
43+ "section", "summary", "table", "tbody", "textarea",
44+ "thead", "tfoot", "ul", "dd",
45+ "dt", "frameset", "li", "tbody", "td", "tfoot",
46+ "th", "thead", "tr", "script", "style"]
47+
48+-- We want to allow raw docbook in markdown documents, so we
49+-- include docbook block tags here too.
50+blockDocBookTags :: Set Text
51+blockDocBookTags = fromList
52+ ["calloutlist", "bibliolist", "glosslist", "itemizedlist",
53+ "orderedlist", "segmentedlist", "simplelist",
54+ "variablelist", "caution", "important", "note", "tip",
55+ "warning", "address", "literallayout", "programlisting",
56+ "programlistingco", "screen", "screenco", "screenshot",
57+ "synopsis", "example", "informalexample", "figure",
58+ "informalfigure", "table", "informaltable", "para",
59+ "simpara", "formalpara", "equation", "informalequation",
60+ "figure", "screenshot", "mediaobject", "qandaset",
61+ "procedure", "task", "cmdsynopsis", "funcsynopsis",
62+ "classsynopsis", "blockquote", "epigraph", "msgset",
63+ "sidebar", "title"]
64+
65+epubTags :: Set Text
66+epubTags = fromList ["case", "switch", "default"]
67+
68+blockTags :: Set Text
69+blockTags = unions [blockHtmlTags, blockDocBookTags, epubTags]
70+
71+sectioningContent :: [Text]
72+sectioningContent = ["article", "aside", "nav", "section"]
73+
74+
75+groupingContent :: [Text]
76+groupingContent = ["p", "hr", "pre", "blockquote", "ol"
77+ , "ul", "li", "dl", "dt", "dt", "dd"
78+ , "figure", "figcaption", "div", "main"]
src/Text/Pandoc/Readers/HTML/Types.hsnew file+97
@@ -0,0 +1,97 @@
1+{-# LANGUAGE FlexibleInstances #-}
2+{-# LANGUAGE MultiParamTypeClasses #-}
3+{- |
4+ Module : Text.Pandoc.Readers.HTML.Types
5+ Copyright : Copyright (C) 2006-2020 John MacFarlane
6+ License : GNU GPL, version 2 or above
7+
8+ Maintainer : John MacFarlane <jgm@berkeley.edu>
9+ Stability : alpha
10+ Portability : portable
11+
12+Types for pandoc's HTML reader.
13+-}
14+module Text.Pandoc.Readers.HTML.Types
15+ ( TagParser
16+ , HTMLParser
17+ , HTMLState (..)
18+ , HTMLLocal (..)
19+ )
20+where
21+
22+import Control.Monad.Reader (ReaderT, asks, local)
23+import Data.Default (Default (def))
24+import Data.Map (Map)
25+import Data.Set (Set)
26+import Data.Text (Text)
27+import Network.URI (URI)
28+import Text.HTML.TagSoup
29+import Text.Pandoc.Builder (Blocks, HasMeta (..))
30+import Text.Pandoc.Class.PandocMonad (PandocMonad (..))
31+import Text.Pandoc.Logging (LogMessage)
32+import Text.Pandoc.Options (ReaderOptions)
33+import Text.Pandoc.Parsing
34+ ( HasIdentifierList (..), HasLastStrPosition (..), HasLogMessages (..)
35+ , HasMacros (..), HasQuoteContext (..), HasReaderOptions (..)
36+ , ParserT, ParserState, QuoteContext (NoQuote)
37+ )
38+import Text.Pandoc.Readers.LaTeX.Types (Macro)
39+
40+-- | HTML parser type
41+type HTMLParser m s = ParserT s HTMLState (ReaderT HTMLLocal m)
42+
43+-- | HTML parser, expecting @Tag Text@ as tokens.
44+type TagParser m = HTMLParser m [Tag Text]
45+
46+-- | Global HTML parser state
47+data HTMLState = HTMLState
48+ { parserState :: ParserState
49+ , noteTable :: [(Text, Blocks)]
50+ , baseHref :: Maybe URI
51+ , identifiers :: Set Text
52+ , logMessages :: [LogMessage]
53+ , macros :: Map Text Macro
54+ , readerOpts :: ReaderOptions
55+ }
56+
57+-- | Local HTML parser state
58+data HTMLLocal = HTMLLocal
59+ { quoteContext :: QuoteContext
60+ , inChapter :: Bool -- ^ Set if in chapter section
61+ , inPlain :: Bool -- ^ Set if in pPlain
62+ }
63+
64+
65+-- Instances
66+
67+instance HasMacros HTMLState where
68+ extractMacros = macros
69+ updateMacros f st = st{ macros = f $ macros st }
70+
71+instance HasIdentifierList HTMLState where
72+ extractIdentifierList = identifiers
73+ updateIdentifierList f s = s{ identifiers = f (identifiers s) }
74+
75+instance HasLogMessages HTMLState where
76+ addLogMessage m s = s{ logMessages = m : logMessages s }
77+ getLogMessages = reverse . logMessages
78+
79+-- This signature should be more general
80+-- MonadReader HTMLLocal m => HasQuoteContext st m
81+instance PandocMonad m => HasQuoteContext HTMLState (ReaderT HTMLLocal m) where
82+ getQuoteContext = asks quoteContext
83+ withQuoteContext q = local (\s -> s{quoteContext = q})
84+
85+instance HasReaderOptions HTMLState where
86+ extractReaderOptions = extractReaderOptions . parserState
87+
88+instance HasMeta HTMLState where
89+ setMeta s b st = st {parserState = setMeta s b $ parserState st}
90+ deleteMeta s st = st {parserState = deleteMeta s $ parserState st}
91+
92+instance Default HTMLLocal where
93+ def = HTMLLocal NoQuote False False
94+
95+instance HasLastStrPosition HTMLState where
96+ setLastStrPos s st = st {parserState = setLastStrPos s (parserState st)}
97+ getLastStrPos = getLastStrPos . parserState