Grid Tables (haskell#718)

* Add table examples * Add table types and adopt simple parser Simple parser is done by Giovanni Cappellotto (@potomak) in haskell#577 It seems to support single fine full tables, so far from full RST-grid tables, but it's good start. Table type support row- and colspans, but obviously parser is lacking. Still TODO: - Latex backend. Should we use multirow package https://ctan.org/pkg/multirow?lang=en? - Hoogle backend: ? * Implement grid-tables * Refactor table parser * Add two ill-examples * Update CHANGES.md * Basic documentation for tables * Fix documentation example
alexbiehl · Feb 1, 2018 · df215ff · df215ff
1 parent 3280e0d
commit df215ff
Show file tree

Hide file tree

Showing 29 changed files with 996 additions and 7 deletions.
diff --git a/CHANGES.md b/CHANGES.md
@@ -2,6 +2,8 @@
 
  * to be released
 
+ * Haddock now supports tables in documentation inspired by reSTs grid tables
+
  * A --reexport flag, which can be used to add extra modules to the
    top-level module tree
 

diff --git a/doc/markup.rst b/doc/markup.rst
@@ -1078,6 +1078,26 @@ If the output format supports it, the mathematics will be rendered
 inside the documentation. For example, the HTML backend will display
 the mathematics via `MathJax <https://www.mathjax.org>`__.
 
+Grid Tables
+~~~~~~~~~~~
+
+Inspired by reSTs grid tables Haddock supports a complete table representation via a grid-like "ASCII art". Grid tables are described with a visual grid made up of the characters "-", "=", "|", and "+". The hyphen ("-") is used for horizontal lines (row separators). The equals sign ("=") may be used to separate optional header rows from the table body. The vertical bar ("|") is used for vertical lines (column separators). The plus sign ("+") is used for intersections of horizontal and vertical lines. ::
+
+    -- | This is a grid table: 
+    -- 
+    -- +------------------------+------------+----------+----------+
+    -- | Header row, column 1   | Header 2   | Header 3 | Header 4 |
+    -- | (header rows optional) |            |          |          |
+    -- +========================+============+==========+==========+
+    -- | body row 1, column 1   | column 2   | column 3 | column 4 |
+    -- +------------------------+------------+----------+----------+
+    -- | body row 2             | Cells may span columns.          |
+    -- +------------------------+------------+---------------------+
+    -- | body row 3             | Cells may  | \[                  |
+    -- +------------------------+ span rows. | f(n) = \sum_{i=1}   |
+    -- | body row 4             |            | \]                  |
+    -- +------------------------+------------+---------------------+
+
 Anchors
 ~~~~~~~
 

diff --git a/haddock-api/resources/html/Classic.theme/xhaddock.css b/haddock-api/resources/html/Classic.theme/xhaddock.css
@@ -392,6 +392,20 @@ td.rdoc p {
 }
 
 
+.doc table {
+  border-collapse: collapse;
+  border-spacing: 0px;
+}
+
+.doc th,
+.doc td {
+  padding: 5px;
+  border: 1px solid #ddd;
+}
+
+.doc th {
+  background-color: #f0f0f0;
+}
 
 #footer {
   background-color: #000099;

diff --git a/haddock-api/resources/html/Ocean.std-theme/ocean.css b/haddock-api/resources/html/Ocean.std-theme/ocean.css
@@ -443,6 +443,21 @@ div#style-menu-holder {
   margin-top: 0.8em;
 }
 
