@@ -40,6 +40,7 @@ import Text.HTML.TagSoup
4040import Text.HTML.TagSoup.Match
4141import Text.Pandoc.Definition
4242import qualified Text.Pandoc.Builder as B
43+import Text.Pandoc.Builder (Blocks, Inlines, trimInlines)
4344import Text.Pandoc.Shared
4445import Text.Pandoc.Options
4546import Text.Pandoc.Parsing
@@ -48,6 +49,8 @@ import Data.List ( intercalate )
4849import Data.Char ( isDigit )
4950import Control.Monad ( liftM, guard, when, mzero )
5051import Control.Applicative ( (<$>), (<$), (<*) )
52+import Data.Monoid
53+import Data.Sequence (ViewL(..), ViewR(..), viewr, viewl)
5154
5255isSpace :: Char -> Bool
5356isSpace ' ' = True
@@ -66,30 +69,30 @@ readHtml opts inp =
6669 where tags = canonicalizeTags $
6770 parseTagsOptions parseOptions{ optTagPosition = True } inp
6871 parseDoc = do
69− blocks <- (fixPlains False . concat) <$> manyTill block eof
72+ blocks <- (fixPlains False) . mconcat <$> manyTill block eof
7073 meta <- stateMeta <$> getState
71− return $ Pandoc meta blocks
74+ return $ Pandoc meta (B.toList blocks)
7275
7376type TagParser = Parser [Tag String] ParserState
7477
75−pBody :: TagParser [Block]
78+pBody :: TagParser Blocks
7679pBody = pInTags "body" block
7780
78−pHead :: TagParser [Block]
79−pHead = pInTags "head" $ pTitle <|> pMetaTag <|> ([] <$ pAnyTag)
80− where pTitle = pInTags "title" inline >>= setTitle . normalizeSpaces
81− setTitle t = [] <$ (updateState $ B.setMeta "title" (B.fromList t))
81+pHead :: TagParser Blocks
82+pHead = pInTags "head" $ pTitle <|> pMetaTag <|> (mempty <$ pAnyTag)
83+ where pTitle = pInTags "title" inline >>= setTitle . trimInlines
84+ setTitle t = mempty <$ (updateState $ B.setMeta "title" t)
8285 pMetaTag = do
8386 mt <- pSatisfy (~== TagOpen "meta" [])
8487 let name = fromAttrib "name" mt
8588 if null name
86− then return []
89+ then return mempty
8790 else do
8891 let content = fromAttrib "content" mt
8992 updateState $ B.setMeta name (B.text content)
90− return []
93+ return mempty
9194
92−block :: TagParser [Block]
95+block :: TagParser Blocks
9396block = choice
9497 [ pPara
9598 , pHeader
@@ -105,10 +108,10 @@ block = choice
105108 , pRawHtmlBlock
106109 ]
107110
108−pList :: TagParser [Block]
111+pList :: TagParser Blocks
109112pList = pBulletList <|> pOrderedList <|> pDefinitionList
110113
111−pBulletList :: TagParser [Block]
114+pBulletList :: TagParser Blocks
112115pBulletList = try $ do
113116 pSatisfy (~== TagOpen "ul" [])
114117 let nonItem = pSatisfy (\t ->
@@ -118,9 +121,9 @@ pBulletList = try $ do
118121 -- treat it as a list item, though it's not valid xhtml...
119122 skipMany nonItem
120123 items <- manyTill (pInTags "li" block >>~ skipMany nonItem) (pCloses "ul")
121− return [BulletList $ map (fixPlains True) items]
124+ return $ B.bulletList $ map (fixPlains True) items
122125
123−pOrderedList :: TagParser [Block]
126+pOrderedList :: TagParser Blocks
124127pOrderedList = try $ do
125128 TagOpen _ attribs <- pSatisfy (~== TagOpen "ol" [])
126129 let (start, style) = (sta', sty')
@@ -146,27 +149,27 @@ pOrderedList = try $ do
146149 -- treat it as a list item, though it's not valid xhtml...
147150 skipMany nonItem
148151 items <- manyTill (pInTags "li" block >>~ skipMany nonItem) (pCloses "ol")
149− return [OrderedList (start, style, DefaultDelim) $ map (fixPlains True) items]
152+ return $ B.orderedListWith (start, style, DefaultDelim) $ map (fixPlains True) items
150153
151−pDefinitionList :: TagParser [Block]
154+pDefinitionList :: TagParser Blocks
152155pDefinitionList = try $ do
153156 pSatisfy (~== TagOpen "dl" [])
154157 items <- manyTill pDefListItem (pCloses "dl")
155− return [DefinitionList items]
158+ return $ B.definitionList items
156159
157−pDefListItem :: TagParser ([Inline],[[Block]])
160+pDefListItem :: TagParser (Inlines, [Blocks])
158161pDefListItem = try $ do
159162 let nonItem = pSatisfy (\t -> not (t ~== TagOpen "dt" []) &&
160163 not (t ~== TagOpen "dd" []) && not (t ~== TagClose "dl"))
161164 terms <- many1 (try $ skipMany nonItem >> pInTags "dt" inline)
162165 defs <- many1 (try $ skipMany nonItem >> pInTags "dd" block)
163166 skipMany nonItem
164− let term = intercalate [LineBreak] terms
167+ let term = foldl1 (\x y -> x <> B.linebreak <> y) terms
165168 return (term, map (fixPlains True) defs)
166169
167−fixPlains :: Bool -> [Block] -> [Block]
168−fixPlains inList bs = if any isParaish bs
169− then map plainToPara bs
170+fixPlains :: Bool -> Blocks -> Blocks
171+fixPlains inList bs = if any isParaish bs'
172+ then B.fromList $ map plainToPara bs'
170173 else bs
171174 where isParaish (Para _) = True
172175 isParaish (CodeBlock _ _) = True
@@ -178,6 +181,7 @@ fixPlains inList bs = if any isParaish bs
178181 isParaish _ = False
179182 plainToPara (Plain xs) = Para xs
180183 plainToPara x = x
184+ bs' = B.toList bs
181185
182186pRawTag :: TagParser String
183187pRawTag = do
@@ -187,20 +191,20 @@ pRawTag = do
187191 then return []
188192 else return $ renderTags' [tag]
189193
190−pDiv :: TagParser [Block]
194+pDiv :: TagParser Blocks
191195pDiv = try $ do
192196 getOption readerParseRaw >>= guard
193197 TagOpen _ attr <- lookAhead $ pSatisfy $ tagOpen (=="div") (const True)
194198 contents <- pInTags "div" block
195− return [Div (mkAttr attr) contents]
199+ return $ B.divWith (mkAttr attr) contents
196200
197−pRawHtmlBlock :: TagParser [Block]
201+pRawHtmlBlock :: TagParser Blocks
198202pRawHtmlBlock = do
199203 raw <- pHtmlBlock "script" <|> pHtmlBlock "style" <|> pRawTag
200204 parseRaw <- getOption readerParseRaw
201205 if parseRaw && not (null raw)
202− then return [RawBlock (Format "html") raw]
203− else return []
206+ then return $ B.rawBlock "html" raw
207+ else return mempty
204208
205209pHtmlBlock :: String -> TagParser String
206210pHtmlBlock t = try $ do
@@ -208,35 +212,34 @@ pHtmlBlock t = try $ do
208212 contents <- manyTill pAnyTag (pSatisfy (~== TagClose t))
209213 return $ renderTags' $ [open] ++ contents ++ [TagClose t]
210214
211−pHeader :: TagParser [Block]
215+pHeader :: TagParser Blocks
212216pHeader = try $ do
213217 TagOpen tagtype attr <- pSatisfy $
214218 tagOpen (`elem` ["h1","h2","h3","h4","h5","h6"])
215219 (const True)
216220 let bodyTitle = TagOpen tagtype attr ~== TagOpen "h1" [("class","title")]
217221 let level = read (drop 1 tagtype)
218− contents <- liftM concat $ manyTill inline (pCloses tagtype <|> eof)
222+ contents <- trimInlines . mconcat <$> manyTill inline (pCloses tagtype <|> eof)
219223 let ident = fromMaybe "" $ lookup "id" attr
220224 let classes = maybe [] words $ lookup "class" attr
221225 let keyvals = [(k,v) | (k,v) <- attr, k /= "class", k /= "id"]
222226 return $ if bodyTitle
223− then [] -- skip a representation of the title in the body
224− else [Header level (ident, classes, keyvals) $
225− normalizeSpaces contents]
227+ then mempty -- skip a representation of the title in the body
228+ else B.headerWith (ident, classes, keyvals) level contents
226229
227−pHrule :: TagParser [Block]
230+pHrule :: TagParser Blocks
228231pHrule = do
229232 pSelfClosing (=="hr") (const True)
230− return [HorizontalRule]
233+ return B.horizontalRule
231234
232−pTable :: TagParser [Block]
235+pTable :: TagParser Blocks
233236pTable = try $ do
234237 TagOpen _ _ <- pSatisfy (~== TagOpen "table" [])
235238 skipMany pBlank
236− caption <- option [] $ pInTags "caption" inline >>~ skipMany pBlank
239+ caption <- option mempty $ pInTags "caption" inline >>~ skipMany pBlank
237240 -- TODO actually read these and take width information from them
238241 widths' <- pColgroup <|> many pCol
239− head' <- option [] $ pOptInTag "thead" $ pInTags "tr" (pCell "th")
242+ head' <- option mempty $ pOptInTag "thead" $ pInTags "tr" (pCell "th")
240243 skipMany pBlank
241244 rows <- pOptInTag "tbody"
242245 $ many1 $ try $ skipMany pBlank >> pInTags "tr" (pCell "td")
@@ -245,19 +248,21 @@ pTable = try $ do
245248 let isSinglePlain [] = True
246249 isSinglePlain [Plain _] = True
247250 isSinglePlain _ = False
248− let isSimple = all isSinglePlain $ concat (head':rows)
249− let cols = length $ if null head'
250− then head rows
251− else head'
251+ let lHead = B.toList head'
252+ let lRows = map B.toList rows
253+ let isSimple = all isSinglePlain (lHead:lRows)
254+ let cols = length $ if null lHead
255+ then head lRows
256+ else lHead
252257 -- fail if there are colspans or rowspans
253− guard $ all (\r -> length r == cols) rows
258+ guard $ all (\r -> length r == cols) lRows
254259 let aligns = replicate cols AlignLeft
255260 let widths = if null widths'
256261 then if isSimple
257262 then replicate cols 0
258263 else replicate cols (1.0 / fromIntegral cols)
259264 else widths'
260− return [Table caption aligns widths head' rows]
265+ return $ B.table caption (zip aligns widths) [head'] [rows]
261266
262267pCol :: TagParser Double
263268pCol = try $ do
@@ -275,31 +280,31 @@ pColgroup = try $ do
275280 skipMany pBlank
276281 manyTill pCol (pCloses "colgroup" <|> eof) <* skipMany pBlank
277282
278−pCell :: String -> TagParser [TableCell]
283+pCell :: String -> TagParser Blocks
279284pCell celltype = try $ do
280285 skipMany pBlank
281286 res <- pInTags celltype block
282287 skipMany pBlank
283− return [res]
288+ return res
284289
285−pBlockQuote :: TagParser [Block]
290+pBlockQuote :: TagParser Blocks
286291pBlockQuote = do
287292 contents <- pInTags "blockquote" block
288− return [BlockQuote $ fixPlains False contents]
293+ return $ B.blockQuote $ fixPlains False contents
289294
290−pPlain :: TagParser [Block]
295+pPlain :: TagParser Blocks
291296pPlain = do
292− contents <- liftM (normalizeSpaces . concat) $ many1 inline
293− if null contents
294− then return []
295− else return [Plain contents]
297+ contents <- trimInlines . mconcat <$> many1 inline
298+ if B.isNull contents
299+ then return mempty
300+ else return $ B.plain contents
296301
297−pPara :: TagParser [Block]
302+pPara :: TagParser Blocks
298303pPara = do
299− contents <- pInTags "p" inline
300− return [Para $ normalizeSpaces contents]
304+ contents <- trimInlines <$> pInTags "p" inline
305+ return $ B.para contents
301306
302−pCodeBlock :: TagParser [Block]
307+pCodeBlock :: TagParser Blocks
303308pCodeBlock = try $ do
304309 TagOpen _ attr <- pSatisfy (~== TagOpen "pre" [])
305310 contents <- manyTill pAnyTag (pCloses "pre" <|> eof)
@@ -312,9 +317,9 @@ pCodeBlock = try $ do
312317 let result = case reverse result' of
313318 '\n':_ -> init result'
314319 _ -> result'
315− return [CodeBlock (mkAttr attr) result]
320+ return $ B.codeBlockWith (mkAttr attr) result
316321
317−inline :: TagParser [Inline]
322+inline :: TagParser Inlines
318323inline = choice
319324 [ pTagText
320325 , pQ
@@ -354,7 +359,7 @@ pSelfClosing f g = do
354359 optional $ pSatisfy (tagClose f)
355360 return open
356361
357−pQ :: TagParser [Inline]
362+pQ :: TagParser Inlines
358363pQ = do
359364 quoteContext <- stateQuoteContext `fmap` getState
360365 let quoteType = case quoteContext of
@@ -363,82 +368,93 @@ pQ = do
363368 let innerQuoteContext = if quoteType == SingleQuote
364369 then InSingleQuote
365370 else InDoubleQuote
366− withQuoteContext innerQuoteContext $ pInlinesInTags "q" (Quoted quoteType)
371+ let constructor = case quoteType of
372+ SingleQuote -> B.singleQuoted
373+ DoubleQuote -> B.doubleQuoted
374+ withQuoteContext innerQuoteContext $
375+ pInlinesInTags "q" constructor
367376
368−pEmph :: TagParser [Inline]
369−pEmph = pInlinesInTags "em" Emph <|> pInlinesInTags "i" Emph
377+pEmph :: TagParser Inlines
378+pEmph = pInlinesInTags "em" B.emph <|> pInlinesInTags "i" B.emph
370379
371−pStrong :: TagParser [Inline]
372−pStrong = pInlinesInTags "strong" Strong <|> pInlinesInTags "b" Strong
380+pStrong :: TagParser Inlines
381+pStrong = pInlinesInTags "strong" B.strong <|> pInlinesInTags "b" B.strong
373382
374−pSuperscript :: TagParser [Inline]
375−pSuperscript = pInlinesInTags "sup" Superscript
383+pSuperscript :: TagParser Inlines
384+pSuperscript = pInlinesInTags "sup" B.superscript
376385
377−pSubscript :: TagParser [Inline]
378−pSubscript = pInlinesInTags "sub" Subscript
386+pSubscript :: TagParser Inlines
387+pSubscript = pInlinesInTags "sub" B.subscript
379388
380−pStrikeout :: TagParser [Inline]
389+pStrikeout :: TagParser Inlines
381390pStrikeout = do
382− pInlinesInTags "s" Strikeout <|>
383− pInlinesInTags "strike" Strikeout <|>
384− pInlinesInTags "del" Strikeout <|>
391+ pInlinesInTags "s" B.strikeout <|>
392+ pInlinesInTags "strike" B.strikeout <|>
393+ pInlinesInTags "del" B.strikeout <|>
385394 try (do pSatisfy (~== TagOpen "span" [("class","strikeout")])
386− contents <- liftM concat $ manyTill inline (pCloses "span")
387− return [Strikeout contents])
395+ contents <- mconcat <$> manyTill inline (pCloses "span")
396+ return $ B.strikeout contents)
388397
389−pLineBreak :: TagParser [Inline]
398+pLineBreak :: TagParser Inlines
390399pLineBreak = do
391400 pSelfClosing (=="br") (const True)
392− return [LineBreak]
401+ return B.linebreak
393402
394−pLink :: TagParser [Inline]
403+pLink :: TagParser Inlines
395404pLink = try $ do
396405 tag <- pSatisfy (tagOpenLit "a" (isJust . lookup "href"))
397406 let url = fromAttrib "href" tag
398407 let title = fromAttrib "title" tag
399− lab <- liftM concat $ manyTill inline (pCloses "a")
400− return [Link (normalizeSpaces lab) (escapeURI url, title)]
408+ lab <- trimInlines . mconcat <$> manyTill inline (pCloses "a")
409+ return $ B.link (escapeURI url) title lab
401410
402−pImage :: TagParser [Inline]
411+pImage :: TagParser Inlines
403412pImage = do
404413 tag <- pSelfClosing (=="img") (isJust . lookup "src")
405414 let url = fromAttrib "src" tag
406415 let title = fromAttrib "title" tag
407416 let alt = fromAttrib "alt" tag
408− return [Image (B.toList $ B.text alt) (escapeURI url, title)]
417+ return $ B.image (escapeURI url) title (B.text alt)
409418
410−pCode :: TagParser [Inline]
419+pCode :: TagParser Inlines
411420pCode = try $ do
412421 (TagOpen open attr) <- pSatisfy $ tagOpen (`elem` ["code","tt"]) (const True)
413422 result <- manyTill pAnyTag (pCloses open)
414− return [Code (mkAttr attr) $ intercalate " " $ lines $ innerText result]
423+ return $ B.codeWith (mkAttr attr) $ intercalate " " $ lines $ innerText result
415424
416−pSpan :: TagParser [Inline]
425+pSpan :: TagParser Inlines
417426pSpan = try $ do
418427 getOption readerParseRaw >>= guard
419428 TagOpen _ attr <- lookAhead $ pSatisfy $ tagOpen (=="span") (const True)
420429 contents <- pInTags "span" inline
421− return [Span (mkAttr attr) contents]
430+ return $ B.spanWith (mkAttr attr) contents
422431
423−pRawHtmlInline :: TagParser [Inline]
432+pRawHtmlInline :: TagParser Inlines
424433pRawHtmlInline = do
425434 result <- pSatisfy (tagComment (const True)) <|> pSatisfy isInlineTag
426435 parseRaw <- getOption readerParseRaw
427436 if parseRaw
428− then return [RawInline (Format "html") $ renderTags' [result]]
429− else return []
437+ then return $ B.rawInline "html" $ renderTags' [result]
438+ else return mempty
430439
431−pInlinesInTags :: String -> ([Inline] -> Inline)
432− -> TagParser [Inline]
440+pInlinesInTags :: String -> (Inlines -> Inlines)
441+ -> TagParser Inlines
433442pInlinesInTags tagtype f = do
434− contents <- pInTags tagtype inline
435− return [f $ normalizeSpaces contents]
436−
437−pInTags :: String -> TagParser [a]
438− -> TagParser [a]
443+ contents <- B.unMany <$> pInTags tagtype inline
444+ let left = case viewl contents of
445+ EmptyL -> mempty
446+ (a :< _) -> padSpace a
447+ let right = case viewr contents of
448+ EmptyR -> mempty
449+ (_ :> a) -> padSpace a
450+ return (left <> f (trimInlines . B.Many $ contents) <> right)
451+ where padSpace a = if a == Space then B.space else mempty
452+
453+pInTags :: (Monoid a) => String -> TagParser a
454+ -> TagParser a
439455pInTags tagtype parser = try $ do
440456 pSatisfy (~== TagOpen tagtype [])
441− liftM concat $ manyTill parser (pCloses tagtype <|> eof)
457+ mconcat <$> manyTill parser (pCloses tagtype <|> eof)
442458
443459pOptInTag :: String -> TagParser a
444460 -> TagParser a
@@ -461,36 +477,36 @@ pCloses tagtype = try $ do
461477 (TagClose "dl") | tagtype == "li" -> return ()
462478 _ -> mzero
463479
464−pTagText :: TagParser [Inline]
480+pTagText :: TagParser Inlines
465481pTagText = try $ do
466482 (TagText str) <- pSatisfy isTagText
467483 st <- getState
468484 case runParser (many pTagContents) st "text" str of
469485 Left _ -> fail $ "Could not parse `" ++ str ++ "'"
470− Right result -> return result
486+ Right result -> return $ mconcat result
471487
472488pBlank :: TagParser ()
473489pBlank = try $ do
474490 (TagText str) <- pSatisfy isTagText
475491 guard $ all isSpace str
476492
477−pTagContents :: Parser [Char] ParserState Inline
493+pTagContents :: Parser [Char] ParserState Inlines
478494pTagContents =
479− Math DisplayMath `fmap` mathDisplay
480− <|> Math InlineMath `fmap` mathInline
495+ B.displayMath <$> mathDisplay
496+ <|> B.math <$> mathInline
481497 <|> pStr
482498 <|> pSpace
483499 <|> smartPunctuation pTagContents
484500 <|> pSymbol
485501 <|> pBad
486502
487−pStr :: Parser [Char] ParserState Inline
503+pStr :: Parser [Char] ParserState Inlines
488504pStr = do
489505 result <- many1 $ satisfy $ \c ->
490506 not (isSpace c) && not (isSpecial c) && not (isBad c)
491507 pos <- getPosition
492508 updateState $ \s -> s{ stateLastStrPos = Just pos }
493− return $ Str result
509+ return $ B.str result
494510
495511isSpecial :: Char -> Bool
496512isSpecial '"' = True
@@ -504,13 +520,13 @@ isSpecial '\8220' = True
504520isSpecial '\8221' = True
505521isSpecial _ = False
506522
507−pSymbol :: Parser [Char] ParserState Inline
508−pSymbol = satisfy isSpecial >>= return . Str . (:[])
523+pSymbol :: Parser [Char] ParserState Inlines
524+pSymbol = satisfy isSpecial >>= return . B.str . (:[])
509525
510526isBad :: Char -> Bool
511527isBad c = c >= '\128' && c <= '\159' -- not allowed in HTML
512528
513−pBad :: Parser [Char] ParserState Inline
529+pBad :: Parser [Char] ParserState Inlines
514530pBad = do
515531 c <- satisfy isBad
516532 let c' = case c of
@@ -542,10 +558,10 @@ pBad = do
542558 '\158' -> '\382'
543559 '\159' -> '\376'
544560 _ -> '?'
545− return $ Str [c']
561+ return $ B.str [c']
546562
547−pSpace :: Parser [Char] ParserState Inline
548−pSpace = many1 (satisfy isSpace) >> return Space
563+pSpace :: Parser [Char] ParserState Inlines
564+pSpace = many1 (satisfy isSpace) >> return B.space
549565
550566--
551567-- Constants
@@ -679,3 +695,4 @@ mkAttr attr = (attribsId, attribsClasses, attribsKV)
679695 attribsClasses = words $ fromMaybe "" $ lookup "class" attr
680696 attribsKV = filter (\(k,_) -> k /= "class" && k /= "id") attr
681697
698+