rST writer: add option for list tables, closes jgm#4564

src/Text/Pandoc/App.hs

@@ -417,6 +417,7 @@ convertWithOpts opts = do
           , writerSectionDivs      = optSectionDivs opts
           , writerExtensions       = writerExts
           , writerReferenceLinks   = optReferenceLinks opts
+          , writerListTables       = optListTables opts
           , writerReferenceLocation = optReferenceLocation opts
           , writerDpi              = optDpi opts
           , writerWrapText         = optWrapText opts
@@ -581,6 +582,7 @@ data Opt = Opt
     , optLogFile               :: Maybe FilePath -- ^ File to write JSON log output
     , optFailIfWarnings        :: Bool    -- ^ Fail on warnings
     , optReferenceLinks        :: Bool    -- ^ Use reference links in writing markdown, rst
+    , optListTables            :: Bool    -- ^ Use list tables in writing rst
     , optReferenceLocation     :: ReferenceLocation -- ^ location for footnotes and link references in markdown output
     , optDpi                   :: Int     -- ^ Dpi
     , optWrapText              :: WrapOption  -- ^ Options for wrapping text
@@ -653,6 +655,7 @@ defaultOpts = Opt
     , optLogFile               = Nothing
     , optFailIfWarnings        = False
     , optReferenceLinks        = False
+    , optListTables            = False
     , optReferenceLocation     = EndOfDocument
     , optDpi                   = 96
     , optWrapText              = WrapAuto
@@ -1159,7 +1162,12 @@ options =
     , Option "" ["reference-links"]
                  (NoArg
                   (\opt -> return opt { optReferenceLinks = True } ))
