Modify toLegacyTable to cut up cells, add tests

Now a cell with dimension (h, w) will be cut up into h*w cells of
dimension (1,1), all in the same grid position, with the upper-left
holding the original cell contents and the rest being empty.

2 files changed, 104 insertions, 8 deletions

diff --git a/src/Text/Pandoc/Writers/Shared.hs b/src/Text/Pandoc/Writers/Shared.hs
index fb4e8eca6..642b33933 100644
--- a/src/Text/Pandoc/Writers/Shared.hs
+++ b/src/Text/Pandoc/Writers/Shared.hs
@@ -431,14 +431,16 @@ endsWithPlain xs =
 -- | Convert the relevant components of a new-style table (with block
 -- caption, row headers, row and column spans, and so on) to those of
 -- an old-style table (inline caption, table head with one row, no
--- foot, and so on).
+-- foot, and so on). Cells with a 'RowSpan' and 'ColSpan' of @(h, w)@
+-- will be cut up into @h * w@ cells of dimension @(1, 1)@, with the
+-- content placed in the upper-left corner.
 toLegacyTable :: Caption
               -> [ColSpec]
               -> TableHead
               -> [TableBody]
               -> TableFoot
               -> ([Inline], [Alignment], [Double], [[Block]], [[[Block]]])
-toLegacyTable (Caption _ cbody) specs (TableHead _ th) tb (TableFoot _ tf)
+toLegacyTable (Caption _ cbody) specs thead tbodies tfoot
   = (cbody', aligns, widths, th', tb')
   where
     numcols = length specs
@@ -446,13 +448,46 @@ toLegacyTable (Caption _ cbody) specs (TableHead _ th) tb (TableFoot _ tf)
     fromWidth (ColWidth w) | w > 0 = w
     fromWidth _                    = 0
     widths = map fromWidth mwidths
-    unRow (Row _ x) = map unCell x
-    unCell (Cell _ _ _ _ x) = x
+    unRow (Row _ x) = x
     unBody (TableBody _ _ hd bd) = hd <> bd
     unBodies = concatMap unBody
+
+    TableHead _ th = Builder.normalizeTableHead numcols thead
+    tb = map (Builder.normalizeTableBody numcols) tbodies
+    TableFoot _ tf = Builder.normalizeTableFoot numcols tfoot
+
     cbody' = blocksToInlines cbody
-    sanitise = pad mempty numcols . unRow
-    pad element upTo list = take upTo (list ++ repeat element)
+
     (th', tb') = case th of
-      (r:rs) -> (sanitise r, map sanitise $ rs <> unBodies tb <> tf)
-      []     -> ([], map sanitise $ unBodies tb <> tf)
+      r:rs -> let (pendingPieces, r') = placeCutCells [] $ unRow r
+                  rs' = cutRows pendingPieces $ rs <> unBodies tb <> tf
+              in (r', rs')
+      []    -> ([], cutRows [] $ unBodies tb <> tf)
+
+    -- Adapted from placeRowSection in Builders. There is probably a
+    -- more abstract foldRowSection that unifies them both.
+    placeCutCells pendingPieces cells
+      -- If there are any pending pieces for a column, add
+      -- them. Pending pieces have preference over cells due to grid
+      -- layout rules.
+      | (p:ps):pendingPieces' <- pendingPieces
+      = let (pendingPieces'', rowPieces) = placeCutCells pendingPieces' cells
+        in (ps : pendingPieces'', p : rowPieces)
+      -- Otherwise cut up a cell on the row and deal with its pieces.
+      | c:cells' <- cells
+      = let (h, w, cBody) = getComponents c
+            cRowPieces = cBody : replicate (w - 1) mempty
+            cPendingPieces = replicate w $ replicate (h - 1) mempty
+            pendingPieces' = dropWhile null pendingPieces
+            (pendingPieces'', rowPieces) = placeCutCells pendingPieces' cells'
+        in (cPendingPieces <> pendingPieces'', cRowPieces <> rowPieces)
+      | otherwise = ([], [])
+
+    cutRows pendingPieces (r:rs)
+      = let (pendingPieces', r') = placeCutCells pendingPieces $ unRow r
+            rs' = cutRows pendingPieces' rs
+        in r' : rs'
+    cutRows _ [] = []
+
+    getComponents (Cell _ _ (RowSpan h) (ColSpan w) body)
+      = (h, w, body)
diff --git a/test/Tests/Shared.hs b/test/Tests/Shared.hs
index 2f934ca08..09391d9d0 100644
--- a/test/Tests/Shared.hs
+++ b/test/Tests/Shared.hs
@@ -20,6 +20,7 @@ import Test.Tasty.HUnit (assertBool, testCase, (@?=))
 import Text.Pandoc.Arbitrary ()
 import Text.Pandoc.Builder
 import Text.Pandoc.Shared
+import Text.Pandoc.Writers.Shared (toLegacyTable)
 
 tests :: [TestTree]
 tests = [ testGroup "compactifyDL"
@@ -29,6 +30,7 @@ tests = [ testGroup "compactifyDL"
                in  compactifyDL x == x)
           ]
         , testGroup "collapseFilePath" testCollapse
+        , testGroup "toLegacyTable" testLegacyTable
         ]
 
 testCollapse :: [TestTree]
@@ -51,3 +53,62 @@ testCollapse = map (testCase "collapse")
  ,  collapseFilePath (joinPath [ "parent","foo",".."]) @?= (joinPath [ "parent"])
  ,  collapseFilePath (joinPath [ "","parent","foo","..","..","bar"]) @?= (joinPath [ "","bar"])
  ,  collapseFilePath (joinPath [ "",".","parent","foo"]) @?= (joinPath [ "","parent","foo"])]
