Add colspan/rowspan support to Table

Text/Pandoc/Arbitrary.hs

@@ -107,10 +107,12 @@ arbBlock n = frequency $ [ (10, liftM Plain $ arbInlines (n-1))
                             x1 <- arbInlines (n-1)
                             x2 <- vector cs
                             x3 <- vectorOf cs $ elements [0, 0.25]
-                            x4 <- vectorOf cs $ listOf $ arbBlock (n-1)
-                            x5 <- vectorOf rs $ vectorOf cs
+                            x4 <- vectorOf cs $ pure (1, 1)
+                            x5 <- vectorOf rs $ vectorOf cs $ pure (1, 1)
+                            x6 <- vectorOf cs $ listOf $ arbBlock (n-1)
+                            x7 <- vectorOf rs $ vectorOf cs
                                   $ listOf $ arbBlock (n-1)
-                            return (Table x1 x2 x3 x4 x5))
+                            return (Table x1 x2 x3 x4 x5 x6 x7))
                    ]
 
 instance Arbitrary Pandoc where

Text/Pandoc/Builder.hs

@@ -159,6 +159,7 @@ module Text.Pandoc.Builder ( module Text.Pandoc.Definition
                            , header
                            , headerWith
                            , horizontalRule
+                           , fullTable
                            , table
                            , simpleTable
                            , divWith
@@ -471,15 +472,26 @@ headerWith attr level = singleton . Header level attr . toList
 horizontalRule :: Blocks
 horizontalRule = singleton HorizontalRule
 
+fullTable :: Inlines               -- ^ Caption
+          -> [(Alignment, Double)] -- ^ Column alignments and fractional widths
+          -> [CellSpec]           -- ^ Header CellSpecs
+          -> [[CellSpec]]         -- ^ Rows Specs
+          -> [Blocks]              -- ^ Headers
+          -> [[Blocks]]            -- ^ Rows
+          -> Blocks
+fullTable caption alignment headerspecs rowspecs headers rows = singleton $
+  Table (toList caption) aligns widths
+      headerspecs rowspecs (map toList headers) (map (map toList) rows)
+   where (aligns, widths) = unzip alignment
+
+
 table :: Inlines               -- ^ Caption
       -> [(Alignment, Double)] -- ^ Column alignments and fractional widths
       -> [Blocks]              -- ^ Headers
       -> [[Blocks]]            -- ^ Rows
       -> Blocks
-table caption cellspecs headers rows = singleton $
-  Table (toList caption) aligns widths
-      (map toList headers) (map (map toList) rows)
-   where (aligns, widths) = unzip cellspecs
+table caption alignment headers rows = fullTable caption alignment (mapConst cellspecs headers) (map (mapConst cellspecs) rows) headers rows
+  where cellspecs = (1, 1)
 
 -- | A simple table without a caption.
 simpleTable :: [Blocks]   -- ^ Headers

Text/Pandoc/Definition.hs

@@ -64,6 +64,7 @@ module Text.Pandoc.Definition ( Pandoc(..)
                               , Format(..)
                               , Attr
                               , nullAttr
+                              , CellSpec
                               , TableCell
                               , QuoteType(..)
                               , Target
@@ -195,6 +196,9 @@ nullAttr = ("",[],[])
 -- | Table cells are list of Blocks
 type TableCell = [Block]
 
+-- | Cell specs are a colspan and a rowspan
+type CellSpec = (Int, Int)
+
 -- | Formats for raw blocks
 newtype Format = Format String
                deriving (Read, Show, Typeable, Data, Generic, ToJSON, FromJSON)
@@ -226,7 +230,7 @@ data Block
                             -- definitions (each a list of blocks)
     | Header Int Attr [Inline] -- ^ Header - level (integer) and text (inlines)
     | HorizontalRule        -- ^ Horizontal rule
-    | Table [Inline] [Alignment] [Double] [TableCell] [[TableCell]]  -- ^ Table,
+    | Table [Inline] [Alignment] [Double] [CellSpec] [[CellSpec]] [TableCell] [[TableCell]]  -- ^ Table,
                             -- with caption, column alignments (required),
                             -- relative column widths (0 = default),
                             -- column headers (each a list of blocks), and
@@ -524,8 +528,8 @@ instance FromJSON Block where
       "Header"         -> do (n, attr, ils) <- v .: "c"
                              return $ Header n attr ils
       "HorizontalRule" -> return $ HorizontalRule
-      "Table"          -> do (cpt, align, wdths, hdr, rows) <- v .: "c"
-                             return $ Table cpt align wdths hdr rows
+      "Table"          -> do (cpt, align, wdths, hspec, rspec, hdr, rows) <- v .: "c"
+                             return $ Table cpt align wdths hspec rspec hdr rows
       "Div"            -> do (attr, blks) <- v .: "c"
                              return $ Div attr blks
       "Null"           -> return $ Null
@@ -543,8 +547,8 @@ instance ToJSON Block where
   toJSON (DefinitionList defs) = tagged "DefinitionList" defs
   toJSON (Header n attr ils) = tagged "Header" (n, attr, ils)
   toJSON HorizontalRule = taggedNoContent "HorizontalRule"
-  toJSON (Table caption aligns widths cells rows) =
-    tagged "Table" (caption, aligns, widths, cells, rows)
+  toJSON (Table caption aligns widths hspec rspec cells rows) =
+    tagged "Table" (caption, aligns, widths, hspec, rspec, cells, rows)
   toJSON (Div attr blks) = tagged "Div" (attr, blks)
   toJSON Null = taggedNoContent "Null"
 

Text/Pandoc/Walk.hs

@@ -199,7 +199,7 @@ instance Walkable Inline Block where
   walk f (DefinitionList xs)      = DefinitionList $ walk f xs
   walk f (Header lev attr xs)     = Header lev attr $ walk f xs
   walk _ HorizontalRule           = HorizontalRule
-  walk f (Table capt as ws hs rs) = Table (walk f capt) as ws (walk f hs) (walk f rs)
+  walk f (Table capt as ws hspec rspec hs rs) = Table (walk f capt) as ws hspec rspec (walk f hs) (walk f rs)
   walk f (Div attr bs)            = Div attr (walk f bs)
   walk _ Null                     = Null
 
@@ -214,11 +214,11 @@ instance Walkable Inline Block where
   walkM f (DefinitionList xs)      = DefinitionList <$> walkM f xs
   walkM f (Header lev attr xs)     = Header lev attr <$> walkM f xs
   walkM _ HorizontalRule           = return HorizontalRule
-  walkM f (Table capt as ws hs rs) = do
+  walkM f (Table capt as ws hspec rspec hs rs) = do
                                      capt' <- walkM f capt
                                      hs' <- walkM f hs
                                      rs' <- walkM f rs
-                                     return $ Table capt' as ws hs' rs'
+                                     return $ Table capt' as ws hspec rspec hs' rs'
   walkM f (Div attr bs)            = Div attr <$> (walkM f bs)
   walkM _ Null                     = return Null
 
@@ -233,7 +233,7 @@ instance Walkable Inline Block where
   query f (DefinitionList xs)      = query f xs
   query f (Header _ _ xs)          = query f xs
   query _ HorizontalRule           = mempty
-  query f (Table capt _ _ hs rs)   = query f capt <> query f hs <> query f rs
+  query f (Table capt _ _ _ _ hs rs)   = query f capt <> query f hs <> query f rs
   query f (Div _ bs)               = query f bs
   query _ Null                     = mempty
 
@@ -249,7 +249,7 @@ instance Walkable Block Block where
   walk f (DefinitionList xs)      = f $ DefinitionList $ walk f xs
   walk f (Header lev attr xs)     = f $ Header lev attr $ walk f xs
   walk f HorizontalRule           = f $ HorizontalRule
-  walk f (Table capt as ws hs rs) = f $ Table (walk f capt) as ws (walk f hs)
+  walk f (Table capt as ws hspec rspec hs rs) = f $ Table (walk f capt) as ws hspec rspec (walk f hs)
                                                      (walk f rs)
   walk f (Div attr bs)            = f $ Div attr (walk f bs)
   walk _ Null                     = Null
@@ -265,10 +265,10 @@ instance Walkable Block Block where
   walkM f (DefinitionList xs)      = DefinitionList <$> walkM f xs >>= f
   walkM f (Header lev attr xs)     = Header lev attr <$> walkM f xs >>= f
   walkM f HorizontalRule           = f $ HorizontalRule
-  walkM f (Table capt as ws hs rs) = do capt' <- walkM f capt
-                                        hs' <- walkM f hs
-                                        rs' <- walkM f rs
-                                        f $ Table capt' as ws hs' rs'
+  walkM f (Table capt as ws hspec rspec hs rs) = do capt' <- walkM f capt
+                                                    hs' <- walkM f hs
+                                                    rs' <- walkM f rs
+                                                    f $ Table capt' as ws hspec rspec hs' rs'
   walkM f (Div attr bs)            = Div attr <$> walkM f bs >>= f
   walkM f Null                     = f Null
 
@@ -283,7 +283,7 @@ instance Walkable Block Block where
   query f (DefinitionList xs)      = f (DefinitionList xs) <> query f xs
   query f (Header lev attr xs)     = f (Header lev attr xs) <> query f xs
   query f HorizontalRule           = f $ HorizontalRule
-  query f (Table capt as ws hs rs) = f (Table capt as ws hs rs) <>
+  query f (Table capt as ws hspec rspec hs rs) = f (Table capt as ws hspec rspec hs rs) <>
                                        query f capt <> query f hs <> query f rs
   query f (Div attr bs)            = f (Div attr bs) <> query f bs
   query f Null                     = f Null