Muse writer: add support for grid tables

1 files changed, 35 insertions, 23 deletions

diff --git a/src/Text/Pandoc/Writers/Muse.hs b/src/Text/Pandoc/Writers/Muse.hs
index ceae14c16..408215602 100644
--- a/src/Text/Pandoc/Writers/Muse.hs
+++ b/src/Text/Pandoc/Writers/Muse.hs
@@ -163,6 +163,32 @@ flatBlockListToMuse bs@(DefinitionList _ : DefinitionList _ : _) = catWithBlankL
 flatBlockListToMuse bs@(_ : _) = catWithBlankLines bs 0
 flatBlockListToMuse [] = return mempty
 
+simpleTable :: PandocMonad m
+            => [Inline]
+            -> [TableCell]
+            -> [[TableCell]]
+            -> Muse m Doc
+simpleTable caption headers rows = do
+  caption' <- inlineListToMuse caption
+  headers' <- mapM blockListToMuse headers
+  rows' <- mapM (mapM blockListToMuse) rows
+  let noHeaders = all null headers
+  let numChars = maximum . map offset
+  let widthsInChars =
+       map numChars $ transpose (headers' : rows')
+  let hpipeBlocks sep blocks = hcat $ intersperse sep' blocks
+        where h      = maximum (1 : map height blocks)
+              sep'   = lblock (length sep) $ vcat (replicate h (text sep))
+  let makeRow sep = (" " <>) . hpipeBlocks sep . zipWith lblock widthsInChars
+  let head' = makeRow " || " headers'
+  let rowSeparator = if noHeaders then " | " else " |  "
+  rows'' <- mapM (\row -> makeRow rowSeparator <$> mapM blockListToMuse row) rows
+  let body = vcat rows''
+  return $  (if noHeaders then empty else head')
+         $$ body
+         $$ (if null caption then empty else " |+ " <> caption' <> " +|")
+         $$ blankline
+
 -- | Convert list of Pandoc block elements to Muse.
 blockListToMuse :: PandocMonad m
                 => [Block]       -- ^ List of block elements
@@ -252,29 +278,15 @@ blockToMuse (Header level (ident,_,_) inlines) = do
   return $ blankline <> attr' $$ nowrap (header' <> contents) <> blankline
 -- 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
-  caption' <- inlineListToMuse caption
-  headers' <- mapM blockListToMuse headers
-  rows' <- mapM (mapM blockListToMuse) rows
-  let noHeaders = all null headers
-
-  let numChars = maximum . map offset
-  -- FIXME: width is not being used.
-  let widthsInChars =
-       map numChars $ transpose (headers' : rows')
-  -- FIXME: Muse doesn't allow blocks with height more than 1.
-  let hpipeBlocks sep blocks = hcat $ intersperse sep' blocks
-        where h      = maximum (1 : map height blocks)
-              sep'   = lblock (length sep) $ vcat (replicate h (text sep))
-  let makeRow sep = (" " <>) . hpipeBlocks sep . zipWith lblock widthsInChars
-  let head' = makeRow " || " headers'
-  let rowSeparator = if noHeaders then " | " else " |  "
-  rows'' <- mapM (\row -> makeRow rowSeparator <$> mapM blockListToMuse row) rows
-  let body = vcat rows''
-  return $  (if noHeaders then empty else head')
-         $$ body
-         $$ (if null caption then empty else " |+ " <> caption' <> " +|")
-         $$ blankline
+blockToMuse (Table caption aligns widths headers rows) =
+  if all (== 0.0) widths
+    then simpleTable caption headers rows
+    else do
+      opts <- asks envOptions
+      gridTable opts blocksToDoc True (map (const AlignDefault) aligns) widths headers rows
+  where
+    blocksToDoc opts blocks =
+      local (\env -> env { envOptions = opts }) $ blockListToMuse blocks
 blockToMuse (Div _ bs) = flatBlockListToMuse bs
 blockToMuse Null = return empty