initial table description render logic

Author: gbaz

Distribution/Server/Pages/Package/HaddockHtml.hs

@@ -34,7 +34,8 @@ htmlMarkup modResolv = 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
@@ -59,6 +60,24 @@ htmlMarkup modResolv = Markup {
         let lnk = anchor ! [href modUrl] << s
         pure (thespan ! [theclass "module"] << lnk)
 
+    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 ]
+
+
 namedAnchor :: String -> Html -> Html
 namedAnchor n = anchor ! [name (escapeStr n)]