@@ -27,36 +27,355 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
2727
2828Conversion of HTML to 'Pandoc' document.
2929-}
30−module Text.Pandoc.Readers.HTML (
31− readHtml,
32− rawHtmlInline,
33− rawHtmlBlock,
34− htmlTag,
35− anyHtmlBlockTag,
36− anyHtmlInlineTag,
37− anyHtmlTag,
38− anyHtmlEndTag,
39− htmlEndTag,
40− extractTagType,
41− htmlBlockElement,
42− htmlComment,
30+module Text.Pandoc.Readers.HTML ( readHtml
31+ , htmlTag
32+ , htmlInBalanced
33+ , isInlineTag
34+ , isBlockTag
35+ , isTextTag
36+ , isCommentTag
4337 ) where
4438
4539import Text.ParserCombinators.Parsec
40+import Text.ParserCombinators.Parsec.Pos
41+import Text.HTML.TagSoup
42+import Text.HTML.TagSoup.Match
4643import Text.Pandoc.Definition
44+import Text.Pandoc.Builder (text, toList)
4745import Text.Pandoc.Shared
4846import Text.Pandoc.Parsing
49−import Text.Pandoc.CharacterReferences ( decodeCharacterReferences )
50−import Data.Maybe ( fromMaybe )
51−import Data.List ( isPrefixOf, isSuffixOf, intercalate )
52−import Data.Char ( toLower, isAlphaNum )
53−import Control.Monad ( liftM, when )
47+import Data.Maybe ( fromMaybe, isJust )
48+import Data.List ( intercalate )
49+import Data.Char ( isSpace, isDigit )
50+import Control.Monad ( liftM, guard )
5451
5552-- | Convert HTML-formatted string to 'Pandoc' document.
5653readHtml :: ParserState -- ^ Parser state
5754 -> String -- ^ String to parse (assumes @'\n'@ line endings)
5855 -> Pandoc
59−readHtml = readWith parseHtml
56+readHtml st inp = Pandoc meta blocks
57+ where blocks = readWith parseBody st body
58+ tags = canonicalizeTags $
59+ parseTagsOptions parseOptions{ optTagPosition = True } inp
60+ hasHeader = any (~== TagOpen "head" []) tags
61+ (meta, rest) = if hasHeader
62+ then parseHeader tags
63+ else (Meta [] [] [], tags)
64+ body = filter (\t -> not $
65+ tagOpen (`elem` ["html","head","body"]) (const True) t ||
66+ tagClose (`elem` ["html","head","body"]) t) rest
67+
68+type TagParser = GenParser (Tag String) ParserState
69+
70+parseHeader :: [Tag String] -> (Meta, [Tag String])
71+parseHeader tags = (Meta{docTitle = tit'', docAuthors = [], docDate = []}, rest)
72+ where (tit,r) = break (~== TagClose "title") $ drop 1 $
73+ dropWhile (\t -> not $ t ~== TagOpen "title" []) tags
74+ tit' = concatMap fromTagText $ filter isTagText tit
75+ tit'' = normalizeSpaces $ toList $ text tit'
76+ rest = drop 1 $ dropWhile (\t -> not $ t ~== TagClose "head") r
77+
78+parseBody :: TagParser [Block]
79+parseBody = liftM concat $ manyTill block eof
80+
81+block :: TagParser [Block]
82+block = optional pLocation >>
83+ choice [
84+ pPara
85+ , pHeader
86+ , pBlockQuote
87+ , pCodeBlock
88+ , pList
89+ , pHrule
90+ , pPlain
91+ , pRawHtmlBlock
92+ ]
93+
94+renderTags' :: [Tag String] -> String
95+renderTags' = renderTagsOptions
96+ renderOptions{ optMinimize = (`elem` ["hr","br","img"]) }
97+
98+pList :: TagParser [Block]
99+pList = pBulletList <|> pOrderedList <|> pDefinitionList
100+
101+pBulletList :: TagParser [Block]
102+pBulletList = try $ do
103+ pSatisfy (~== TagOpen "ul" [])
104+ let nonItem = pSatisfy (\t ->
105+ not (tagOpen (`elem` ["li","ol","ul","dl"]) (const True) t) &&
106+ not (t ~== TagClose "ul"))
107+ -- note: if they have an <ol> or <ul> not in scope of a <li>,
108+ -- treat it as a list item, though it's not valid xhtml...
109+ skipMany nonItem
110+ items <- manyTill (pInTags "li" block >>~ skipMany nonItem) (pCloses "ul")
111+ return [BulletList items]
112+
113+pOrderedList :: TagParser [Block]
114+pOrderedList = try $ do
115+ TagOpen _ attribs <- pSatisfy (~== TagOpen "ol" [])
116+ st <- getState
117+ let (start, style) = if stateStrict st
118+ then (1, DefaultStyle)
119+ else (sta', sty')
120+ where sta = fromMaybe "1" $
121+ lookup "start" attribs
122+ sta' = if all isDigit sta
123+ then read sta
124+ else 1
125+ sty = fromMaybe (fromMaybe "" $
126+ lookup "style" attribs) $
127+ lookup "class" attribs
128+ sty' = case sty of
129+ "lower-roman" -> LowerRoman
130+ "upper-roman" -> UpperRoman
131+ "lower-alpha" -> LowerAlpha
132+ "upper-alpha" -> UpperAlpha
133+ "decimal" -> Decimal
134+ _ -> DefaultStyle
135+ let nonItem = pSatisfy (\t ->
136+ not (tagOpen (`elem` ["li","ol","ul","dl"]) (const True) t) &&
137+ not (t ~== TagClose "ol"))
138+ -- note: if they have an <ol> or <ul> not in scope of a <li>,
139+ -- treat it as a list item, though it's not valid xhtml...
140+ skipMany nonItem
141+ items <- manyTill (pInTags "li" block >>~ skipMany nonItem) (pCloses "ol")
142+ return [OrderedList (start, style, DefaultDelim) items]
143+
144+pDefinitionList :: TagParser [Block]
145+pDefinitionList = try $ do
146+ pSatisfy (~== TagOpen "dl" [])
147+ items <- manyTill pDefListItem (pCloses "dl")
148+ return [DefinitionList items]
149+
150+pDefListItem :: TagParser ([Inline],[[Block]])
151+pDefListItem = try $ do
152+ let nonItem = pSatisfy (\t -> not (t ~== TagOpen "dt" []) &&
153+ not (t ~== TagOpen "dd" []) && not (t ~== TagClose "dl"))
154+ terms <- many1 (try $ skipMany nonItem >> pInTags "dt" inline)
155+ defs <- many1 (try $ skipMany nonItem >> pInTags "dd" block)
156+ skipMany nonItem
157+ let term = intercalate [LineBreak] terms
158+ return (term, defs)
159+
160+pRawHtmlBlock :: TagParser [Block]
161+pRawHtmlBlock = do
162+ raw <- pHtmlBlock "script" <|> pHtmlBlock "style" <|>
163+ liftM (renderTags' . (:[])) pAnyTag
164+ state <- getState
165+ if stateParseRaw state
166+ then return [RawHtml raw]
167+ else return []
168+
169+pHtmlBlock :: String -> TagParser String
170+pHtmlBlock t = try $ do
171+ open <- pSatisfy (~== TagOpen t [])
172+ contents <- manyTill pAnyTag (pSatisfy (~== TagClose t))
173+ return $ renderTags' $ [open] ++ contents ++ [TagClose t]
174+
175+pHeader :: TagParser [Block]
176+pHeader = try $ do
177+ TagOpen tagtype attr <- pSatisfy $
178+ tagOpen (`elem` ["h1","h2","h3","h4","h5","h6"])
179+ (const True)
180+ let bodyTitle = TagOpen tagtype attr ~== TagOpen "h1" [("class","title")]
181+ let level = read (drop 1 tagtype)
182+ contents <- liftM concat $ manyTill inline (pCloses tagtype <|> eof)
183+ return $ if bodyTitle
184+ then [] -- skip a representation of the title in the body
185+ else [Header level $ normalizeSpaces contents]
186+
187+pHrule :: TagParser [Block]
188+pHrule = do
189+ pSelfClosing (=="hr") (const True)
190+ return [HorizontalRule]
191+
192+pBlockQuote :: TagParser [Block]
193+pBlockQuote = do
194+ contents <- pInTags "blockquote" block
195+ return [BlockQuote contents]
196+
197+pPlain :: TagParser [Block]
198+pPlain = do
199+ contents <- liftM (normalizeSpaces . concat) $ many1 inline
200+ if null contents
201+ then return []
202+ else return [Plain contents]
203+
204+pPara :: TagParser [Block]
205+pPara = do
206+ contents <- pInTags "p" inline
207+ return [Para $ normalizeSpaces contents]
208+
209+pCodeBlock :: TagParser [Block]
210+pCodeBlock = try $ do
211+ TagOpen _ attr <- pSatisfy (~== TagOpen "pre" [])
212+ contents <- manyTill pAnyTag (pCloses "pre" <|> eof)
213+ let rawText = concatMap fromTagText $ filter isTagText contents
214+ -- drop leading newline if any
215+ let result' = case rawText of
216+ '\n':xs -> xs
217+ _ -> rawText
218+ -- drop trailing newline if any
219+ let result = case reverse result' of
220+ '\n':_ -> init result'
221+ _ -> result'
222+ let attribsId = fromMaybe "" $ lookup "id" attr
223+ let attribsClasses = words $ fromMaybe "" $ lookup "class" attr
224+ let attribsKV = filter (\(k,_) -> k /= "class" && k /= "id") attr
225+ st <- getState
226+ let attribs = if stateStrict st
227+ then ("",[],[])
228+ else (attribsId, attribsClasses, attribsKV)
229+ return [CodeBlock attribs result]
230+
231+inline :: TagParser [Inline]
232+inline = choice [
233+ pLocation
234+ , pTagText
235+ , pEmph
236+ , pStrong
237+ , pSuperscript
238+ , pSubscript
239+ , pStrikeout
240+ , pLineBreak
241+ , pLink
242+ , pImage
243+ , pCode
244+ , pRawHtmlInline
245+ ]
246+
247+pLocation :: TagParser [a]
248+pLocation = do
249+ (TagPosition r c) <- pSatisfy isTagPosition
250+ setPosition $ newPos "input" r c
251+ return []
252+
253+pSatisfy :: (Tag String -> Bool) -> TagParser (Tag String)
254+pSatisfy f = do
255+ pos <- getPosition
256+ token show (const pos) (\x -> if f x then Just x else Nothing)
257+
258+pAnyTag :: TagParser (Tag String)
259+pAnyTag = pSatisfy (const True)
260+
261+pSelfClosing :: (String -> Bool) -> ([Attribute String] -> Bool)
262+ -> TagParser (Tag String)
263+pSelfClosing f g = do
264+ open <- pSatisfy (tagOpen f g)
265+ optional $ try $ pLocation >> pSatisfy (tagClose f)
266+ return open
267+
268+pEmph :: TagParser [Inline]
269+pEmph = pInlinesInTags "em" Emph <|> pInlinesInTags "i" Emph
270+
271+pStrong :: TagParser [Inline]
272+pStrong = pInlinesInTags "strong" Strong <|> pInlinesInTags "b" Strong
273+
274+pSuperscript :: TagParser [Inline]
275+pSuperscript = failIfStrict >> pInlinesInTags "sup" Superscript
276+
277+pSubscript :: TagParser [Inline]
278+pSubscript = failIfStrict >> pInlinesInTags "sub" Subscript
279+
280+pStrikeout :: TagParser [Inline]
281+pStrikeout = do
282+ failIfStrict
283+ pInlinesInTags "s" Strikeout <|>
284+ pInlinesInTags "strike" Strikeout <|>
285+ pInlinesInTags "del" Strikeout <|>
286+ do pSatisfy (~== TagOpen "span" [("class","strikeout")])
287+ contents <- liftM concat $ manyTill inline (pCloses "span")
288+ return [Strikeout contents]
289+
290+pLineBreak :: TagParser [Inline]
291+pLineBreak = do
292+ pSelfClosing (=="br") (const True)
293+ return [LineBreak]
294+
295+pLink :: TagParser [Inline]
296+pLink = do
297+ tag <- pSatisfy (tagOpenLit "a" (isJust . lookup "href"))
298+ let url = fromAttrib "href" tag
299+ let title = fromAttrib "title" tag
300+ lab <- liftM concat $ manyTill inline (pCloses "a")
301+ return [Link (normalizeSpaces lab) (escapeURI url, title)]
302+
303+pImage :: TagParser [Inline]
304+pImage = do
305+ tag <- pSelfClosing (=="img") (isJust . lookup "src")
306+ let url = fromAttrib "src" tag
307+ let title = fromAttrib "title" tag
308+ let alt = fromAttrib "alt" tag
309+ return [Image (toList $ text alt) (escapeURI url, title)]
310+
311+pCode :: TagParser [Inline]
312+pCode = do
313+ (TagOpen open _) <- pSatisfy $ tagOpen (`elem` ["code","tt"]) (const True)
314+ result <- manyTill pAnyTag (pCloses open)
315+ return [Code $ intercalate " " $ lines $ innerText result]
316+
317+pRawHtmlInline :: TagParser [Inline]
318+pRawHtmlInline = do
319+ result <- pSatisfy (tagComment (const True)) <|> pSatisfy isInlineTag
320+ state <- getState
321+ if stateParseRaw state
322+ then return [HtmlInline $ renderTags' [result]]
323+ else return []
324+
325+pInlinesInTags :: String -> ([Inline] -> Inline)
326+ -> TagParser [Inline]
327+pInlinesInTags tagtype f = do
328+ contents <- pInTags tagtype inline
329+ return [f contents]
330+
331+pInTags :: String -> TagParser [a]
332+ -> TagParser [a]
333+pInTags tagtype parser = try $ do
334+ pSatisfy (~== TagOpen tagtype [])
335+ liftM concat $ manyTill parser (pCloses tagtype <|> eof)
336+
337+pCloses :: String -> TagParser ()
338+pCloses tagtype = try $ do
339+ optional pLocation
340+ t <- lookAhead $ pSatisfy $ \tag -> isTagClose tag || isTagOpen tag
341+ case t of
342+ (TagClose t') | t' == tagtype -> pAnyTag >> return ()
343+ (TagOpen t' _) | t' `closes` tagtype -> return ()
344+ (TagClose "ul") | tagtype == "li" -> return ()
345+ (TagClose "ol") | tagtype == "li" -> return ()
346+ (TagClose "dl") | tagtype == "li" -> return ()
347+ _ -> pzero
348+
349+pTagText :: TagParser [Inline]
350+pTagText = do
351+ (TagText str) <- pSatisfy isTagText
352+ st <- getState
353+ case runParser (many pTagContents) st "text" str of
354+ Left _ -> fail $ "Could not parse `" ++ str ++ "'"
355+ Right result -> return result
356+
357+pTagContents :: GenParser Char ParserState Inline
358+pTagContents = pStr <|> pSpace <|> smartPunctuation pTagContents <|> pSymbol
359+
360+pStr :: GenParser Char ParserState Inline
361+pStr = many1 (satisfy (\c -> not (isSpace c) && not (isSpecial c))) >>= return . Str
362+
363+isSpecial :: Char -> Bool
364+isSpecial '"' = True
365+isSpecial '\'' = True
366+isSpecial '.' = True
367+isSpecial '-' = True
368+isSpecial '\8216' = True
369+isSpecial '\8217' = True
370+isSpecial '\8220' = True
371+isSpecial '\8221' = True
372+isSpecial _ = False
373+
374+pSymbol :: GenParser Char ParserState Inline
375+pSymbol = satisfy isSpecial >>= return . Str . (:[])
376+
377+pSpace :: GenParser Char ParserState Inline
378+pSpace = many1 (satisfy isSpace) >> return Space
60379
61380--
62381-- Constants
@@ -83,10 +402,26 @@ blockHtmlTags = ["address", "blockquote", "body", "center", "dir", "div",
83402 "dt", "frameset", "li", "tbody", "td", "tfoot",
84403 "th", "thead", "tr", "script", "style"]
85404
405+isInlineTag :: Tag String -> Bool
406+isInlineTag t = tagOpen (`notElem` blockHtmlTags) (const True) t ||
407+ tagClose (`notElem` blockHtmlTags) t ||
408+ tagComment (const True) t
409+
410+isBlockTag :: Tag String -> Bool
411+isBlockTag t = tagOpen (`elem` blocktags) (const True) t ||
412+ tagClose (`elem` blocktags) t ||
413+ tagComment (const True) t
414+ where blocktags = blockHtmlTags ++ eitherBlockOrInline
415+
416+isTextTag :: Tag String -> Bool
417+isTextTag = tagText (const True)
418+
419+isCommentTag :: Tag String -> Bool
420+isCommentTag = tagComment (const True)
421+
86422-- taken from HXT and extended
87423
88424closes :: String -> String -> Bool
89−"EOF" `closes` _ = True
90425_ `closes` "body" = False
91426_ `closes` "html" = False
92427"a" `closes` "a" = True
@@ -117,565 +452,27 @@ t1 `closes` t2 |
117452 t2 `notElem` (blockHtmlTags ++ eitherBlockOrInline) = True
118453_ `closes` _ = False
119454
120−--
121−-- HTML utility functions
122−--
123−
124−-- | Read blocks until end tag.
125−blocksTilEnd :: String -> GenParser Char ParserState [Block]
126−blocksTilEnd tag = do
127− blocks <- manyTill (block >>~ spaces) (htmlEndTag tag)
128− return $ filter (/= Null) blocks
129−
130−-- | Read inlines until end tag.
131−inlinesTilEnd :: String -> GenParser Char ParserState [Inline]
132−inlinesTilEnd tag = manyTill inline (htmlEndTag tag)
133−
134−-- | Parse blocks between open and close tag.
135−blocksIn :: String -> GenParser Char ParserState [Block]
136−blocksIn tag = try $ htmlOpenTag tag >> spaces >> blocksTilEnd tag
137−
138−-- | Parse inlines between open and close tag.
139−inlinesIn :: String -> GenParser Char ParserState [Inline]
140−inlinesIn tag = try $ htmlOpenTag tag >> spaces >> inlinesTilEnd tag
141−
142−-- | Extract type from a tag: e.g. @br@ from @\<br\>@
143−extractTagType :: String -> String
144−extractTagType ('<':rest) =
145− let isSpaceOrSlash c = c `elem` "/ \n\t" in
146− map toLower $ takeWhile isAlphaNum $ dropWhile isSpaceOrSlash rest
147−extractTagType _ = ""
148−
149−-- Parse any HTML tag (opening or self-closing) and return tag type
150−anyOpener :: GenParser Char ParserState [Char]
151−anyOpener = try $ do
152− char '<'
153− spaces
154− tag <- many1 alphaNum
155− skipMany htmlAttribute
156− spaces
157− option "" (string "/")
158− spaces
159− char '>'
160− return $ map toLower tag
161−
162−-- | Parse any HTML tag (opening or self-closing) and return text of tag
163−anyHtmlTag :: GenParser Char ParserState [Char]
164−anyHtmlTag = try $ do
165− char '<'
166− spaces
167− first <- letter
168− rest <- many (alphaNum <|> char ':')
169− let tag = first : rest
170− attribs <- many htmlAttribute
171− spaces
172− ender <- option "" (string "/")
173− let ender' = if null ender then "" else " /"
174− spaces
175− char '>'
176− let result = "<" ++ tag ++
177− concatMap (\(_, _, raw) -> (' ':raw)) attribs ++ ender' ++ ">"
178− return result
179−
180−anyHtmlEndTag :: GenParser Char ParserState [Char]
181−anyHtmlEndTag = try $ do
182− char '<'
183− spaces
184− char '/'
185− spaces
186− first <- letter
187− rest <- many (alphaNum <|> char ':')
188− let tag = first : rest
189− spaces
190− char '>'
191− let result = "</" ++ tag ++ ">"
192− return result
193−
194−htmlTag :: Bool
195− -> String
196− -> GenParser Char ParserState (String, [(String, String)])
197−htmlTag selfClosing tag = try $ do
198− char '<'
199− spaces
200− stringAnyCase tag
201− attribs <- many htmlAttribute
202− spaces
203− -- note: we want to handle both HTML and XHTML,
204− -- so we don't require the /
205− when selfClosing $ optional $ char '/' >> spaces
206− char '>'
207− return (tag, (map (\(name, content, _) -> (name, content)) attribs))
208−
209−htmlOpenTag :: String
210− -> GenParser Char ParserState (String, [(String, String)])
211−htmlOpenTag = htmlTag False
212−
213−htmlCloseTag :: String
214− -> GenParser Char ParserState (String, [(String, String)])
215−htmlCloseTag = htmlTag False . ('/':)
216−
217−htmlSelfClosingTag :: String
218− -> GenParser Char ParserState (String, [(String, String)])
219−htmlSelfClosingTag = htmlTag True
220−
221−-- parses a quoted html attribute value
222−quoted :: Char -> GenParser Char st (String, String)
223−quoted quoteChar = do
224− result <- between (char quoteChar) (char quoteChar)
225− (many (noneOf [quoteChar]))
226− return (result, [quoteChar])
227−
228−htmlAttribute :: GenParser Char ParserState ([Char], [Char], [Char])
229−htmlAttribute = do
230− attr <- htmlRegularAttribute <|> htmlMinimizedAttribute
231− return attr
232−
233−-- minimized boolean attribute
234−htmlMinimizedAttribute :: GenParser Char st ([Char], [Char], [Char])
235−htmlMinimizedAttribute = try $ do
236− many1 space
237− name <- many1 (choice [letter, oneOf ".-_:"])
238− return (name, name, name)
239−
240−htmlRegularAttribute :: GenParser Char st ([Char], [Char], [Char])
241−htmlRegularAttribute = try $ do
242− many1 space
243− name <- many1 (choice [letter, oneOf ".-_:"])
244− spaces
245− char '='
246− spaces
247− (content, quoteStr) <- choice [ (quoted '\''),
248− (quoted '"'),
249− (do
250− a <- many (noneOf " \t\n\r\"'<>")
251− return (a,"")) ]
252− return (name, content,
253− (name ++ "=" ++ quoteStr ++ content ++ quoteStr))
254−
255−-- | Parse an end tag of type 'tag'
256−htmlEndTag :: [Char] -> GenParser Char ParserState [Char]
257−htmlEndTag tag = try $ do
258− closedByNext <- lookAhead $ option False $ liftM (`closes` tag) $
259− anyOpener <|> (eof >> return "EOF")
260− if closedByNext
261− then return ""
262− else do char '<'
263− spaces
264− char '/'
265− spaces
266− stringAnyCase tag
267− spaces
268− char '>'
269− return $ "</" ++ tag ++ ">"
270−
271−-- | Returns @True@ if the tag is (or can be) a block tag.
272−isBlock :: String -> Bool
273−isBlock tag = (extractTagType tag) `elem` (blockHtmlTags ++ eitherBlockOrInline)
274−
275−anyHtmlBlockTag :: GenParser Char ParserState [Char]
276−anyHtmlBlockTag = try $ do
277− tag <- anyHtmlTag <|> anyHtmlEndTag
278− if isBlock tag then return tag else fail "not a block tag"
279−
280−anyHtmlInlineTag :: GenParser Char ParserState [Char]
281−anyHtmlInlineTag = try $ do
282− tag <- anyHtmlTag <|> anyHtmlEndTag
283− if not (isBlock tag) then return tag else fail "not an inline tag"
284−
285−-- | Parses material between script tags.
286−-- Scripts must be treated differently, because they can contain '<>' etc.
287−htmlScript :: GenParser Char ParserState [Char]
288−htmlScript = try $ do
289− lookAhead $ htmlOpenTag "script"
290− open <- anyHtmlTag
291− rest <- manyTill anyChar (htmlEndTag "script")
292− return $ open ++ rest ++ "</script>"
293−
294−-- | Parses material between style tags.
295−-- Style tags must be treated differently, because they can contain CSS
296−htmlStyle :: GenParser Char ParserState [Char]
297−htmlStyle = try $ do
298− lookAhead $ htmlOpenTag "style"
299− open <- anyHtmlTag
300− rest <- manyTill anyChar (htmlEndTag "style")
301− return $ open ++ rest ++ "</style>"
302−
303−htmlBlockElement :: GenParser Char ParserState [Char]
304−htmlBlockElement = choice [ htmlScript, htmlStyle, htmlComment, xmlDec, definition ]
305−
306−rawHtmlBlock :: GenParser Char ParserState Block
307−rawHtmlBlock = try $ do
308− body <- htmlBlockElement <|> rawVerbatimBlock <|> anyHtmlBlockTag
309− state <- getState
310− if stateParseRaw state then return (RawHtml body) else return Null
311−
312−-- This is a block whose contents should be passed through verbatim, not interpreted.
313−rawVerbatimBlock :: GenParser Char ParserState [Char]
314−rawVerbatimBlock = try $ do
315− start <- anyHtmlBlockTag
316− let tagtype = extractTagType start
317− if tagtype `elem` ["pre"]
318− then do
319− contents <- many (notFollowedBy' (htmlEndTag tagtype) >> anyChar)
320− end <- htmlEndTag tagtype
321− return $ start ++ contents ++ end
322− else fail "Not a verbatim block"
323−
324−-- We don't want to parse </body> or </html> as raw HTML, since these
325−-- are handled in parseHtml.
326−rawHtmlBlock' :: GenParser Char ParserState Block
327−rawHtmlBlock' = do notFollowedBy' (htmlCloseTag "body" <|>
328− htmlCloseTag "html")
329− rawHtmlBlock
330−
331−-- | Parses an HTML comment.
332−htmlComment :: GenParser Char st [Char]
333−htmlComment = try $ do
334− string "<!--"
335− comment <- many $ noneOf "-"
336− <|> try (char '-' >>~ notFollowedBy (try (char '-' >> char '>')))
337− string "-->"
338− return $ "<!--" ++ comment ++ "-->"
339−
340−--
341−-- parsing documents
342−--
343−
344−xmlDec :: GenParser Char st [Char]
345−xmlDec = try $ do
346− string "<?"
347− rest <- manyTill anyChar (char '>')
348− return $ "<?" ++ rest ++ ">"
349−
350−definition :: GenParser Char st [Char]
351−definition = try $ do
352− string "<!"
353− rest <- manyTill anyChar (char '>')
354− return $ "<!" ++ rest ++ ">"
355−
356−nonTitleNonHead :: GenParser Char ParserState Char
357−nonTitleNonHead = try $ do
358− notFollowedBy $ (htmlOpenTag "title" >> return ' ') <|>
359− (htmlEndTag "head" >> return ' ')
360− (rawHtmlBlock >> return ' ') <|> anyChar
361−
362−parseTitle :: GenParser Char ParserState [Inline]
363−parseTitle = try $ do
364− (tag, _) <- htmlOpenTag "title"
365− contents <- inlinesTilEnd tag
366− spaces
367− return contents
368−
369−-- parse header and return meta-information (for now, just title)
370−parseHead :: GenParser Char ParserState Meta
371−parseHead = try $ do
372− htmlOpenTag "head"
373− spaces
374− skipMany nonTitleNonHead
375− contents <- option [] parseTitle
376− skipMany nonTitleNonHead
377− htmlEndTag "head"
378− return $ Meta contents [] []
379−
380−-- h1 class="title" representation of title in body
381−bodyTitle :: GenParser Char ParserState [Inline]
382−bodyTitle = try $ do
383− (_, attribs) <- htmlOpenTag "h1"
384− case (extractAttribute "class" attribs) of
385− Just "title" -> return ""
386− _ -> fail "not title"
387− inlinesTilEnd "h1"
388−
389−endOfDoc :: GenParser Char ParserState ()
390−endOfDoc = try $ do
391− spaces
392− optional (htmlEndTag "body")
393− spaces
394− optional (htmlEndTag "html" >> many anyChar) -- ignore stuff after </html>
395− eof
396−
397−parseHtml :: GenParser Char ParserState Pandoc
398−parseHtml = do
399− sepEndBy (choice [xmlDec, definition, htmlComment]) spaces
400− spaces
401− optional $ htmlOpenTag "html"
402− spaces
403− meta <- option (Meta [] [] []) parseHead
404− spaces
405− optional $ htmlOpenTag "body"
406− spaces
407− optional bodyTitle -- skip title in body, because it's represented in meta
408− blocks <- parseBlocks
409− endOfDoc
410− return $ Pandoc meta blocks
411−
412−--
413−-- parsing blocks
414−--
415−
416−parseBlocks :: GenParser Char ParserState [Block]
417−parseBlocks = spaces >> sepEndBy block spaces >>= (return . filter (/= Null))
418−
419−block :: GenParser Char ParserState Block
420−block = choice [ codeBlock
421− , header
422− , hrule
423− , list
424− , blockQuote
425− , para
426− , plain
427− , rawHtmlBlock'
428− , notFollowedBy' endOfDoc >> char '<' >> return Null
429− ] <?> "block"
430−
431−--
432−-- header blocks
433−--
434−
435−header :: GenParser Char ParserState Block
436−header = choice (map headerLevel (enumFromTo 1 5)) <?> "header"
437−
438−headerLevel :: Int -> GenParser Char ParserState Block
439−headerLevel n = try $ do
440− let level = "h" ++ show n
441− htmlOpenTag level
442− contents <- inlinesTilEnd level
443− return $ Header n (normalizeSpaces contents)
444−
445−--
446−-- hrule block
447−--
448−
449−hrule :: GenParser Char ParserState Block
450−hrule = try $ do
451− (_, attribs) <- htmlSelfClosingTag "hr"
452− state <- getState
453− if not (null attribs) && stateParseRaw state
454− then unexpected "attributes in hr" -- parse as raw in this case
455− else return HorizontalRule
456−
457−--
458−-- code blocks
459−--
460−
461−-- Note: HTML tags in code blocks (e.g. for syntax highlighting) are
462−-- skipped, because they are not portable to output formats other than HTML.
463−codeBlock :: GenParser Char ParserState Block
464−codeBlock = try $ do
465− htmlOpenTag "pre"
466− result <- manyTill
467− (many1 (satisfy (/= '<')) <|>
468− ((anyHtmlTag <|> anyHtmlEndTag) >> return ""))
469− (htmlEndTag "pre")
470− let result' = concat result
471− -- drop leading newline if any
472− let result'' = if "\n" `isPrefixOf` result'
473− then drop 1 result'
474− else result'
475− -- drop trailing newline if any
476− let result''' = if "\n" `isSuffixOf` result''
477− then init result''
478− else result''
479− return $ CodeBlock ("",[],[]) $ decodeCharacterReferences result'''
480−
481−--
482−-- block quotes
483−--
484−
485−blockQuote :: GenParser Char ParserState Block
486−blockQuote = try $ htmlOpenTag "blockquote" >> spaces >>
487− blocksTilEnd "blockquote" >>= (return . BlockQuote)
488−
489−--
490−-- list blocks
491−--
492−
493−list :: GenParser Char ParserState Block
494−list = choice [ bulletList, orderedList, definitionList ] <?> "list"
495−
496−orderedList :: GenParser Char ParserState Block
497−orderedList = try $ do
498− (_, attribs) <- htmlOpenTag "ol"
499− (start, style) <- option (1, DefaultStyle) $
500− do failIfStrict
501− let sta = fromMaybe "1" $
502− lookup "start" attribs
503− let sty = fromMaybe (fromMaybe "" $
504− lookup "style" attribs) $
505− lookup "class" attribs
506− let sty' = case sty of
507− "lower-roman" -> LowerRoman
508− "upper-roman" -> UpperRoman
509− "lower-alpha" -> LowerAlpha
510− "upper-alpha" -> UpperAlpha
511− "decimal" -> Decimal
512− _ -> DefaultStyle
513− return (read sta, sty')
514− spaces
515− -- note: if they have an <ol> or <ul> not in scope of a <li>,
516− -- treat it as a list item, though it's not valid xhtml...
517− items <- sepEndBy1 (blocksIn "li" <|> liftM (:[]) list) spaces
518− htmlEndTag "ol"
519− return $ OrderedList (start, style, DefaultDelim) items
520−
521−bulletList :: GenParser Char ParserState Block
522−bulletList = try $ do
523− htmlOpenTag "ul"
524− spaces
525− -- note: if they have an <ol> or <ul> not in scope of a <li>,
526− -- treat it as a list item, though it's not valid xhtml...
527− items <- sepEndBy1 (blocksIn "li" <|> liftM (:[]) list) spaces
528− htmlEndTag "ul"
529− return $ BulletList items
530−
531−definitionList :: GenParser Char ParserState Block
532−definitionList = try $ do
533− failIfStrict -- def lists not part of standard markdown
534− htmlOpenTag "dl"
535− spaces
536− items <- sepEndBy1 definitionListItem spaces
537− htmlEndTag "dl"
538− return $ DefinitionList items
539−
540−definitionListItem :: GenParser Char ParserState ([Inline], [[Block]])
541−definitionListItem = try $ do
542− terms <- sepEndBy1 (inlinesIn "dt") spaces
543− defs <- sepEndBy1 (blocksIn "dd") spaces
544− let term = intercalate [LineBreak] terms
545− return (term, defs)
546−
547−--
548−-- paragraph block
549−--
550−
551−para :: GenParser Char ParserState Block
552−para = try $ htmlOpenTag "p" >> inlinesTilEnd "p" >>=
553− return . Para . normalizeSpaces
554−
555−--
556−-- plain block
557−--
558−
559−plain :: GenParser Char ParserState Block
560−plain = many1 inline >>= return . Plain . normalizeSpaces
561−
562−--
563−-- inline
564−--
565−
566−inline :: GenParser Char ParserState Inline
567−inline = choice [ str
568− , strong
569− , emph
570− , superscript
571− , subscript
572− , strikeout
573− , spanStrikeout
574− , code
575− , linebreak
576− , whitespace
577− , link
578− , image
579− , smartPunctuation inline
580− , charRef
581− , rawHtmlInline
582− , symbol
583− ] <?> "inline"
584−
585−code :: GenParser Char ParserState Inline
586−code = try $ do
587− result <- (htmlOpenTag "code" >> manyTill (noneOf "<>") (htmlEndTag "code"))
588− <|> (htmlOpenTag "tt" >> manyTill (noneOf "<>") (htmlEndTag "tt"))
589− -- remove internal line breaks, leading and trailing space,
590− -- and decode character references
591− return $ Code $ decodeCharacterReferences $ removeLeadingTrailingSpace $
592− intercalate " " $ lines result
593−
594−rawHtmlInline :: GenParser Char ParserState Inline
595−rawHtmlInline = do
596− result <- anyHtmlInlineTag <|> htmlComment
597− state <- getState
598− if stateParseRaw state then return (HtmlInline result) else return (Str "")
599−
600−symbol :: GenParser Char ParserState Inline
601−symbol = do
602− notFollowedBy (char '<')
603− c <- oneOf specialChars
604− return $ Str [c]
605−
606−betweenTags :: [Char] -> GenParser Char ParserState [Inline]
607−betweenTags tag = try $ htmlOpenTag tag >> inlinesTilEnd tag >>=
608− return . normalizeSpaces
609−
610−emph :: GenParser Char ParserState Inline
611−emph = (betweenTags "em" <|> betweenTags "i") >>= return . Emph
612−
613−strong :: GenParser Char ParserState Inline
614−strong = (betweenTags "b" <|> betweenTags "strong") >>= return . Strong
615−
616−superscript :: GenParser Char ParserState Inline
617−superscript = failIfStrict >> betweenTags "sup" >>= return . Superscript
618−
619−subscript :: GenParser Char ParserState Inline
620−subscript = failIfStrict >> betweenTags "sub" >>= return . Subscript
621−
622−strikeout :: GenParser Char ParserState Inline
623−strikeout = failIfStrict >> (betweenTags "s" <|> betweenTags "strike") >>=
624− return . Strikeout
625−
626−spanStrikeout :: GenParser Char ParserState Inline
627−spanStrikeout = try $ do
628− failIfStrict -- strict markdown has no strikeout, so treat as raw HTML
629− (_, attributes) <- htmlOpenTag "span"
630− result <- case (extractAttribute "class" attributes) of
631− Just "strikeout" -> inlinesTilEnd "span"
632− _ -> fail "not a strikeout"
633− return $ Strikeout result
634−
635−whitespace :: GenParser Char st Inline
636−whitespace = many1 space >> return Space
637−
638−-- hard line break
639−linebreak :: GenParser Char ParserState Inline
640−linebreak = htmlSelfClosingTag "br" >> optional newline >> return LineBreak
641−
642−str :: GenParser Char st Inline
643−str = many1 (noneOf $ specialChars ++ " \t\n") >>= return . Str
644−
645−specialChars :: [Char]
646−specialChars = "<&-\"'.\8216\8217\8220\8221"
647−
648−--
649−-- links and images
650−--
651−
652−-- extract contents of attribute (attribute names are case-insensitive)
653−extractAttribute :: [Char] -> [([Char], String)] -> Maybe String
654−extractAttribute _ [] = Nothing
655−extractAttribute name ((attrName, contents):rest) =
656− let name' = map toLower name
657− attrName' = map toLower attrName
658− in if attrName' == name'
659− then Just (decodeCharacterReferences contents)
660− else extractAttribute name rest
661−
662−link :: GenParser Char ParserState Inline
663−link = try $ do
664− (_, attributes) <- htmlOpenTag "a"
665− url <- case (extractAttribute "href" attributes) of
666− Just url -> return url
667− Nothing -> fail "no href"
668− let title = fromMaybe "" $ extractAttribute "title" attributes
669− lab <- inlinesTilEnd "a"
670− return $ Link (normalizeSpaces lab) (escapeURI url, title)
671−
672−image :: GenParser Char ParserState Inline
673−image = try $ do
674− (_, attributes) <- htmlSelfClosingTag "img"
675− url <- case (extractAttribute "src" attributes) of
676− Just url -> return url
677− Nothing -> fail "no src"
678− let title = fromMaybe "" $ extractAttribute "title" attributes
679− let alt = fromMaybe "" (extractAttribute "alt" attributes)
680− return $ Image [Str alt] (escapeURI url, title)
681−
455+--- parsers for use in markdown, textile readers
456+
457+-- | Matches a stretch of HTML in balanced tags.
458+htmlInBalanced :: (Tag String -> Bool) -> GenParser Char ParserState String
459+htmlInBalanced f = try $ do
460+ (TagOpen t _, tag) <- htmlTag f
461+ guard $ '/' `notElem` tag -- not a self-closing tag
462+ let nonTagChunk = many1 $ satisfy (/= '<')
463+ let stopper = htmlTag (~== TagClose t)
464+ let anytag = liftM snd $ htmlTag (const True)
465+ contents <- many $ notFollowedBy' stopper >>
466+ (nonTagChunk <|> htmlInBalanced (const True) <|> anytag)
467+ endtag <- liftM snd stopper
468+ return $ tag ++ concat contents ++ endtag
469+
470+-- | Matches a tag meeting a certain condition.
471+htmlTag :: (Tag String -> Bool) -> GenParser Char ParserState (Tag String, String)
472+htmlTag f = try $ do
473+ lookAhead (char '<')
474+ (next : _) <- getInput >>= return . canonicalizeTags . parseTags
475+ guard $ f next
476+ -- advance the parser
477+ rendered <- manyTill anyChar (char '>')
478+ return (next, rendered ++ ">")