HTML reader: support row or column-spanning table cells

2 files changed, 26 insertions, 28 deletions

diff --git a/src/Text/Pandoc/Readers/HTML.hs b/src/Text/Pandoc/Readers/HTML.hs
index 177a39be0..e33dface7 100644
--- a/src/Text/Pandoc/Readers/HTML.hs
+++ b/src/Text/Pandoc/Readers/HTML.hs
@@ -476,18 +476,10 @@ pHrule = do
 pTable :: PandocMonad m => TagParser m Blocks
 pTable = pTable' block pCell
 
-noColOrRowSpans :: Tag Text -> Bool
-noColOrRowSpans t = isNullOrOne "colspan" && isNullOrOne "rowspan"
-  where isNullOrOne x = case fromAttrib x t of
-                              ""  -> True
-                              "1" -> True
-                              _   -> False
-
-pCell :: PandocMonad m => Text -> TagParser m [(Alignment, Blocks)]
+pCell :: PandocMonad m => Text -> TagParser m [Cell]
 pCell celltype = try $ do
   skipMany pBlank
-  tag <- lookAhead $
-           pSatisfy (\t -> t ~== TagOpen celltype [] && noColOrRowSpans t)
+  tag <- lookAhead $ pSatisfy (\t -> t ~== TagOpen celltype [])
   let extractAlign' []                 = ""
       extractAlign' ("text-align":x:_) = x
       extractAlign' (_:xs)             = extractAlign' xs
@@ -498,9 +490,13 @@ pCell celltype = try $ do
                    Just "right"  -> AlignRight
                    Just "center" -> AlignCenter
                    _             -> AlignDefault
-  res <- pInTags' celltype noColOrRowSpans block
+  let rowspan = RowSpan . fromMaybe 1 $
+                safeRead =<< maybeFromAttrib "rowspan" tag
+  let colspan = ColSpan . fromMaybe 1 $
+                safeRead =<< maybeFromAttrib "colspan" tag
+  res <- pInTags celltype block
   skipMany pBlank
-  return [(align, res)]
+  return [B.cell align rowspan colspan res]
 
 pBlockQuote :: PandocMonad m => TagParser m Blocks
 pBlockQuote = do
diff --git a/src/Text/Pandoc/Readers/HTML/Table.hs b/src/Text/Pandoc/Readers/HTML/Table.hs
index bebb75df6..eba84884f 100644
--- a/src/Text/Pandoc/Readers/HTML/Table.hs
+++ b/src/Text/Pandoc/Readers/HTML/Table.hs
@@ -59,8 +59,8 @@ pColgroup = try $ do
 
 -- | Parses a simple HTML table
 pTable' :: PandocMonad m
-        => TagParser m Blocks                          -- ^ Caption parser
-        -> (Text -> TagParser m [(Alignment, Blocks)]) -- ^ Table cell parser
+        => TagParser m Blocks           -- ^ Caption parser
+        -> (Text -> TagParser m [Cell]) -- ^ Table cell parser
         -> TagParser m Blocks
 pTable' block pCell = try $ do
   TagOpen _ attribs' <- pSatisfy (matchTagOpen "table" [])
@@ -73,35 +73,31 @@ pTable' block pCell = try $ do
                   pInTags "tr" (pCell "td" <|> pCell "th")
       pTBody = pInTag True "tbody" $ many1 pTr
   head'' <- pInTag False "thead" (option [] pTr) <|> pInTag True "thead" pTh
-  head'  <- map snd <$>
-             pInTag True "tbody"
+  head'  <- pInTag True "tbody"
                (if null head'' then pTh else return head'')
   topfoot <- option [] $ pInTag False "tfoot" $ many pTr
   rowsLs <- many pTBody
   bottomfoot <- option [] $ pInTag False "tfoot" $ many pTr
   TagClose _ <- pSatisfy (matchTagClose "table")
-  let rows'' = concat rowsLs <> topfoot <> bottomfoot
-  let rows''' = map (map snd) rows''
+  let rows = concat rowsLs <> topfoot <> bottomfoot
+      rows''' = map (map cellContents) rows
   -- fail on empty table
   guard $ not $ null head' && null rows'''
-  let isSimple = onlySimpleTableCells $ fmap B.toList <$> head':rows'''
+  let isSimple = onlySimpleTableCells $
+                 map cellContents head' : rows'''
   let cols = if null head'
                 then maximum (map length rows''')
                 else length head'
-  -- add empty cells to short rows
-  let addEmpties r = case cols - length r of
-                           n | n > 0 -> r <> replicate n mempty
-                             | otherwise -> r
-  let rows = map addEmpties rows'''
-  let aligns = case rows'' of
-                    (cs:_) -> take cols $ map fst cs ++ repeat AlignDefault
-                    _      -> replicate cols AlignDefault
+  let aligns = case rows of
+                 (cs:_) -> take cols $
+                           concatMap cellAligns cs ++ repeat AlignDefault
+                 _      -> replicate cols AlignDefault
   let widths = if null widths'
                   then if isSimple
                        then replicate cols ColWidthDefault
                        else replicate cols (ColWidth (1.0 / fromIntegral cols))
                   else widths'
-  let toRow = Row nullAttr . map B.simpleCell
+  let toRow = Row nullAttr
       toHeaderRow l = [toRow l | not (null l)]
   return $ B.tableWith attribs
                    (B.simpleCaption caption)
@@ -109,3 +105,9 @@ pTable' block pCell = try $ do
                    (TableHead nullAttr $ toHeaderRow head')
                    [TableBody nullAttr 0 [] $ map toRow rows]
                    (TableFoot nullAttr [])
+
+cellContents :: Cell -> [Block]
+cellContents (Cell _ _ _ _ bs) = bs
+
+cellAligns :: Cell -> [Alignment]
+cellAligns (Cell _ align _ (ColSpan cs) _) = replicate cs align