-                 "" -- "Use reference links in parsing HTML"
+                 "" -- "Use reference links in writing markdown, rST"
+
+    , Option "" ["list-tables"]
+                 (NoArg
+                  (\opt -> return opt { optListTables = True } ))
+                 "" -- "Use list tables in writing rST"
 
     , Option "" ["reference-location"]
                  (ReqArg

src/Text/Pandoc/Options.hs

@@ -30,7 +30,9 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
    Portability : portable
 
 Data structures and functions for representing parser and writer
-options.
+options. In Text.Pandoc.App, these get filled in with values from the
+@Opt@ options parsed from the command line
+
 -}
 module Text.Pandoc.Options ( module Text.Pandoc.Extensions
                            , ReaderOptions(..)
@@ -172,6 +174,7 @@ data WriterOptions = WriterOptions
   , writerSectionDivs       :: Bool   -- ^ Put sections in div tags in HTML
   , writerExtensions        :: Extensions -- ^ Markdown extensions that can be used
   , writerReferenceLinks    :: Bool   -- ^ Use reference links in writing markdown, rst
+  , writerListTables        :: Bool   -- ^ Use list tables in writing rst
   , writerDpi               :: Int    -- ^ Dpi for pixel to/from inch/cm conversions
   , writerWrapText          :: WrapOption  -- ^ Option for wrapping text
   , writerColumns           :: Int    -- ^ Characters in a line (for text wrapping)
@@ -208,6 +211,7 @@ instance Default WriterOptions where
                       , writerSectionDivs      = False
                       , writerExtensions       = emptyExtensions
                       , writerReferenceLinks   = False
+                      , writerListTables       = False
                       , writerDpi              = 96
                       , writerWrapText         = WrapAuto
                       , writerColumns          = 72

src/Text/Pandoc/Writers/RST.hs

@@ -35,7 +35,7 @@ module Text.Pandoc.Writers.RST ( writeRST, flatten ) where
 import Prelude
 import Control.Monad.State.Strict
 import Data.Char (isSpace, toLower)
-import Data.List (isPrefixOf, stripPrefix)
+import Data.List (isPrefixOf, stripPrefix, intercalate)
 import Data.Maybe (fromMaybe)
 import Data.Text (Text, stripEnd)
 import qualified Text.Pandoc.Builder as B
@@ -282,21 +282,11 @@ blockToRST (BlockQuote blocks) = do
   contents <- blockListToRST blocks
   return $ nest 3 contents <> blankline
 blockToRST (Table caption aligns widths headers rows) = do
-  caption' <- inlineListToRST caption
-  let blocksToDoc opts bs = do
-         oldOpts <- gets stOptions
-         modify $ \st -> st{ stOptions = opts }
-         result <- blockListToRST bs
-         modify $ \st -> st{ stOptions = oldOpts }
-         return result
   opts <- gets stOptions
-  tbl <- gridTable opts blocksToDoc (all null headers)
-            (map (const AlignDefault) aligns) widths
-            headers rows
-  return $ if null caption
-              then tbl $$ blankline
-              else (".. table:: " <> caption') $$ blankline $$ nest 3 tbl $$
-                   blankline
+  (tableToRST opts) caption aligns widths headers rows
+  where tableToRST opts = if writerListTables opts
+                          then tableToRSTList
+                          else tableToRSTGrid
 blockToRST (BulletList items) = do
   contents <- mapM bulletListItemToRST items
   -- ensure that sublists have preceding blank line
@@ -317,6 +307,106 @@ blockToRST (DefinitionList items) = do
   -- ensure that sublists have preceding blank line
   return $ blankline $$ chomp (vcat contents) $$ blankline
 
+tableToRSTGrid :: PandocMonad m
+                  => [Inline]
+                  -> [Alignment]
+                  -> [Double]
+                  -> [TableCell]
+                  -> [[TableCell]]
+                  -> RST m Doc
+tableToRSTGrid caption aligns widths headers rows = do
+  caption' <- inlineListToRST caption
+  let blocksToDoc opts bs = do
+         oldOpts <- gets stOptions
+         modify $ \st -> st{ stOptions = opts }
+         result <- blockListToRST bs
+         modify $ \st -> st{ stOptions = oldOpts }
+         return result
+  opts <- gets stOptions
+  tbl <- gridTable opts blocksToDoc (all null headers)
+            (map (const AlignDefault) aligns) widths
+            headers rows
+  return $ if null caption
+              then tbl $$ blankline
+              else (".. table:: " <> caption') $$ blankline $$ nest 3 tbl $$
+                   blankline
+
+{-
+
+http://docutils.sourceforge.net/docs/ref/rst/restructuredtext.html#directives
+ 
+According to the terminology used in the spec a marker includes a
+final whitespace and a block includes the directive arguments. Here
+the variable names have slightly different meanings because we don't
+want to finish the line with a space if there are no arguments, it
+would produce rST that differs from what users expect in a way that's
+not easy to detect
+
+-}
+toRSTDirective :: Doc -> Doc -> [(Doc, Doc)] -> Doc -> Doc
+toRSTDirective typ args options content = marker <> spaceArgs <> cr <> block
+  where marker = ".. " <> typ <> "::"
+        block = nest 3 (fieldList $$
+                        blankline $$
+                        content $$
+                        blankline)
+        spaceArgs = if isEmpty args then "" else " " <> args
+        -- a field list could end up being an empty doc thus being
+        -- omitted by $$
+        fieldList = foldl ($$) "" $ map joinField options
+        -- a field body can contain multiple lines
+        joinField (name, body) = ":" <> name <> ": " <> body
+
+tableToRSTList :: PandocMonad m
+             => [Inline]
+             -> [Alignment]
+             -> [Double]
+             -> [TableCell]
+             -> [[TableCell]]
+             -> RST m Doc
+tableToRSTList caption _ propWidths headers rows = do
+  captionRST <- inlineListToRST caption
+  opts <- gets stOptions
+  content <- listTableContent toWrite
+  pure $ toRSTDirective "list-table" captionRST (directiveOptions opts) content
+  where directiveOptions opts = widths (writerColumns opts) propWidths <>
+                                headerRows
+        toWrite = if noHeaders then rows else headers:rows
+        headerRows = if noHeaders
+                     then []
+                     else [("header-rows", text $ show (1 :: Int))]
+        widths tot pro = if (null propWidths) || (all (==0.0) propWidths)
+                 then []
+                 else [("widths", showWidths tot pro)]
+        noHeaders = all null headers
+        -- >>> showWidths 70 [0.5, 0.5]
+        -- "35 35"
+        showWidths :: Int -> [Double] -> Doc
+        showWidths tot = text . intercalate " " . map (show . toColumns tot)
+        -- toColumns converts a width expressed as a proportion of the
+        -- total into a width expressed as a number of columns
+        toColumns :: Int -> Double -> Int
+        toColumns t p = round (p * fromIntegral t)
+        listTableContent :: PandocMonad m => [[[Block]]] -> RST m Doc
+        listTableContent = joinTable joinDocsM joinDocsM .
+                           mapTable blockListToRST
+        -- joinDocsM adapts joinDocs in order to work in the `RST m` monad
+        joinDocsM :: PandocMonad m => [RST m Doc] -> RST m Doc
+        joinDocsM = fmap joinDocs . sequence
+        -- joinDocs will be used to join cells and to join rows
+        joinDocs :: [Doc] -> Doc
+        joinDocs items = blankline $$
+                         (chomp . vcat . map formatItem) items $$
+                         blankline
+        formatItem :: Doc -> Doc
+        formatItem i = hang 3 "- " (i <> cr)
+        -- apply a function to all table cells changing their type
+        mapTable :: (a -> b) -> [[a]] -> [[b]]
+        mapTable = map . map
+        -- function hor to join cells and function ver to join rows
+        joinTable :: ([a] -> a) -> ([a] -> a) -> [[a]] -> a
+        joinTable hor ver = ver . map hor
+
 -- | Convert bullet list item (list of blocks) to RST.
 bulletListItemToRST :: PandocMonad m => [Block] -> RST m Doc
 bulletListItemToRST items = do

test/command/4564.md

@@ -0,0 +1,145 @@
+```
+% pandoc -f native -t rst --list-tables
+[Para [Str "Here",Space,Str "is",Space,Str "an",Space,Str "example",Space,Str "of",Space,Str "a",Space,Str "request",Space,Str "packet",Space,Str "sent",Space,Str "to",Space,Str "the",Space,Str "Plesk",Space,Str "server:"]
+,Table [] [AlignDefault,AlignDefault] [0.5,0.5]
+ [[]
+ ,[]]
+ [[[CodeBlock ("",[],[]) "POST /enterprise/control/agent.php HTTP/1.1\nHost: 10.58.83.1:8443\nAccept: */*\nHTTP_AUTH_LOGIN: admin\nHTTP_AUTH_PASSWD: setup\nPragma: no-cache\nContent-Length: 1398\nContent-Type: text/xml"]
+  ,[Para [Str "HTTP",Space,Str "header"]
+   ,Para [Str "The",Space,Str "HTTP",Space,Str "header",Space,Str "indicates",Space,Str "that",Space,Str "the",Space,Str "HTTP",Space,Str "method",Space,Str "used",Space,Str "is",Space,Str "POST,",SoftBreak,Str "the",Space,Str "handling",Space,Str "agent",Space,Str "is",Space,Str "located",Space,Str "at",SoftBreak,Code ("",["docutils","literal"],[]) "/enterprise/control/agent.php,",Space,Str "and",Space,Str "the",Space,Str "HTTP",Space,Str "version",Space,Str "is",SoftBreak,Str "1.1.",Space,Str "The",Space,Code ("",["docutils","literal"],[]) "Host",Space,Str "element",Space,Str "specifies",Space,Str "the",Space,Str "IP",Space,Str "address",Space,Str "and",Space,Str "port",Space,Str "of",SoftBreak,Str "the",Space,Str "server",Space,Str "to",Space,Str "which",Space,Str "the",Space,Str "message",Space,Str "is",Space,Str "addressed.",SoftBreak,Code ("",["docutils","literal"],[]) "HTTP_AUTH_LOGIN",Space,Str "and",Space,Code ("",["docutils","literal"],[]) "HTTP_AUTH_PASSWD",Space,Str "elements",Space,Str "hold",Space,Str "the",SoftBreak,Str "Administrator's",Space,Str "credentials.",Space,Str "The",Space,Code ("",["docutils","literal"],[]) "Content-Type",Space,Str "must",Space,Str "be",SoftBreak,Str "\"text/xml\".",Space,Str "The",Space,Str "length",Space,Str "of",Space,Str "the",Space,Str "passed",Space,Str "message",Space,Str "is",Space,Str "also",Space,Str "required."]]]
+ ,[[CodeBlock ("",[],[]) "<?xml version=\"1.0\" encoding=\"UTF-8\" ?>"]
+  ,[Plain [Str "XML",Space,Str "declaration"]]]
+ ,[[CodeBlock ("",[],[]) "<packet>"]
+  ,[Plain [Str "Packet",Space,Str "header"]]]
+ ,[[CodeBlock ("",[],[]) "<customer>\n    <add>\n        <gen_info>\n            <cname>LogicSoft Ltd.</cname>\n            <pname>Stephen Lowell</pname>\n            <login>stevelow</login>\n            <passwd>Jhtr66fBB</passwd>\n            <status>0</status>\n            <phone>416 907 9944</phone>\n            <fax>928 752 3905</fax>\n            <email>[email protected]</email>\n            <address>105 Brisbane Road, Unit 2</address>\n            <city>Toronto</city>\n            <state/>\n            <pcode/>\n            <country>CA</country>\n        </gen_info>\n    </add>\n</customer>", Plain [Str "Packet",Space,Str "header"]]
+  ,[Para [Str "Packet",Space,Str "body"]
+   ,Para [Str "Always",Space,Str "starts",Space,Str "from",Space,Str "the",Space,Str "tag",Space,Str "of",Space,Str "the",Space,Str "related",Space,Str "operator."]
+   ,Para [Str "This",Space,Str "particular",Space,Str "packet",Space,Str "uses",Space,Str "the",Space,Str "customer",Space,Str "operator",Space,Str "to",Space,Str "create",Space,Str "a",SoftBreak,Str "customer",Space,Str "account.",Space,Str "The",Space,Str "elements",Space,Str "nested",Space,Str "within",Space,Str "the",Space,Code ("",["docutils","literal"],[]) "gen_info",Space,Str "node",SoftBreak,Str "contain",Space,Str "the",Space,Str "profile",Space,Str "details."]
+   ,Para [Str "The",Space,Str "structure",Space,Str "of",Space,Str "the",Space,Str "packet",Space,Str "body",Space,Str "is",Space,Str "compliant",Space,Str "with",Space,Str "the",SoftBreak,Code ("",["docutils","literal"],[]) "client_input.xsd",Space,Str "XML",Space,Str "schema",Space,Str "of",Space,Str "XML",Space,Str "API",Space,Str "1.6.3.0."]]]
+ ,[[CodeBlock ("",[],[]) "</packet>"]
+  ,[Plain [Str "Trailing",Space,Str "tag",Space,Str "closing",Space,Str "the",Space,Str "packet"]]]]]
+^D
+Here is an example of a request packet sent to the Plesk server:
+
+.. list-table::
+   :widths: 36 36
+
+   - 
+
+      - ::
+
+            POST /enterprise/control/agent.php HTTP/1.1
+            Host: 10.58.83.1:8443
+            Accept: */*
+            HTTP_AUTH_LOGIN: admin
+            HTTP_AUTH_PASSWD: setup
+            Pragma: no-cache
+            Content-Length: 1398
+            Content-Type: text/xml
+
+      - HTTP header
+
+         The HTTP header indicates that the HTTP method used is POST,
+         the handling agent is located at
+         ``/enterprise/control/agent.php,`` and the HTTP version is 1.1.
+         The ``Host`` element specifies the IP address and port of the
+         server to which the message is addressed. ``HTTP_AUTH_LOGIN``
+         and ``HTTP_AUTH_PASSWD`` elements hold the Administrator's
+         credentials. The ``Content-Type`` must be "text/xml". The
+         length of the passed message is also required.
+
+   - 
+
+      - ::
+
+            <?xml version="1.0" encoding="UTF-8" ?>
+
+      - XML declaration
+
+   - 
+
+      - ::
+
+            <packet>
+
+      - Packet header
+
+   - 
+
+      - ::
+
+            <customer>
+                <add>
+                    <gen_info>
+                        <cname>LogicSoft Ltd.</cname>
+                        <pname>Stephen Lowell</pname>
+                        <login>stevelow</login>
+                        <passwd>Jhtr66fBB</passwd>
+                        <status>0</status>
+                        <phone>416 907 9944</phone>
+                        <fax>928 752 3905</fax>
+                        <email>[email protected]</email>
+                        <address>105 Brisbane Road, Unit 2</address>
+                        <city>Toronto</city>
+                        <state/>
+                        <pcode/>
+                        <country>CA</country>
+                    </gen_info>
+                </add>
+            </customer>
+
+         Packet header
+      - Packet body
+
+         Always starts from the tag of the related operator.
+
+         This particular packet uses the customer operator to create a
+         customer account. The elements nested within the ``gen_info``
+         node contain the profile details.
+
+         The structure of the packet body is compliant with the
+         ``client_input.xsd`` XML schema of XML API 1.6.3.0.
+
+   - 
+
+      - ::
+
+            </packet>
+
+      - Trailing tag closing the packet
+
+
+
+```
+
+Zero widths are not allowed in rST so we omit them
+
+```
+% pandoc -f native -t rst --list-tables
+[Table [] [AlignDefault,AlignDefault] [0.0,0.0]
+ [[]
+ ,[]]
+ [[[Para [Str "1 1"]]
+   ,[Para [Str "1 2"]]]
+ ,[[CodeBlock ("",[],[]) "2 1"]
+  ,[Plain [Str "2 2"]]]]]
+^D
+.. list-table::
+
+   - 
+
+      - 1 1
+
+      - 1 2
+
+   - 
+
+      - ::
+
+            2 1
+
+      - 2 2
+
+
+
+```