+
+testLegacyTable :: [TestTree]
+testLegacyTable =
+  [ testCase "decomposes a table with head" $ gen1 @?= expect1
+  , testCase "decomposes a table without head" $ gen2 @?= expect2
+  ]
+  where
+    pln = toList . plain . str
+    cl a h w = Cell ("", [], []) AlignDefault h w $ pln a
+    rws = map $ Row nullAttr
+    th = TableHead nullAttr . rws
+    tb n x y = TableBody nullAttr n (rws x) (rws y)
+    tf = TableFoot nullAttr . rws
+
+    headRows1 =
+      [[cl "a" 1 1, cl "b" 2 2]
+      ,[cl "c" 1 1]
+      ]
+    body1 = tb 1
+      [[cl "e" 3 1,cl "f" 3 2]
+      ,[]
+      ,[]
+      ]
+      [[emptyCell,emptyCell,emptyCell]
+      ,[cl "g" 1 1,emptyCell,emptyCell]
+      ]
+    footRows1 =
+      [[cl "h" 1 2,cl "i" 2 1]
+      ,[cl "j" 1 2]]
+    caption1 = simpleCaption $ plain "caption"
+    spec1 = replicate 2 (AlignDefault, ColWidth 0.5) ++ [(AlignRight, ColWidthDefault)]
+    expect1 = ( [Str "caption"]
+              , replicate 2 AlignDefault ++ [AlignRight]
+              , replicate 2 0.5 ++ [0]
+              , [pln "a", pln "b", mempty]
+              , [[pln "c", mempty, mempty]
+                ,[pln "e", pln "f", mempty]
+                ,[mempty, mempty, mempty]
+                ,[mempty, mempty, mempty]
+                ,[mempty, mempty, mempty]
+                ,[pln "g", mempty, mempty]
+                ,[pln "h", mempty, pln "i"]
+                ,[pln "j", mempty, mempty]]
+              )
+    gen1 = toLegacyTable caption1 spec1 (th headRows1) [body1] (tf footRows1)
+
+    expect2 = ( []
+              , replicate 2 AlignDefault ++ [AlignRight]
+              , replicate 2 0.5 ++ [0]
+              , []
+              , [[pln "e", pln "f", mempty]
+                ,[mempty, mempty, mempty]
+                ,[mempty, mempty, mempty]
+                ,[mempty, mempty, mempty]
+                ,[pln "g", mempty, mempty]
+                ,[pln "h", mempty, pln "i"]
+                ,[pln "j", mempty, mempty]]
+              )
+    gen2 = toLegacyTable emptyCaption spec1 (th []) [body1] (tf footRows1)