Grid Tables (#718)

* Add table examples

* Add table types and adopt simple parser

Simple parser is done by Giovanni Cappellotto (@potomak)
in #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

Author: phadej

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
 

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
 ~~~~~~~
 

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;

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: " ";

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"
   }
 
 

haddock-api/src/Haddock/Backends/LaTeX.hs

@@ -1139,7 +1139,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
@@ -1148,6 +1149,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

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"]
 

haddock-api/src/Haddock/Interface/LexParseRn.hs

@@ -143,6 +143,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

haddock-api/src/Haddock/InterfaceFile.hs

@@ -464,6 +464,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
@@ -547,6 +573,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
@@ -620,6 +649,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"
 
 

haddock-api/src/Haddock/Types.hs

@@ -471,6 +471,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
@@ -491,6 +492,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) =