Add markup support for tables

haddock-api/resources/html/Classic.theme/xhaddock.css

@@ -390,7 +390,20 @@ td.rdoc p {
 	margin-bottom: 0;
 }
 
+.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

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

@@ -327,7 +327,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

@@ -1138,7 +1138,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 _ _) _ -> text "TODO: TABLE"
   }
   where
     header 1 d = text "\\section*" <> braces d

haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs

@@ -72,7 +72,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 c) -> makeTable h c
   }
   where
     makeHeader :: Int -> Html -> Html
@@ -83,6 +84,11 @@ parHtmlMarkup qual insertAnchors ppId = Markup {
     makeHeader 5 mkup = h5 mkup
     makeHeader 6 mkup = h6 mkup
     makeHeader l _ = error $ "Somehow got a header level `" ++ show l ++ "' in DocMarkup!"
+    makeTable :: Maybe [Html] -> [[Html]] -> Html
+    makeTable mHeaderElements bodyElements = table << (tblHeader +++ tblBody)
+      where
+        tblHeader = maybe noHtml ((thead <<) . besides . map th) mHeaderElements
+        tblBody = tbody << (aboves . map (besides . map td)) bodyElements
 
 
     examplesToHtml l = pre (concatHtml $ map exampleToHtml l) ! [theclass "screen"]

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

@@ -137,6 +137,7 @@ rename dflags gre = rn
       DocAName str -> DocAName str
       DocProperty p -> DocProperty p
       DocExamples e -> DocExamples e
+      DocTable (Table h c) -> DocTable $ Table (fmap rn <$> h) (fmap rn <$> c)
       DocEmpty -> DocEmpty
       DocString str -> DocString str
       DocHeader (Header l t) -> DocHeader $ Header l (rn t)

haddock-api/src/Haddock/InterfaceFile.hs

@@ -464,6 +464,15 @@ 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 c) = do
+        put_ bh h
+        put_ bh c
+    get bh = do
+        h <- get bh
+        c <- get bh
+        return (Table h c)
+
 instance Binary Meta where
   put_ bh Meta { _version = v } = put_ bh v
   get bh = (\v -> Meta { _version = v }) <$> get bh
@@ -547,6 +556,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 +632,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

@@ -468,6 +468,7 @@ instance (NFData a, NFData mod)
     DocAName a                -> a `deepseq` ()
     DocProperty a             -> a `deepseq` ()
     DocExamples a             -> a `deepseq` ()
+    DocTable a                -> a `deepseq` ()
     DocHeader a               -> a `deepseq` ()
 
 #if !MIN_VERSION_ghc(8,0,2)
@@ -489,6 +490,9 @@ 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 a b) = a `deepseq` b `deepseq` ()
+
 
 exampleToString :: Example -> String
 exampleToString (Example expression result) =
@@ -519,6 +523,7 @@ data DocMarkup id a = Markup
   , markupProperty             :: String -> a
   , markupExample              :: [Example] -> a
   , markupHeader               :: Header a -> a
+  , markupTable                :: Table a -> a
   }
 
 

haddock-api/src/Haddock/Utils.hs

@@ -478,6 +478,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 c))      = markupTable m (Table (fmap (markup m) <$> h) (fmap (markup m) <$> c))
 
 
 markupPair :: DocMarkup id a -> (Doc id, Doc id) -> (a, a)
@@ -509,7 +510,8 @@ idMarkup = Markup {
   markupMathDisplay          = DocMathDisplay,
   markupProperty             = DocProperty,
   markupExample              = DocExamples,
-  markupHeader               = DocHeader
+  markupHeader               = DocHeader,
+  markupTable                = DocTable
   }
 
 

haddock-library/src/Documentation/Haddock/Parser.hs

@@ -78,6 +78,7 @@ overIdentifier f d = g d
     g (DocAName x) = DocAName x
     g (DocProperty x) = DocProperty x
     g (DocExamples x) = DocExamples x
+    g (DocTable (Table h c)) = DocTable $ Table (fmap g <$> h) (fmap g <$> c)
     g (DocHeader (Header l x)) = DocHeader . Header l $ g x
 
 parse :: Parser a -> BS.ByteString -> (ParserState, a)
@@ -251,7 +252,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
@@ -422,6 +423,55 @@ takeIndent = do
   indent <- takeHorizontalSpace
   "\n" *> takeIndent <|> return indent
 
