[WIP] Add colspan/rowspan support

pandoc.cabal

@@ -276,7 +276,7 @@ Library
                  xml >= 1.3.12 && < 1.4,
                  random >= 1 && < 1.2,
                  extensible-exceptions >= 0.1 && < 0.2,
-                 pandoc-types >= 1.17 && < 1.18,
+                 pandoc-types >= 1.17 && < 1.20,
                  aeson >= 0.7 && < 1.2,
                  aeson-pretty >= 0.8 && < 0.9,
                  tagsoup >= 0.13.7 && < 0.15,
@@ -501,7 +501,7 @@ Test-Suite test-pandoc
   Build-Depends:  base >= 4.2 && < 5,
                   syb >= 0.1 && < 0.8,
                   pandoc,
-                  pandoc-types >= 1.17 && < 1.18,
+                  pandoc-types >= 1.17 && < 1.20,
                   bytestring >= 0.9 && < 0.11,
                   text >= 0.11 && < 1.3,
                   directory >= 1 && < 1.4,

src/Text/Pandoc/Readers/LaTeX.hs

@@ -1086,11 +1086,11 @@ addImageCaption = walkM go
 
 addTableCaption :: PandocMonad m => Blocks -> LP m Blocks
 addTableCaption = walkM go
-  where go (Table c als ws hs rs) = do
+  where go (Table c als ws hspec rspec hs rs) = do
           mbcapt <- stateCaption <$> getState
           return $ case mbcapt of
-               Just ils -> Table (toList ils) als ws hs rs
-               Nothing  -> Table c als ws hs rs
+               Just ils -> Table (toList ils) als ws hspec rspec hs rs
+               Nothing  -> Table c als ws hspec rspec hs rs
         go x = return x
 
 environments :: PandocMonad m => M.Map String (LP m Blocks)

src/Text/Pandoc/Readers/MediaWiki.hs

@@ -237,23 +237,24 @@ table = do
   caption <- option mempty tableCaption
   optional rowsep
   hasheader <- option False $ True <$ (lookAhead (skipSpaces *> char '!'))