+.doc table {
+  border-collapse: collapse;
+  border-spacing: 0px;
+}
+
+.doc th,
+.doc td {
+  padding: 5px;
+  border: 1px solid #ddd;
+}
+
+.doc th {
+  background-color: #f0f0f0;
+}
+
 .clearfix:after {
   clear: both;
   content: " ";

diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -328,7 +328,8 @@ markupTag dflags = Markup {
   markupAName                = const $ str "",
   markupProperty             = box TagPre . str,
   markupExample              = box TagPre . str . unlines . map exampleToString,
-  markupHeader               = \(Header l h) -> box (TagInline $ "h" ++ show l) h
+  markupHeader               = \(Header l h) -> box (TagInline $ "h" ++ show l) h,
+  markupTable                = \(Table _ _) -> str "TODO: table"
   }
 
 

diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -1140,7 +1140,8 @@ parLatexMarkup ppId = Markup {
   markupAName                = \_ _ -> empty,
   markupProperty             = \p _ -> quote $ verb $ text p,
   markupExample              = \e _ -> quote $ verb $ text $ unlines $ map exampleToString e,
-  markupHeader               = \(Header l h) p -> header l (h p)
+  markupHeader               = \(Header l h) p -> header l (h p),
+  markupTable                = \(Table h b) p -> table h b p
   }
   where
     header 1 d = text "\\section*" <> braces d
@@ -1149,6 +1150,8 @@ parLatexMarkup ppId = Markup {
       | l > 0 && l <= 6 = text "\\subsubsection*" <> braces d
     header l _ = error $ "impossible header level in LaTeX generation: " ++ show l
 
+    table _ _ _ = text "{TODO: Table}"
+
     fixString Plain s = latexFilter s
     fixString Verb  s = s
     fixString Mono  s = latexMonoFilter s

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
@@ -73,7 +73,8 @@ parHtmlMarkup qual insertAnchors ppId = Markup {
   markupMathDisplay          = \mathjax -> toHtml ("\\[" ++ mathjax ++ "\\]"),
   markupProperty             = pre . toHtml,
   markupExample              = examplesToHtml,
-  markupHeader               = \(Header l t) -> makeHeader l t
+  markupHeader               = \(Header l t) -> makeHeader l t,
+  markupTable                = \(Table h r) -> makeTable h r
   }
   where
     makeHeader :: Int -> Html -> Html
@@ -85,6 +86,22 @@ parHtmlMarkup qual insertAnchors ppId = Markup {
     makeHeader 6 mkup = h6 mkup
     makeHeader l _ = error $ "Somehow got a header level `" ++ show l ++ "' in DocMarkup!"
 
+    makeTable :: [TableRow Html] -> [TableRow Html] -> Html
+    makeTable hs bs = table (concatHtml (hs' ++ bs'))
+      where
+        hs' | null hs   = []
+            | otherwise = [thead (concatHtml (map (makeTableRow th) hs))]
+
+        bs' = [tbody (concatHtml (map (makeTableRow td) bs))]
+
+    makeTableRow :: (Html -> Html) -> TableRow Html -> Html
+    makeTableRow thr (TableRow cs) = tr (concatHtml (map (makeTableCell thr) cs))
+
+    makeTableCell :: (Html -> Html) -> TableCell Html -> Html
+    makeTableCell thr (TableCell i j c) = thr c ! (i' ++ j')
+      where
+        i' = if i == 1 then [] else [ colspan i ]
+        j' = if j == 1 then [] else [ rowspan j ]
 
     examplesToHtml l = pre (concatHtml $ map exampleToHtml l) ! [theclass "screen"]
 

diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs
@@ -144,6 +144,7 @@ rename dflags gre = rn
       DocEmpty -> pure (DocEmpty)
       DocString str -> pure (DocString str)
       DocHeader (Header l t) -> DocHeader . Header l <$> rn t
+      DocTable t -> DocTable <$> traverse rn t
 
 -- | Wrap an identifier that's out of scope (i.e. wasn't found in
 -- 'GlobalReaderEnv' during 'rename') in an appropriate doc. Currently

diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs
@@ -459,6 +459,32 @@ instance Binary a => Binary (Header a) where
         t <- get bh
         return (Header l t)
 
+instance Binary a => Binary (Table a) where
+    put_ bh (Table h b) = do
+        put_ bh h
+        put_ bh b
+    get bh = do
+        h <- get bh
+        b <- get bh
+        return (Table h b)
+
+instance Binary a => Binary (TableRow a) where
+    put_ bh (TableRow cs) = put_ bh cs
+    get bh = do
+        cs <- get bh
+        return (TableRow cs)
+
+instance Binary a => Binary (TableCell a) where
+    put_ bh (TableCell i j c) = do
+        put_ bh i
+        put_ bh j
+        put_ bh c
+    get bh = do
+        i <- get bh
+        j <- get bh
+        c <- get bh
+        return (TableCell i j c)
+
 instance Binary Meta where
   put_ bh Meta { _version = v } = put_ bh v
   get bh = (\v -> Meta { _version = v }) <$> get bh
@@ -542,6 +568,9 @@ instance (Binary mod, Binary id) => Binary (DocH mod id) where
     put_ bh (DocMathDisplay x) = do
             putByte bh 22
             put_ bh x
+    put_ bh (DocTable x) = do
+            putByte bh 23
+            put_ bh x
 
     get bh = do
             h <- getByte bh
@@ -615,6 +644,9 @@ instance (Binary mod, Binary id) => Binary (DocH mod id) where
               22 -> do
                     x <- get bh
                     return (DocMathDisplay x)
+              23 -> do
+                    x <- get bh
+                    return (DocTable x)
               _ -> error "invalid binary data found in the interface file"
 
 

diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
@@ -454,6 +454,7 @@ instance (NFData a, NFData mod)
     DocProperty a             -> a `deepseq` ()
     DocExamples a             -> a `deepseq` ()
     DocHeader a               -> a `deepseq` ()
+    DocTable a                -> a `deepseq` ()
 
 #if !MIN_VERSION_ghc(8,0,2)
 -- These were added to GHC itself in 8.0.2
@@ -474,6 +475,14 @@ instance NFData Picture where
 instance NFData Example where
   rnf (Example a b) = a `deepseq` b `deepseq` ()
 
+instance NFData id => NFData (Table id) where
+    rnf (Table h b) = h `deepseq` b `deepseq` ()
+
+instance NFData id => NFData (TableRow id) where
+    rnf (TableRow cs) = cs `deepseq` ()
+
+instance NFData id => NFData (TableCell id) where
+    rnf (TableCell i j c) = i `deepseq` j `deepseq` c `deepseq` ()
 
 exampleToString :: Example -> String
 exampleToString (Example expression result) =

diff --git a/haddock-library/fixtures/Fixtures.hs b/haddock-library/fixtures/Fixtures.hs
@@ -151,3 +151,12 @@ instance ToExpr Picture
 
 deriving instance Generic Example
 instance ToExpr Example
+
+deriving instance Generic (Table id)
+instance ToExpr id => ToExpr (Table id)
+
+deriving instance Generic (TableRow id)
+instance ToExpr id => ToExpr (TableRow id)
+
+deriving instance Generic (TableCell id)
+instance ToExpr id => ToExpr (TableCell id)
diff --git a/haddock-library/fixtures/examples/table-simple.input b/haddock-library/fixtures/examples/table-simple.input
@@ -0,0 +1,7 @@
++------+--------------+------------------------------------------+
+| code | message      | description                              |
++======+==============+==========================================+
+| 200  |   @OK@       | operation successful                     |
++------+--------------+------------------------------------------+
+| 204  | @No Content@ | operation successful, no body returned   |
++------+--------------+------------------------------------------+
diff --git a/haddock-library/fixtures/examples/table-simple.parsed b/haddock-library/fixtures/examples/table-simple.parsed
@@ -0,0 +1,52 @@
+DocTable
+  Table
+    {tableBodyRows = [TableRow
+                        [TableCell
+                           {tableCellColspan = 1,
+                            tableCellContents = DocString " 200  ",
+                            tableCellRowspan = 1},
+                         TableCell
+                           {tableCellColspan = 1,
+                            tableCellContents = DocAppend
+                                                  (DocString "   ")
+                                                  (DocAppend
+                                                     (DocMonospaced (DocString "OK"))
+                                                     (DocString "       ")),
+                            tableCellRowspan = 1},
+                         TableCell
+                           {tableCellColspan = 1,
+                            tableCellContents = DocString
+                                                  " operation successful                     ",
+                            tableCellRowspan = 1}],
+                      TableRow
+                        [TableCell
+                           {tableCellColspan = 1,
+                            tableCellContents = DocString " 204  ",
+                            tableCellRowspan = 1},
+                         TableCell
+                           {tableCellColspan = 1,
+                            tableCellContents = DocAppend
+                                                  (DocString " ")
+                                                  (DocAppend
+                                                     (DocMonospaced (DocString "No Content"))
+                                                     (DocString " ")),
+                            tableCellRowspan = 1},
+                         TableCell
+                           {tableCellColspan = 1,
+                            tableCellContents = DocString
+                                                  " operation successful, no body returned   ",
+                            tableCellRowspan = 1}]],
+     tableHeaderRows = [TableRow
+                          [TableCell
+                             {tableCellColspan = 1,
+                              tableCellContents = DocString " code ",
+                              tableCellRowspan = 1},
+                           TableCell
+                             {tableCellColspan = 1,
+                              tableCellContents = DocString " message      ",
+                              tableCellRowspan = 1},
+                           TableCell
+                             {tableCellColspan = 1,
+                              tableCellContents = DocString
+                                                    " description                              ",
+                              tableCellRowspan = 1}]]}
diff --git a/haddock-library/fixtures/examples/table1.input b/haddock-library/fixtures/examples/table1.input
@@ -0,0 +1,12 @@
++------------------------+------------+----------+----------+
+| Header row, column 1   | Header 2   | Header 3 | Header 4 |
+| (header rows optional) |            |          |          |
++========================+============+==========+==========+
+| body row 1, column 1   | column 2   | column 3 | column 4 |
++------------------------+------------+----------+----------+
+| body row 2             | Cells may span columns.          |
++------------------------+------------+---------------------+
+| body row 3             | Cells may  | \[                  |
++------------------------+ span rows. | f(n) = \sum_{i=1}   |
+| body row 4             |            | \]                  |
++------------------------+------------+---------------------+
diff --git a/haddock-library/fixtures/examples/table1.parsed b/haddock-library/fixtures/examples/table1.parsed
@@ -0,0 +1,81 @@
+DocTable
+  Table
+    {tableBodyRows = [TableRow
+                        [TableCell
+                           {tableCellColspan = 1,
+                            tableCellContents = DocString " body row 1, column 1   ",
+                            tableCellRowspan = 1},
+                         TableCell
+                           {tableCellColspan = 1,
+                            tableCellContents = DocString " column 2   ",
+                            tableCellRowspan = 1},
+                         TableCell
+                           {tableCellColspan = 1,
+                            tableCellContents = DocString " column 3 ",
+                            tableCellRowspan = 1},
+                         TableCell
+                           {tableCellColspan = 1,
+                            tableCellContents = DocString " column 4 ",
+                            tableCellRowspan = 1}],
+                      TableRow
+                        [TableCell
+                           {tableCellColspan = 1,
+                            tableCellContents = DocString " body row 2             ",
+                            tableCellRowspan = 1},
+                         TableCell
+                           {tableCellColspan = 3,
+                            tableCellContents = DocString " Cells may span columns.          ",
+                            tableCellRowspan = 1}],
+                      TableRow
+                        [TableCell
+                           {tableCellColspan = 1,
+                            tableCellContents = DocString " body row 3             ",
+                            tableCellRowspan = 1},
+                         TableCell
+                           {tableCellColspan = 1,
+                            tableCellContents = DocString
+                                                  (concat
+                                                     [" Cells may  \n",
+                                                      " span rows. \n",
+                                                      "            "]),
+                            tableCellRowspan = 2},
+                         TableCell
+                           {tableCellColspan = 2,
+                            tableCellContents = DocAppend
+                                                  (DocString " ")
+                                                  (DocAppend
+                                                     (DocMathDisplay
+                                                        (concat
+                                                           ["                  \n",
+                                                            " f(n) = \\sum_{i=1}   \n",
+                                                            " "]))
+                                                     (DocString "                  ")),
+                            tableCellRowspan = 2}],
+                      TableRow
+                        [TableCell
+                           {tableCellColspan = 1,
+                            tableCellContents = DocString " body row 4             ",
+                            tableCellRowspan = 1}]],
+     tableHeaderRows = [TableRow
+                          [TableCell
+                             {tableCellColspan = 1,
+                              tableCellContents = DocString
+                                                    (concat
+                                                       [" Header row, column 1   \n",
+                                                        " (header rows optional) "]),
+                              tableCellRowspan = 1},
+                           TableCell
+                             {tableCellColspan = 1,
+                              tableCellContents = DocString
+                                                    (concat [" Header 2   \n", "            "]),
+                              tableCellRowspan = 1},
+                           TableCell
+                             {tableCellColspan = 1,
+                              tableCellContents = DocString
+                                                    (concat [" Header 3 \n", "          "]),
+                              tableCellRowspan = 1},
+                           TableCell
+                             {tableCellColspan = 1,
+                              tableCellContents = DocString
+                                                    (concat [" Header 4 \n", "          "]),
+                              tableCellRowspan = 1}]]}