+-- | Provides support for simple 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@ |
+-- > +----------+----------+
+table :: Parser (DocH mod Identifier)
+table = do
+  parseTableRowDivider
+  mHeader <- optional parseTableHeader
+  content <- parseTableContent
+  return $ DocTable (Table mHeader content)
+
+parseTableHeader :: Parser [DocH mod Identifier]
+parseTableHeader = parseTableRow <* parseTableHeaderDivider
+
+parseTableContent :: Parser [[DocH mod Identifier]]
+parseTableContent = many1 (parseTableRow <* parseTableRowDivider)
+
+parseTableRow :: Parser [DocH mod Identifier]
+parseTableRow = skipHorizontalSpace *> manyTill columnValue endOfRow
+  where
+    columnValue = parseStringBS . bsStrip <$> ("|" *> takeWhile_ (/= '|'))
+    endOfRow = "|" *> skipHorizontalSpace *> "\n"
+    bsStrip = bsDropWhile isSpace . bsDropWhileEnd isSpace
+    bsDropWhile c = snd . BS.span c
+    bsDropWhileEnd c = fst . BS.spanEnd c
+
+parseTableRowDivider :: Parser ()
+parseTableRowDivider = parseTableDivider "-"
+
+parseTableHeaderDivider :: Parser ()
+parseTableHeaderDivider = parseTableDivider "="
+
+parseTableDivider :: Parser BS.ByteString -> Parser ()
+parseTableDivider c = void $
+       skipHorizontalSpace
+    *> many1 (columnDivider c) *> "+"
+    *> skipHorizontalSpace *> "\n"
+  where
+    columnDivider :: Parser BS.ByteString -> Parser [BS.ByteString]
+    columnDivider d = "+" *> many1 d
+
 -- | Blocks of text of the form:
 --
 -- >> foo

haddock-library/src/Documentation/Haddock/Types.hs

@@ -55,6 +55,11 @@ data Example = Example
   , exampleResult     :: [String]
   } deriving (Eq, Show)
 
+data Table id = Table
+  { tableHeader :: Maybe [id]
+  , tableBody   :: [[id]]
+  } deriving (Eq, Show, Functor, Foldable, Traversable)
+
 data DocH mod id
   = DocEmpty
   | DocAppend (DocH mod id) (DocH mod id)
@@ -78,5 +83,6 @@ data DocH mod id
   | DocAName String
   | DocProperty String
   | DocExamples [Example]
+  | DocTable (Table (DocH mod id))
   | DocHeader (Header (DocH mod id))
   deriving (Eq, Show, Functor, Foldable, Traversable)

haddock-library/test/Documentation/Haddock/ParserSpec.hs

@@ -649,6 +649,50 @@ spec = do
             , " bar"
             ] `shouldParseTo` DocExamples [Example "foo" [" bar"]]
 
+    context "when parsing tables" $ do
+      let simpleTable :: Maybe [DocH () String] -> [[DocH () String]] -> Doc String
+          simpleTable header rows = DocTable (Table header rows)
+          table :: Maybe [DocH () a] -> [[DocH () a]] -> Doc a
+          table header rows = DocTable (Table header rows)
+
+      it "parses a table with a header" $
+        "+----------+----------+\n\
+        \|  32bit   |   64bit  |\n\
+        \+==========+==========+\n\
+        \|  0x0000  |  0x0000  |\n\
+        \+----------+----------+"
+          `shouldParseTo`
+            simpleTable (Just ["32bit", "64bit"]) [["0x0000", "0x0000"]]
+
+      it "parses a table without header" $
+        "+----------+----------+\n\
+        \|  32bit   |   64bit  |\n\
+        \+----------+----------+\n\
+        \|  0x0000  |  0x0000  |\n\
+        \+----------+----------+"
+          `shouldParseTo`
+            simpleTable Nothing [["32bit", "64bit"], ["0x0000", "0x0000"]]
+
+      it "parses a table that contains formatted elements" $
+        "+----------+----------+\n\
+        \| /32bit/  |   64bit  |\n\
+        \+----------+----------+\n\
+        \|  0x0000  | @0x0000@ |\n\
+        \+----------+----------+"
+          `shouldParseTo`
+            table Nothing [
+                [ DocEmphasis (DocString "32bit"), DocString "64bit" ]
+              , [ DocString "0x0000", DocMonospaced (DocString "0x0000") ]
+              ]
+
+      it "can deal with whitespace before and after each line" $
+        "  +----------+----------+  \n\
+        \  |  32bit   |   64bit  |  \n\
+        \  +----------+----------+  \n\
+        \  |  0x0000  |  0x0000  |  \n\
+        \  +----------+----------+  "
+          `shouldParseTo`
+            simpleTable Nothing [["32bit", "64bit"], ["0x0000", "0x0000"]]
 
     context "when parsing paragraphs nested in lists" $ do
       it "can nest the same type of list" $ do