diff options
| -rw-r--r-- | src/Text/Pandoc/Writers/Shared.hs | 51 | ||||
| -rw-r--r-- | test/Tests/Shared.hs | 61 |
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) |