Grid Tables (#718)

* Add table examples

* Add table types and adopt simple parser

Simple parser is done by Giovanni Cappellotto (@potomak)
in https://github.com/haskell/haddock/pull/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

17 files changed, 594 insertions, 4 deletions

diff --git a/haddock-library/fixtures/Fixtures.hs b/haddock-library/fixtures/Fixtures.hs
index 3707e0a8..f75ff664 100644
--- 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
new file mode 100644
index 00000000..d9c49f87
--- /dev/null
+++ 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
new file mode 100644
index 00000000..b5e62453
--- /dev/null
+++ 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
new file mode 100644
index 00000000..a007020c
--- /dev/null
+++ 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
new file mode 100644
index 00000000..2fa58fd8
--- /dev/null
+++ 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}]]}
diff --git a/haddock-library/fixtures/examples/table2.input b/haddock-library/fixtures/examples/table2.input
new file mode 100644
index 00000000..aa5d0862
--- /dev/null
+++ b/haddock-library/fixtures/examples/table2.input
@@ -0,0 +1,7 @@
++--------------+----------+-----------+-----------+
+| row 1, col 1 | column 2 | column 3  | column 4  |
++--------------+----------+-----------+-----------+
+| row 2        |                                  |
++--------------+----------+-----------+-----------+
+| row 3        |          |           |           |
++--------------+----------+-----------+-----------+
diff --git a/haddock-library/fixtures/examples/table2.parsed b/haddock-library/fixtures/examples/table2.parsed
new file mode 100644
index 00000000..e3dbf0b4
--- /dev/null
+++ b/haddock-library/fixtures/examples/table2.parsed
@@ -0,0 +1,46 @@
+DocTable
+  Table
+    {tableBodyRows = [TableRow
+                        [TableCell
+                           {tableCellColspan = 1,
+                            tableCellContents = DocString " row 1, col 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 " row 2        ",
+                            tableCellRowspan = 1},
+                         TableCell
+                           {tableCellColspan = 3,
+                            tableCellContents = DocString "                                  ",
+                            tableCellRowspan = 1}],
+                      TableRow
+                        [TableCell
+                           {tableCellColspan = 1,
+                            tableCellContents = DocString " row 3        ",
+                            tableCellRowspan = 1},
+                         TableCell
+                           {tableCellColspan = 1,
+                            tableCellContents = DocString "          ",
+                            tableCellRowspan = 1},
+                         TableCell
+                           {tableCellColspan = 1,
+                            tableCellContents = DocString "           ",
+                            tableCellRowspan = 1},
+                         TableCell
+                           {tableCellColspan = 1,
+                            tableCellContents = DocString "           ",
+                            tableCellRowspan = 1}]],
+     tableHeaderRows = []}
diff --git a/haddock-library/fixtures/examples/table3.input b/haddock-library/fixtures/examples/table3.input
new file mode 100644
index 00000000..a6ca84ca
--- /dev/null
+++ b/haddock-library/fixtures/examples/table3.input
@@ -0,0 +1,7 @@
++--------------+----------+-----------+-----------+
+| row 1, col 1 | column 2 | column 3  | column 4  |
++--------------+----------+-----------+-----------+
+| row 2        | Use the command ``ls | more``.   |
++--------------+----------+-----------+-----------+
+| row 3        |          |           |           |
++--------------+----------+-----------+-----------+
diff --git a/haddock-library/fixtures/examples/table3.parsed b/haddock-library/fixtures/examples/table3.parsed
new file mode 100644
index 00000000..cabff9cb
--- /dev/null
+++ b/haddock-library/fixtures/examples/table3.parsed
@@ -0,0 +1,50 @@
+DocTable
+  Table
+    {tableBodyRows = [TableRow
+                        [TableCell
+                           {tableCellColspan = 1,
+                            tableCellContents = DocString " row 1, col 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 " row 2        ",
+                            tableCellRowspan = 1},
+                         TableCell
+                           {tableCellColspan = 2,
+                            tableCellContents = DocString " Use the command ``ls ",
+                            tableCellRowspan = 1},
+                         TableCell
+                           {tableCellColspan = 1,
+                            tableCellContents = DocString " more``.   ",
+                            tableCellRowspan = 1}],
+                      TableRow
+                        [TableCell
+                           {tableCellColspan = 1,
+                            tableCellContents = DocString " row 3        ",
+                            tableCellRowspan = 1},
+                         TableCell
+                           {tableCellColspan = 1,
+                            tableCellContents = DocString "          ",
+                            tableCellRowspan = 1},
+                         TableCell
+                           {tableCellColspan = 1,
+                            tableCellContents = DocString "           ",
+                            tableCellRowspan = 1},
+                         TableCell
+                           {tableCellColspan = 1,
+                            tableCellContents = DocString "           ",
+                            tableCellRowspan = 1}]],
+     tableHeaderRows = []}
diff --git a/haddock-library/fixtures/examples/table4.input b/haddock-library/fixtures/examples/table4.input
new file mode 100644
index 00000000..2c5611c8
--- /dev/null
+++ b/haddock-library/fixtures/examples/table4.input
@@ -0,0 +1,17 @@
+Single outer cell:
+
++-------------+
+|   outer     |
+|             |
++-------+     |
+| inner |     |
++-------+-----+
+
+Broken (only inner cell is rendered):
+
++-------+-----+
+| inner |     |
++-------+     |
+|             |
+|   outer     |
++-------------+
diff --git a/haddock-library/fixtures/examples/table4.parsed b/haddock-library/fixtures/examples/table4.parsed
new file mode 100644
index 00000000..cfdd6f0f
--- /dev/null
+++ b/haddock-library/fixtures/examples/table4.parsed
@@ -0,0 +1,26 @@
+DocAppend
+  (DocParagraph (DocString "Single outer cell:"))
+  (DocAppend
+     (DocTable
+        Table
+          {tableBodyRows = [TableRow
+                              [TableCell
+                                 {tableCellColspan = 1,
+                                  tableCellContents = DocString
+                                                        (concat
+                                                           ["   outer     \n",
+                                                            "             \n",
+                                                            "-------+     \n",
+                                                            " inner |     "]),
+                                  tableCellRowspan = 1}]],
+           tableHeaderRows = []})
+     (DocAppend
+        (DocParagraph (DocString "Broken (only inner cell is rendered):"))
+        (DocTable
+           Table
+             {tableBodyRows = [TableRow
+                                 [TableCell
+                                    {tableCellColspan = 1,
+                                     tableCellContents = DocString " inner ",
+                                     tableCellRowspan = 1}]],
+              tableHeaderRows = []})))
diff --git a/haddock-library/fixtures/examples/table5.input b/haddock-library/fixtures/examples/table5.input
new file mode 100644
index 00000000..7cf26512
--- /dev/null
+++ b/haddock-library/fixtures/examples/table5.input
@@ -0,0 +1,8 @@
++--------------+----------+-----------+-----------+
+| row 1, col 1 | column 2 | column 3  | column 4  |
++==============+==========+===========+===========+
+| row 2        | Use the command  @ls | more@.    |
+|              |                                  |
+|              +----------+-----------+-----------+
+| row 3        |          |           |           |
++--------------+----------+-----------+-----------+
diff --git a/haddock-library/fixtures/examples/table5.parsed b/haddock-library/fixtures/examples/table5.parsed
new file mode 100644
index 00000000..9a547ad3
--- /dev/null
+++ b/haddock-library/fixtures/examples/table5.parsed
@@ -0,0 +1,53 @@
+DocTable
+  Table
+    {tableBodyRows = [TableRow
+                        [TableCell
+                           {tableCellColspan = 1,
+                            tableCellContents = DocString
+                                                  (concat
+                                                     [" row 2        \n",
+                                                      "              \n",
+                                                      "              \n",
+                                                      " row 3        "]),
+                            tableCellRowspan = 2},
+                         TableCell
+                           {tableCellColspan = 3,
+                            tableCellContents = DocAppend
+                                                  (DocString " Use the command  ")
+                                                  (DocAppend
+                                                     (DocMonospaced (DocString "ls | more"))
+                                                     (DocString
+                                                        (concat
+                                                           [".    \n",
+                                                            "                                  "]))),
+                            tableCellRowspan = 1}],
+                      TableRow
+                        [TableCell
+                           {tableCellColspan = 1,
+                            tableCellContents = DocString "          ",
+                            tableCellRowspan = 1},
+                         TableCell
+                           {tableCellColspan = 1,
+                            tableCellContents = DocString "           ",
+                            tableCellRowspan = 1},
+                         TableCell
+                           {tableCellColspan = 1,
+                            tableCellContents = DocString "           ",
+                            tableCellRowspan = 1}]],
+     tableHeaderRows = [TableRow
+                          [TableCell
+                             {tableCellColspan = 1,
+                              tableCellContents = DocString " row 1, col 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}]]}
diff --git a/haddock-library/haddock-library.cabal b/haddock-library/haddock-library.cabal
index 2707a928..62df724b 100644
--- a/haddock-library/haddock-library.cabal
+++ b/haddock-library/haddock-library.cabal
@@ -18,12 +18,14 @@ build-type:           Simple
 cabal-version:        >= 2.0
 extra-source-files:
   CHANGES.md
+
 library
   default-language:     Haskell2010
 
   build-depends:
       base         >= 4.5     && < 4.12
     , bytestring   >= 0.9.2.1 && < 0.11
+    , containers   >= 0.4.2.1 && < 0.6
     , transformers >= 0.3.0   && < 0.6
 
   -- internal sub-lib
@@ -108,6 +110,7 @@ test-suite spec
 
   build-depends:
       base-compat   ^>= 0.9.3
+    , containers   >= 0.4.2.1 && < 0.6
     , transformers   >= 0.3.0   && < 0.6
     , hspec         ^>= 2.4.4
     , QuickCheck    ^>= 2.10
diff --git a/haddock-library/src/Documentation/Haddock/Markup.hs b/haddock-library/src/Documentation/Haddock/Markup.hs
index 1bf6c084..da8edcd4 100644
--- a/haddock-library/src/Documentation/Haddock/Markup.hs
+++ b/haddock-library/src/Documentation/Haddock/Markup.hs
@@ -30,6 +30,7 @@ markup m (DocMathDisplay mathjax)    = markupMathDisplay m mathjax
 markup m (DocProperty p)             = markupProperty m p
 markup m (DocExamples e)             = markupExample m e
 markup m (DocHeader (Header l t))    = markupHeader m (Header l (markup m t))
+markup m (DocTable (Table h b))      = markupTable m (Table (map (fmap (markup m)) h) (map (fmap (markup m)) b))
 
 markupPair :: DocMarkupH mod id a -> (DocH mod id, DocH mod id) -> (a, a)
 markupPair m (a,b) = (markup m a, markup m b)
@@ -59,5 +60,6 @@ idMarkup = Markup {
   markupMathDisplay          = DocMathDisplay,
   markupProperty             = DocProperty,
   markupExample              = DocExamples,
-  markupHeader               = DocHeader
+  markupHeader               = DocHeader,
+  markupTable                = DocTable
   }
diff --git a/haddock-library/src/Documentation/Haddock/Parser.hs b/haddock-library/src/Documentation/Haddock/Parser.hs
index 4ea87db7..a1349c95 100644
--- a/haddock-library/src/Documentation/Haddock/Parser.hs
+++ b/haddock-library/src/Documentation/Haddock/Parser.hs
@@ -24,15 +24,17 @@ import           Control.Arrow (first)
 import           Control.Monad
 import qualified Data.ByteString.Char8 as BS
 import           Data.Char (chr, isAsciiUpper)
-import           Data.List (stripPrefix, intercalate, unfoldr)
-import           Data.Maybe (fromMaybe)
+import           Data.List (stripPrefix, intercalate, unfoldr, elemIndex)
+import           Data.Maybe (fromMaybe, mapMaybe)
 import           Data.Monoid
+import qualified Data.Set as Set
 import           Documentation.Haddock.Doc
 import           Documentation.Haddock.Parser.Monad hiding (take, endOfLine)
 import           Documentation.Haddock.Parser.Util
 import           Documentation.Haddock.Types
 import           Documentation.Haddock.Utf8
 import           Prelude hiding (takeWhile)
+import qualified Prelude as P
 
 -- $setup
 -- >>> :set -XOverloadedStrings
@@ -79,6 +81,7 @@ overIdentifier f d = g d
     g (DocProperty x) = DocProperty x
     g (DocExamples x) = DocExamples x
     g (DocHeader (Header l x)) = DocHeader . Header l $ g x
+    g (DocTable (Table h b)) = DocTable (Table (map (fmap g) h) (map (fmap g) b))
 
 parse :: Parser a -> BS.ByteString -> (ParserState, a)
 parse p = either err id . parseOnly (p <* endOfInput)
@@ -251,7 +254,7 @@ markdownImage = fromHyperlink <$> ("!" *> linkParser)
 
 -- | Paragraph parser, called by 'parseParas'.
 paragraph :: Parser (DocH mod Identifier)
-paragraph = examples <|> do
+paragraph = examples <|> table <|> do
   indent <- takeIndent
   choice
     [ since
@@ -266,6 +269,193 @@ paragraph = examples <|> do
     , docParagraph <$> textParagraph
     ]
 
+-- | Provides support for grid tables.
+--
+-- Tables are composed by an optional header and body. The header is composed by
+-- a single row. The body is composed by a non-empty list of rows.
+--
+-- Example table with header:
+--
+-- > +----------+----------+
+-- > | /32bit/  |   64bit  |
+-- > +==========+==========+
+-- > |  0x0000  | @0x0000@ |
+-- > +----------+----------+
+--
+-- Algorithms loosely follows ideas in
+-- http://docutils.sourceforge.net/docutils/parsers/rst/tableparser.py
+--
+table :: Parser (DocH mod Identifier)
+table = do
+    -- first we parse the first row, which determines the width of the table
+    firstRow <- parseFirstRow
+    let len = BS.length firstRow
+
+    -- then we parse all consequtive rows starting and ending with + or |,
+    -- of the width `len`.
+    restRows <- many (parseRestRows len)
+
+    -- Now we gathered the table block, the next step is to split the block
+    -- into cells.
+    DocTable <$> tableStepTwo len (firstRow : restRows)
+  where
+    parseFirstRow :: Parser BS.ByteString
+    parseFirstRow = do
+        skipHorizontalSpace
+        -- upper-left corner is +
+        c <- char '+'
+        cs <- many1 (char '-' <|> char '+')
+
+        -- upper right corner is + too
+        guard (last cs == '+')
+
+        -- trailing space
+        skipHorizontalSpace
+        _ <- char '\n'
+
+        return (BS.cons c $ BS.pack cs)
+
+    parseRestRows :: Int -> Parser BS.ByteString
+    parseRestRows l = do
+        skipHorizontalSpace
+
+        c <- char '|' <|> char '+'
+        bs <- scan (l - 2) predicate
+        c2 <- char '|' <|> char '+'
+
+        -- trailing space
+        skipHorizontalSpace
+        _ <- char '\n'
+
+        return (BS.cons c (BS.snoc bs c2))
+      where
+        predicate n c
+            | n <= 0    = Nothing
+            | c == '\n' = Nothing
+            | otherwise = Just (n - 1)
+
+-- Second step searchs for row of '+' and '=' characters, records it's index
+-- and changes to '=' to '-'.
+tableStepTwo
+    :: Int              -- ^ width
+    -> [BS.ByteString]  -- ^ rows
+    -> Parser (Table (DocH mod Identifier))
+tableStepTwo width = go 0 [] where
+    go _ left [] = tableStepThree width (reverse left) Nothing
+    go n left (r : rs)
+        | BS.all (`elem` ['+', '=']) r =
+            tableStepThree width (reverse left ++ r' : rs) (Just n)
+        | otherwise =
+            go (n + 1) (r :  left) rs
+      where
+        r' = BS.map (\c -> if c == '=' then '-' else c) r
+
+-- Third step recognises cells in the table area, returning a list of TC, cells.
+tableStepThree
+    :: Int              -- ^ width
+    -> [BS.ByteString]  -- ^ rows
+    -> Maybe Int        -- ^ index of header separator
+    -> Parser (Table (DocH mod Identifier))
+tableStepThree width rs hdrIndex = do
+    cells <- loop (Set.singleton (0, 0))
+    tableStepFour rs hdrIndex cells
+  where
+    height = length rs
+
+    loop :: Set.Set (Int, Int) -> Parser [TC]
+    loop queue = case Set.minView queue of
+        Nothing -> return []
+        Just ((y, x), queue')
+            | y + 1 >= height || x + 1 >= width -> loop queue'
+            | otherwise -> case scanRight x y of
+                Nothing -> loop queue'
+                Just (x2, y2) -> do
+                    let tc = TC y x y2 x2
+                    fmap (tc :) $ loop $ queue' `Set.union` Set.fromList
+                        [(y, x2), (y2, x), (y2, x2)]
+
+    -- scan right looking for +, then try scan down
+    --
+    -- do we need to record + saw on the way left and down?
+    scanRight :: Int -> Int -> Maybe (Int, Int)
+    scanRight x y = go (x + 1) where
+        bs = rs !! y
+        go x' | x' >= width           = fail "overflow right "
+              | BS.index bs x' == '+' = scanDown x y x' <|> go (x' + 1)
+              | BS.index bs x' == '-' = go (x' + 1)
+              | otherwise             = fail $ "not a border (right) " ++ show (x,y,x')
+
+    -- scan down looking for +
+    scanDown :: Int -> Int -> Int -> Maybe (Int, Int)
+    scanDown x y x2 = go (y + 1) where
+        go y' | y' >= height                  = fail "overflow down"
+              | BS.index (rs !! y') x2 == '+' = scanLeft x y x2 y' <|> go (y' + 1)
+              | BS.index (rs !! y') x2 == '|' = go (y' + 1)
+              | otherwise                     = fail $ "not a border (down) " ++ show (x,y,x2,y')
+
+    -- check that at y2 x..x2 characters are '+' or '-'
+    scanLeft :: Int -> Int -> Int -> Int -> Maybe (Int, Int)
+    scanLeft x y x2 y2
+        | all (\x' -> BS.index bs x' `elem` ['+', '-']) [x..x2] = scanUp x y x2 y2
+        | otherwise                                             = fail $ "not a border (left) " ++ show (x,y,x2,y2)
+      where
+        bs = rs !! y2
+
+    -- check that at y2 x..x2 characters are '+' or '-'
+    scanUp :: Int -> Int -> Int -> Int -> Maybe (Int, Int)
+    scanUp x y x2 y2
+        | all (\y' -> BS.index (rs !! y') x `elem` ['+', '|']) [y..y2] = return (x2, y2)
+        | otherwise                                                    = fail $ "not a border (up) " ++ show (x,y,x2,y2)
+
+-- | table cell: top left bottom right
+data TC = TC !Int !Int !Int !Int
+  deriving Show
+
+tcXS :: TC -> [Int]
+tcXS (TC _ x _ x2) = [x, x2]
+
+tcYS :: TC -> [Int]
+tcYS (TC y _ y2 _) = [y, y2]
+
+-- | Fourth step. Given the locations of cells, forms 'Table' structure.
+tableStepFour :: [BS.ByteString] -> Maybe Int -> [TC] -> Parser (Table (DocH mod Identifier))
+tableStepFour rs hdrIndex cells =  case hdrIndex of
+    Nothing -> return $ Table [] rowsDoc
+    Just i  -> case elemIndex i yTabStops of
+        Nothing -> return $ Table [] rowsDoc
+        Just i' -> return $ uncurry Table $ splitAt i' rowsDoc
+  where
+    xTabStops = sortNub $ concatMap tcXS cells
+    yTabStops = sortNub $ concatMap tcYS cells
+
+    sortNub :: Ord a => [a] -> [a]
+    sortNub = Set.toList . Set.fromList
+
+    init' :: [a] -> [a]
+    init' []       = []
+    init' [_]      = []
+    init' (x : xs) = x : init' xs
+
+    rowsDoc = (fmap . fmap) parseStringBS rows
+
+    rows = map makeRow (init' yTabStops)
+      where
+        makeRow y = TableRow $ mapMaybe (makeCell y) cells
+        makeCell y (TC y' x y2 x2)
+            | y /= y' = Nothing
+            | otherwise = Just $ TableCell xts yts (extract (x + 1) (y + 1) (x2 - 1) (y2 - 1))
+          where
+            xts = length $ P.takeWhile (< x2) $ dropWhile (< x) xTabStops
+            yts = length $ P.takeWhile (< y2) $ dropWhile (< y) yTabStops
+
+    -- extract cell contents given boundaries
+    extract :: Int -> Int -> Int -> Int -> BS.ByteString
+    extract x y x2 y2 = BS.intercalate "\n"
+        [ BS.take (x2 - x + 1) $ BS.drop x $ rs !! y'
+        | y' <- [y .. y2]
+        ]
+
+-- | Parse \@since annotations.
 since :: Parser (DocH mod a)
 since = ("@since " *> version <* skipHorizontalSpace <* endOfLine) >>= setSince >> return DocEmpty
   where
diff --git a/haddock-library/src/Documentation/Haddock/Types.hs b/haddock-library/src/Documentation/Haddock/Types.hs
index 1e76c631..96653864 100644
--- a/haddock-library/src/Documentation/Haddock/Types.hs
+++ b/haddock-library/src/Documentation/Haddock/Types.hs
@@ -81,6 +81,21 @@ data Example = Example
   , exampleResult     :: [String]
   } deriving (Eq, Show)
 
+data TableCell id = TableCell
+  { tableCellColspan  :: Int
+  , tableCellRowspan  :: Int
+  , tableCellContents :: id
+  } deriving (Eq, Show, Functor, Foldable, Traversable)
+
+newtype TableRow id = TableRow
+  { tableRowCells :: [TableCell id]
+  } deriving (Eq, Show, Functor, Foldable, Traversable)
+
+data Table id = Table
+  { tableHeaderRows :: [TableRow id]
+  , tableBodyRows   :: [TableRow id]
+  } deriving (Eq, Show, Functor, Foldable, Traversable)
+
 data DocH mod id
   = DocEmpty
   | DocAppend (DocH mod id) (DocH mod id)
@@ -105,6 +120,7 @@ data DocH mod id
   | DocProperty String
   | DocExamples [Example]
   | DocHeader (Header (DocH mod id))
+  | DocTable (Table (DocH mod id))
   deriving (Eq, Show, Functor, Foldable, Traversable)
 
 #if MIN_VERSION_base(4,8,0)
@@ -132,6 +148,7 @@ instance Bifunctor DocH where
   bimap _ _ (DocProperty s) = DocProperty s
   bimap _ _ (DocExamples examples) = DocExamples examples
   bimap f g (DocHeader (Header level title)) = DocHeader (Header level (bimap f g title))
+  bimap f g (DocTable (Table header body)) = DocTable (Table (map (fmap (bimap f g)) header) (map (fmap (bimap f g)) body))
 #endif
 
 #if MIN_VERSION_base(4,10,0)
@@ -149,6 +166,7 @@ instance Bifoldable DocH where
   bifoldr f g z (DocDefList docs) = foldr (\(l, r) acc -> bifoldr f g (bifoldr f g acc l) r) z docs
   bifoldr f g z (DocCodeBlock doc) = bifoldr f g z doc
   bifoldr f g z (DocHeader (Header _ title)) = bifoldr f g z title
+  bifoldr f g z (DocTable (Table header body)) = foldr (\r acc -> foldr (flip (bifoldr f g)) acc r) (foldr (\r acc -> foldr (flip (bifoldr f g)) acc r) z body) header
   bifoldr _ _ z _ = z
 
 instance Bitraversable DocH where
@@ -175,6 +193,7 @@ instance Bitraversable DocH where
   bitraverse _ _ (DocProperty s) = pure (DocProperty s)
   bitraverse _ _ (DocExamples examples) = pure (DocExamples examples)
   bitraverse f g (DocHeader (Header level title)) = (DocHeader . Header level) <$> bitraverse f g title
+  bitraverse f g (DocTable (Table header body)) = (\h b -> DocTable (Table h b)) <$> traverse (traverse (bitraverse f g)) header <*> traverse (traverse (bitraverse f g)) body
 #endif
 
 -- | 'DocMarkupH' is a set of instructions for marking up documentation.
@@ -209,4 +228,5 @@ data DocMarkupH mod id a = Markup
   , markupProperty             :: String -> a
   , markupExample              :: [Example] -> a
   , markupHeader               :: Header a -> a
+  , markupTable                :: Table a -> a
   }