@@ -1,7 +1,6 @@
1−{-# LANGUAGE LambdaCase #-}
2−{-# LANGUAGE FlexibleContexts #-}
1+{-# LANGUAGE FlexibleContexts #-}
32{-# LANGUAGE FlexibleInstances #-}
4−{-# LANGUAGE MultiParamTypeClasses #-}
3+{-# LANGUAGE LambdaCase #-}
54{-# LANGUAGE OverloadedStrings #-}
65{-# LANGUAGE ViewPatterns #-}
76{- |
@@ -29,7 +28,8 @@ import Control.Applicative ((<|>))
2928import Control.Arrow (first)
3029import Control.Monad (guard, mplus, msum, mzero, unless, void)
3130import 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)
3333import Data.Char (isAlphaNum, isLetter)
3434import Data.Default (Default (..), def)
3535import Data.Foldable (for_)
@@ -40,17 +40,19 @@ import Data.Monoid (First (..))
4040import qualified Data.Set as Set
4141import Data.Text (Text)
4242import qualified Data.Text as T
43−import Network.URI (URI, nonStrictRelativeTo, parseURIReference)
43+import Network.URI (nonStrictRelativeTo, parseURIReference)
4444import Text.HTML.TagSoup
4545import Text.HTML.TagSoup.Match
46−import Text.Pandoc.Builder (Blocks, HasMeta (..), Inlines, trimInlines)
46+import Text.Pandoc.Builder (Blocks, Inlines, trimInlines)
4747import qualified Text.Pandoc.Builder as B
4848import Text.Pandoc.Class.PandocMonad (PandocMonad (..))
4949import Text.Pandoc.CSS (foldOrElse, pickStyleAttrProps)
5050import qualified Text.Pandoc.UTF8 as UTF8
5151import Text.Pandoc.Definition
52+import Text.Pandoc.Readers.HTML.Parsing
53+import Text.Pandoc.Readers.HTML.TagCategories
54+import Text.Pandoc.Readers.HTML.Types
5255import Text.Pandoc.Readers.LaTeX (rawLaTeXInline)
53−import Text.Pandoc.Readers.LaTeX.Types (Macro)
5456import Text.Pandoc.XML (html5Attributes, html4Attributes, rdfaAttributes)
5557import Text.Pandoc.Error
5658import Text.Pandoc.Logging
@@ -66,7 +68,6 @@ import Text.Pandoc.Shared (addMetaField, blocksToInlines', crFilter, escapeURI,
6668import Text.Pandoc.Walk
6769import Text.Parsec.Error
6870import Text.TeXMath (readMathML, writeTeX)
69−import Data.ByteString.Base64 (encode)
7071
7172-- | Convert HTML-formatted string to 'Pandoc' document.
7273readHtml :: PandocMonad m
@@ -105,32 +106,12 @@ replaceNotes' noteTbl (RawInline (Format "noteref") ref) =
105106 maybe (Str "") (Note . B.toList) $ lookup ref noteTbl
106107replaceNotes' _ x = x
107108
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−
124109setInChapter :: PandocMonad m => HTMLParser m s a -> HTMLParser m s a
125110setInChapter = local (\s -> s {inChapter = True})
126111
127112setInPlain :: PandocMonad m => HTMLParser m s a -> HTMLParser m s a
128113setInPlain = local (\s -> s {inPlain = True})
129114
130−type HTMLParser m s = ParserT s HTMLState (ReaderT HTMLLocal m)
131−
132−type TagParser m = HTMLParser m [Tag Text]
133−
134115pHtml :: PandocMonad m => TagParser m Blocks
135116pHtml = try $ do
136117 (TagOpen "html" attr) <- lookAhead pAny
@@ -681,22 +662,6 @@ inline = choice
681662 , pRawHtmlInline
682663 ]
683664
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−
700665pSelfClosing :: PandocMonad m
701666 => (Text -> Bool) -> ([Attribute Text] -> Bool)
702667 -> TagParser m (Tag Text)
@@ -924,49 +889,6 @@ pInlinesInTags :: PandocMonad m => Text -> (Inlines -> Inlines)
924889 -> TagParser m Inlines
925890pInlinesInTags tagtype f = extractSpaces f <$> pInTags tagtype inline
926891
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−
970892pTagText :: PandocMonad m => TagParser m Inlines
971893pTagText = try $ do
972894 (TagText str) <- pSatisfy isTagText
@@ -975,14 +897,10 @@ pTagText = try $ do
975897 parsed <- lift $ lift $
976898 flip runReaderT qu $ runParserT (many pTagContents) st "text" str
977899 case parsed of
978− Left _ -> throwError $ PandocParseError $ "Could not parse `" <> str <> "'"
900+ Left _ -> throwError $ PandocParseError $
901+ "Could not parse `" <> str <> "'"
979902 Right result -> return $ mconcat result
980903
981−pBlank :: PandocMonad m => TagParser m ()
982−pBlank = try $ do
983− (TagText str) <- pSatisfy isTagText
984− guard $ T.all isSpace str
985−
986904type InlinesParser m = HTMLParser m Text
987905
988906pTagContents :: PandocMonad m => InlinesParser m Inlines
@@ -1077,54 +995,6 @@ pSpace = many1 (satisfy isSpace) >>= \xs ->
1077995 then return B.softbreak
1078996 else return B.space
1079997
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−
1128998class NamedTag a where
1129999 getTagName :: a -> Maybe Text
11301000
@@ -1162,47 +1032,6 @@ isTextTag = tagText (const True)
11621032isCommentTag :: Tag a -> Bool
11631033isCommentTag = tagComment (const True)
11641034
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−
12061035--- parsers for use in markdown, textile readers
12071036
12081037-- | Matches a stretch of HTML in balanced tags.
@@ -1347,13 +1176,6 @@ stripPrefix' s =
13471176 if T.null t then s else T.drop 1 t
13481177 where (_, t) = T.span (/= ':') s
13491178
1350−isSpace :: Char -> Bool
1351−isSpace ' ' = True
1352−isSpace '\t' = True
1353−isSpace '\n' = True
1354−isSpace '\r' = True
1355−isSpace _ = False
1356−
13571179-- Utilities
13581180
13591181-- | Adjusts a url according to the document's base URL.
@@ -1364,41 +1186,6 @@ canonicalizeUrl url = do
13641186 (Just rel, Just bs) -> tshow (rel `nonStrictRelativeTo` bs)
13651187 _ -> url
13661188
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−
14021189-- For now we need a special version here; the one in Shared has String type
14031190renderTags' :: [Tag Text] -> Text
14041191renderTags' = renderTagsOptions
@@ -1411,21 +1198,6 @@ renderTags' = renderTagsOptions
14111198-- EPUB Specific
14121199--
14131200--
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−
14291201{-
14301202
14311203types :: [(String, ([String], Int))]