-  (cellspecs',hdr) <- unzip <$> tableRow
-  let widths = map ((tableWidth *) . snd) cellspecs'
+  (alignment',hspecs,hdr) <- unzip3 <$> tableRow
+  let widths = map ((tableWidth *) . snd) alignment'
   let restwidth = tableWidth - sum widths
   let zerocols = length $ filter (==0.0) widths
   let defaultwidth = if zerocols == 0 || zerocols == length widths
                         then 0.0
                         else restwidth / fromIntegral zerocols
   let widths' = map (\w -> if w == 0 then defaultwidth else w) widths
-  let cellspecs = zip (map fst cellspecs') widths'
-  rows' <- many $ try $ rowsep *> (map snd <$> tableRow)
+  let alignment = zip (map fst alignment') widths'
+  x <- many $ try $ rowsep *> (unzip3 <$> tableRow)
+  let (_, rspecs, rows') = unzip3 x
   optional blanklines
   tableEnd
   let cols = length hdr
   let (headers,rows) = if hasheader
                           then (hdr, rows')
                           else (replicate cols mempty, hdr:rows')
-  return $ B.table caption cellspecs headers rows
+  return $ B.fullTable caption alignment hspecs rspecs headers rows
 
 parseAttrs :: PandocMonad m => MWParser m [(String,String)]
 parseAttrs = many1 parseAttr
@@ -291,10 +292,10 @@ tableCaption = try $ do
   optional (try $ parseAttr *> skipSpaces *> char '|' *> skipSpaces)
   (trimInlines . mconcat) <$> many (notFollowedBy (cellsep <|> rowsep) *> inline)
 
-tableRow :: PandocMonad m => MWParser m [((Alignment, Double), Blocks)]
+tableRow :: PandocMonad m => MWParser m [((Alignment, Double), CellSpec, Blocks)]
 tableRow = try $ skipMany htmlComment *> many tableCell
 
-tableCell :: PandocMonad m => MWParser m ((Alignment, Double), Blocks)
+tableCell :: PandocMonad m => MWParser m ((Alignment, Double), CellSpec, Blocks)
 tableCell = try $ do
   cellsep
   skipMany spaceChar
@@ -314,7 +315,12 @@ tableCell = try $ do
   let width = case lookup "width" attrs of
                     Just xs -> fromMaybe 0.0 $ parseWidth xs
                     Nothing -> 0.0
-  return ((align, width), bs)
+  let rowspan = fromMaybe 1 $ (lookup "rowspan" attrs) >>= parseSpec
+  let colspan = fromMaybe 1 $ (lookup "colspan" attrs) >>= parseSpec
+  return ((align, width), (colspan, rowspan), bs)
+
+parseSpec :: String -> Maybe Int
+parseSpec s = safeRead s
 
 parseWidth :: String -> Maybe Double
 parseWidth s =

src/Text/Pandoc/Readers/Odt/ContentReader.hs

@@ -915,8 +915,8 @@ post_process (Pandoc m blocks) =
   Pandoc m (post_process' blocks)
 
 post_process' :: [Block] -> [Block]
-post_process' ((Table _ a w h r) : (Div ("", ["caption"], _) [Para inlines] ) : xs) =
-  (Table inlines a w h r) : ( post_process' xs )
+post_process' ((Table _ a w hspec rspec h r) : (Div ("", ["caption"], _) [Para inlines] ) : xs) =
+  (Table inlines a w hspec rspec h r) : ( post_process' xs )
 post_process' bs = bs
 
 read_body :: OdtReader _x (Pandoc, MediaBag)

src/Text/Pandoc/Readers/RST.hs

@@ -762,12 +762,12 @@ tableDirective :: PandocMonad m
 tableDirective top _fields body = do
   bs <- parseFromString parseBlocks body
   case B.toList bs of
-       [Table _ aligns' widths' header' rows'] -> do
+       [Table _ aligns' widths' hspec rspec header' rows'] -> do
          title <- parseFromString (trimInlines . mconcat <$> many inline) top
          -- TODO widths
          -- align is not applicable since we can't represent whole table align
          return $ B.singleton $ Table (B.toList title)
-                                  aligns' widths' header' rows'
+                                  aligns' widths' hspec rspec header' rows'
        _ -> return mempty
 
 -- TODO:
@@ -1122,8 +1122,8 @@ simpleTable headless = do
               sep simpleTableFooter
   -- Simple tables get 0s for relative column widths (i.e., use default)
   case B.toList tbl of
-       [Table c a _w h l]  -> return $ B.singleton $
-                                 Table c a (replicate (length a) 0) h l
+       [Table c a _w hspec rspec h l]  -> return $ B.singleton $
+                                 Table c a (replicate (length a) 0) hspec rspec h l
        _ ->
          throwError $ PandocShouldNeverHappenError
             "tableWith returned something unexpected"

src/Text/Pandoc/Shared.hs

@@ -826,7 +826,7 @@ blockToInlines (DefinitionList pairslst) =
       (concatMap blocksToInlines blkslst)
 blockToInlines (Header _ _  ils) = ils
 blockToInlines (HorizontalRule) = []
-blockToInlines (Table _ _ _ headers rows) =
+blockToInlines (Table _ _ _ _ _ headers rows) =
   intercalate [LineBreak] $ map (concatMap blocksToInlines) tbl
   where
     tbl = headers : rows

src/Text/Pandoc/Writers/AsciiDoc.hs

@@ -193,7 +193,7 @@ blockToAsciiDoc opts (BlockQuote blocks) = do
   let cols = offset contents'
   let bar = text $ replicate cols '_'
   return $ bar $$ chomp contents' $$ bar <> blankline
-blockToAsciiDoc opts (Table caption aligns widths headers rows) =  do
+blockToAsciiDoc opts (Table caption aligns widths _ _ headers rows) =  do
   caption' <- inlineListToAsciiDoc opts caption
   let caption'' = if null caption
                      then empty

src/Text/Pandoc/Writers/CommonMark.hs

@@ -137,7 +137,7 @@ blockToNodes (DefinitionList items) ns = blockToNodes (BulletList items') ns
           Plain (term ++ [LineBreak] ++ xs) : ys ++ concat zs
         dlToBullet (term, xs) =
           Para term : concat xs
-blockToNodes t@(Table _ _ _ _ _) ns = do
+blockToNodes t@(Table _ _ _ _ _ _ _) ns = do
   s <- writeHtml5String def $! Pandoc nullMeta [t]
   return (node (HTML_BLOCK (T.pack $! s)) [] : ns)
 blockToNodes Null ns = return ns

src/Text/Pandoc/Writers/ConTeXt.hs

@@ -242,7 +242,7 @@ blockToConTeXt (DefinitionList lst) =
 blockToConTeXt HorizontalRule = return $ "\\thinrule" <> blankline
 -- If this is ever executed, provide a default for the reference identifier.
 blockToConTeXt (Header level attr lst) = sectionHeader attr level lst
-blockToConTeXt (Table caption aligns widths heads rows) = do
+blockToConTeXt (Table caption aligns widths _ _ heads rows) = do
     let colDescriptor colWidth alignment = (case alignment of
                                                AlignLeft    -> 'l'
                                                AlignRight   -> 'r'

src/Text/Pandoc/Writers/Custom.hs

@@ -243,8 +243,8 @@ blockToCustom lua (CodeBlock attr str) =
 
 blockToCustom lua (BlockQuote blocks) = callfunc lua "BlockQuote" blocks
 
-blockToCustom lua (Table capt aligns widths headers rows') =
-  callfunc lua "Table" capt (map show aligns) widths headers rows'
+blockToCustom lua (Table capt aligns widths hspecs rspecs headers rows') =
+  callfunc lua "Table" capt (map show aligns) hspecs rspecs widths headers rows'
 
 blockToCustom lua (BulletList items) = callfunc lua "BulletList" items
 

src/Text/Pandoc/Writers/Docbook.hs

@@ -288,7 +288,7 @@ blockToDocbook _ b@(RawBlock f str)
       report $ BlockNotRendered b
       return empty
 blockToDocbook _ HorizontalRule = return empty -- not semantic
-blockToDocbook opts (Table caption aligns widths headers rows) = do
+blockToDocbook opts (Table caption aligns widths _ _ headers rows) = do
   captionDoc <- if null caption
                    then return empty
                    else inTagsIndented "title" <$>

src/Text/Pandoc/Writers/Docx.hs

@@ -894,7 +894,7 @@ blockToOpenXML' _ HorizontalRule = do
     $ mknode "v:rect" [("style","width:0;height:1.5pt"),
                        ("o:hralign","center"),
                        ("o:hrstd","t"),("o:hr","t")] () ]
-blockToOpenXML' opts (Table caption aligns widths headers rows) = do
+blockToOpenXML' opts (Table caption aligns widths _ _ headers rows) = do
   setFirstPara
   let captionStr = stringify caption
   caption' <- if null caption

src/Text/Pandoc/Writers/DokuWiki.hs

@@ -187,7 +187,7 @@ blockToDokuWiki opts (BlockQuote blocks) = do
      then return $ unlines $ map ("> " ++) $ lines contents
      else return $ "<HTML><blockquote>\n" ++ contents ++ "</blockquote></HTML>"
 
-blockToDokuWiki opts (Table capt aligns _ headers rows) = do
+blockToDokuWiki opts (Table capt aligns _ _ _ headers rows) = do
   captionDoc <- if null capt
                    then return ""
                    else do

src/Text/Pandoc/Writers/FB2.hs

@@ -362,7 +362,7 @@ blockToXml HorizontalRule = return
                             [ el "empty-line" ()
                             , el "p" (txt (replicate 10 '—'))
                             , el "empty-line" () ]
-blockToXml (Table caption aligns _ headers rows) = do
+blockToXml (Table caption aligns _ _ _ headers rows) = do
     hd <- mkrow "th" headers aligns
     bd <- mapM (\r -> mkrow "td" r aligns) rows
     c <- return . el "emphasis" =<< cMapM toXml caption

src/Text/Pandoc/Writers/HTML.hs

@@ -733,7 +733,7 @@ blockToHtml opts (DefinitionList lst) = do
                      return $ mconcat $ nl opts : term' : nl opts :
                                         intersperse (nl opts) defs') lst
   defList opts contents
-blockToHtml opts (Table capt aligns widths headers rows') = do
+blockToHtml opts (Table capt aligns widths hspecs rspecs headers rows') = do
   captionDoc <- if null capt
                    then return mempty
                    else do
@@ -756,10 +756,10 @@ blockToHtml opts (Table capt aligns widths headers rows') = do
   head' <- if all null headers
               then return mempty
               else do
-                contents <- tableRowToHtml opts aligns 0 headers
+                contents <- tableRowToHtml opts aligns 0 (zip hspecs headers)
                 return $ H.thead (nl opts >> contents) >> nl opts
   body' <- liftM (\x -> H.tbody (nl opts >> mconcat x)) $
-               zipWithM (tableRowToHtml opts aligns) [1..] rows'
+               zipWithM (tableRowToHtml opts aligns) [1..] (map (\(specs, cols) -> zip specs cols) (zip rspecs rows'))
   let tbl = H.table $
               nl opts >> captionDoc >> coltags >> head' >> body' >> nl opts
   let totalWidth = sum widths
@@ -774,17 +774,17 @@ tableRowToHtml :: PandocMonad m
                => WriterOptions
                -> [Alignment]
                -> Int
-               -> [[Block]]
+               -> [(CellSpec, [Block])]
                -> StateT WriterState m Html
-tableRowToHtml opts aligns rownum cols' = do
+tableRowToHtml opts aligns rownum specs = do
   let mkcell = if rownum == 0 then H.th else H.td
   let rowclass = case rownum of
                       0 -> "header"
                       x | x `rem` 2 == 1 -> "odd"
                       _ -> "even"
   cols'' <- sequence $ zipWith
             (\alignment item -> tableItemToHtml opts mkcell alignment item)
-            aligns cols'
+            aligns specs
   return $ (H.tr ! A.class_ rowclass $ nl opts >> mconcat cols'')
           >> nl opts
 
@@ -799,18 +799,19 @@ tableItemToHtml :: PandocMonad m
                 => WriterOptions
                 -> (Html -> Html)
                 -> Alignment
-                -> [Block]
+                -> (CellSpec, [Block])
                 -> StateT WriterState m Html
-tableItemToHtml opts tag' align' item = do
+tableItemToHtml opts tag' align' ((colspan, rowspan), item) = do
   contents <- blockListToHtml opts item
   html5 <- gets stHtml5
   let alignStr = alignmentToString align'
-  let attribs = if html5
+  let align = if html5
                    then A.style (toValue $ "text-align: " ++ alignStr ++ ";")
                    else A.align (toValue alignStr)
-  let tag'' = if null alignStr
-                 then tag'
-                 else tag' ! attribs
+
+  let tag'' = tag' !? (null alignStr, align)
+                   !? (colspan /= 1, A.colspan $ toValue colspan)
+                   !? (rowspan /= 1, A.rowspan $ toValue rowspan)
   return $ (tag'' $ contents) >> nl opts
 
 toListItems :: WriterOptions -> [Html] -> [Html]

src/Text/Pandoc/Writers/Haddock.hs

@@ -138,7 +138,7 @@ blockToHaddock _ (CodeBlock (_,_,_) str) =
 blockToHaddock opts (BlockQuote blocks) =
   blockListToHaddock opts blocks
 -- Haddock doesn't have tables.  Use haddock tables in code.
-blockToHaddock opts (Table caption aligns widths headers rows) = do
+blockToHaddock opts (Table caption aligns widths _ _ headers rows) = do
   caption' <- inlineListToHaddock opts caption
   let caption'' = if null caption
                      then empty

src/Text/Pandoc/Writers/ICML.hs

@@ -319,7 +319,7 @@ blockToICML opts style (Header lvl _ lst) =
   let stl = (headerName ++ show lvl):style
   in parStyle opts stl lst
 blockToICML _ _ HorizontalRule = return empty -- we could insert a page break instead
-blockToICML opts style (Table caption aligns widths headers rows) =
+blockToICML opts style (Table caption aligns widths _ _ headers rows) =
   let style' = tableName : style
       noHeader  = all null headers
       nrHeaders = if noHeader

src/Text/Pandoc/Writers/LaTeX.hs

@@ -626,7 +626,7 @@ blockToLaTeX (Header level (id',classes,_) lst) = do
   hdr <- sectionHeader ("unnumbered" `elem` classes) id' level lst
   modify $ \s -> s{stInHeading = False}
   return hdr
-blockToLaTeX (Table caption aligns widths heads rows) = do
+blockToLaTeX (Table caption aligns widths _ _ heads rows) = do
   headers <- if all null heads
                 then return empty
                 else do

src/Text/Pandoc/Writers/Man.hs

@@ -200,7 +200,7 @@ blockToMan _ (CodeBlock _ str) = return $
 blockToMan opts (BlockQuote blocks) = do
   contents <- blockListToMan opts blocks
   return $ text ".RS" $$ contents $$ text ".RE"
-blockToMan opts (Table caption alignments widths headers rows) =
+blockToMan opts (Table caption alignments widths _ _ headers rows) =
   let aligncode AlignLeft    = "l"
       aligncode AlignRight   = "r"
       aligncode AlignCenter  = "c"

src/Text/Pandoc/Writers/Markdown.hs

@@ -526,7 +526,7 @@ blockToMarkdown' opts (BlockQuote blocks) = do
                   else if plain then "  " else "> "
   contents <- blockListToMarkdown opts blocks
   return $ (prefixed leader contents) <> blankline
-blockToMarkdown' opts t@(Table caption aligns widths headers rows) =  do
+blockToMarkdown' opts t@(Table caption aligns widths _ _ headers rows) =  do
   let numcols = maximum (length aligns : length widths :
                            map length (headers:rows))
   caption' <- inlineListToMarkdown opts caption

src/Text/Pandoc/Writers/MediaWiki.hs

@@ -32,7 +32,7 @@ MediaWiki:  <http://www.mediawiki.org/wiki/MediaWiki>
 module Text.Pandoc.Writers.MediaWiki ( writeMediaWiki ) where
 import Control.Monad.Reader
 import Control.Monad.State
-import Data.List (intercalate)
+import Data.List (intercalate, zip4)
 import qualified Data.Set as Set
 import Network.URI (isURI)
 import Text.Pandoc.Class (PandocMonad, report)
@@ -154,17 +154,18 @@ blockToMediaWiki (BlockQuote blocks) = do
   contents <- blockListToMediaWiki blocks
   return $ "<blockquote>" ++ contents ++ "</blockquote>"
 
-blockToMediaWiki (Table capt aligns widths headers rows') = do
+blockToMediaWiki (Table capt aligns widths hspecs rspecs headers rows') = do
   caption <- if null capt
                 then return ""
                 else do
                    c <- inlineListToMediaWiki capt
                    return $ "|+ " ++ trimr c ++ "\n"
   let headless = all null headers
   let allrows = if headless then rows' else headers:rows'
+  let allspecs = if headless then rspecs else hspecs:rspecs
   tableBody <- intercalate "|-\n" `fmap`
                 mapM (tableRowToMediaWiki headless aligns widths)
-                     (zip [1..] allrows)
+                     (zip3 [1..] allspecs allrows)
   return $ "{|\n" ++ caption ++ tableBody ++ "|}\n"
 
 blockToMediaWiki x@(BulletList items) = do
@@ -285,26 +286,30 @@ tableRowToMediaWiki :: PandocMonad m
                     => Bool
                     -> [Alignment]
                     -> [Double]
-                    -> (Int, [[Block]])
+                    -> (Int, [CellSpec], [[Block]])
                     -> MediaWikiWriter m String
-tableRowToMediaWiki headless alignments widths (rownum, cells) = do
+tableRowToMediaWiki headless alignments widths (rownum, specs, cells) = do
   cells' <- mapM (tableCellToMediaWiki headless rownum)
-          $ zip3 alignments widths cells
+          $ zip4 alignments widths specs cells
   return $ unlines cells'
 
 tableCellToMediaWiki :: PandocMonad m
                      => Bool
                      -> Int
-                     -> (Alignment, Double, [Block])
+                     -> (Alignment, Double, CellSpec, [Block])
                      -> MediaWikiWriter m String
-tableCellToMediaWiki headless rownum (alignment, width, bs) = do
+tableCellToMediaWiki headless rownum (alignment, width, (cspan, rspan), bs) = do
   contents <- blockListToMediaWiki bs
   let marker = if rownum == 1 && not headless then "!" else "|"
   let percent w = show (truncate (100*w) :: Integer) ++ "%"
   let attrs = ["align=" ++ show (alignmentToString alignment) |
                  alignment /= AlignDefault && alignment /= AlignLeft] ++
               ["width=\"" ++ percent width ++ "\"" |
-                 width /= 0.0 && rownum == 1]
+                 width /= 0.0 && rownum == 1] ++
+              ["colspan=\"" ++ show cspan ++ "\"" |
+                cspan /= 1] ++
+              ["rowspan=\"" ++ show rspan ++ "\"" |
+                rspan /= 1]
   let attr = if null attrs
                 then ""
                 else unwords attrs ++ "|"

src/Text/Pandoc/Writers/Muse.hs

@@ -193,7 +193,7 @@ blockToMuse (Header level (ident,_,_) inlines) = do
                  <> blankline <> attr'
 -- https://www.gnu.org/software/emacs-muse/manual/muse.html#Horizontal-Rules-and-Anchors
 blockToMuse HorizontalRule = return $ blankline $$ "----" $$ blankline
-blockToMuse (Table caption _ _ headers rows) =  do
+blockToMuse (Table caption _ _ _ _ headers rows) =  do
   caption' <- inlineListToMuse caption
   headers' <- mapM blockListToMuse headers
   rows' <- mapM (mapM blockListToMuse) rows