constructors and args as dl lists, built in Layout.hs

2 files changed, 42 insertions, 44 deletions

diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs
index 286e9670..1245ff62 100644
--- a/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/src/Haddock/Backends/Xhtml/Decl.hs
@@ -480,26 +480,12 @@ ppDataDecl summary links instances subdocs loc mbDoc dataDecl unicode
         ResTyGADT _ -> keyword "where"
         _ -> empty                         
 
-    constrTable
-      | any isRecCon cons = spacedTable5
-      | otherwise         = spacedTable1
-
-    constrBit 
-      | null cons = noHtml
-      | otherwise = constrHdr +++ ( 
-          constrTable << 
-          aboves (map (ppSideBySideConstr subdocs unicode) cons)
-        )
+    constrBit = subDecls "Constructors" 
+      (map (ppSideBySideConstr subdocs unicode) cons)
 
     instancesBit = ppInstances instances docname unicode
 
 
-isRecCon :: Located (ConDecl a) -> Bool
-isRecCon lcon = case con_details (unLoc lcon) of 
-  RecCon _ -> True
-  _ -> False
-
-
 
 ppShortConstr :: Bool -> ConDecl DocName -> Bool -> Html
 ppShortConstr summary con unicode = cHead <+> cBody <+> cFoot
@@ -567,43 +553,45 @@ ppConstrHdr forall tvs ctxt unicode
       Explicit -> forallSymbol unicode <+> hsep (map ppName tvs) <+> toHtml ". "
       Implicit -> empty
 
-ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LConDecl DocName -> HtmlTable
+ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LConDecl DocName -> (Html, Maybe Html)
 ppSideBySideConstr subdocs unicode (L _ con) = case con_res con of 
  
   ResTyH98 -> case con_details con of 
 
     PrefixCon args -> 
-      argBox (hsep ((header_ unicode +++ ppBinder False occ) : map (ppLParendType unicode) args)) 
-      <-> maybeRDocBox mbDoc  
+      (hsep ((header_ unicode +++ ppBinder False occ)
+        : map (ppLParendType unicode) args), 
+      fmap docToHtml mbDoc)
 
     RecCon fields -> 
-      argBox (header_ unicode +++ ppBinder False occ) <->
-      maybeRDocBox mbDoc
-      </>
-      doRecordFields fields
+      (header_ unicode +++ ppBinder False occ,
+      fmap docToHtml mbDoc `with` (Just $ doRecordFields fields))
 
     InfixCon arg1 arg2 -> 
-      argBox (hsep [header_ unicode+++ppLParendType unicode arg1, ppBinder False occ, ppLParendType unicode arg2])
-      <-> maybeRDocBox mbDoc
+      (hsep [header_ unicode+++ppLParendType unicode arg1,
+        ppBinder False occ,
+        ppLParendType unicode arg2],
+      fmap docToHtml mbDoc)
  
   ResTyGADT resTy -> case con_details con of
     -- prefix & infix could also use hsConDeclArgTys if it seemed to
     -- simplify the code.
-    PrefixCon args -> doGADTCon args resTy
+    PrefixCon args -> doGADTCon args resTy Nothing
     cd@(RecCon fields) -> doGADTCon (hsConDeclArgTys cd) resTy
-                                          </> doRecordFields fields
-    InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy 
+                                          (Just $ doRecordFields fields)
+    InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy Nothing
 
  where 
-    doRecordFields fields =
-        (tda [theclass "body"] << spacedTable1 <<
-        aboves (map (ppSideBySideField subdocs unicode) fields))
-    doGADTCon args resTy = argBox (ppBinder False occ <+> dcolon unicode <+> hsep [
-                               ppForAll forall ltvs (con_cxt con) unicode,
-                               ppLType unicode (foldr mkFunTy resTy args) ]
-                            ) <-> maybeRDocBox mbDoc
-
-
+    doRecordFields fields = subDecls "Fields" 
+      (map (ppSideBySideField subdocs unicode) fields)
+    doGADTCon :: [LHsType DocName] -> Located (HsType DocName) -> Maybe Html -> (Html, Maybe Html)
+    doGADTCon args resTy fieldsHtml =
+      (ppBinder False occ <+> dcolon unicode
+        <+> hsep [ppForAll forall ltvs (con_cxt con) unicode,
+                  ppLType unicode (foldr mkFunTy resTy args) ],
+       fmap docToHtml mbDoc `with` fieldsHtml)
+
+    with a  = maybe a (\b -> Just $ a +++ b)
     header_ = ppConstrHdr forall tyVars context
     occ     = docNameOcc . unLoc . con_name $ con
     ltvs    = con_qvars con
@@ -616,10 +604,10 @@ ppSideBySideConstr subdocs unicode (L _ con) = case con_res con of
     mbDoc = join $ fmap fst $ lookup (unLoc $ con_name con) subdocs
     mkFunTy a b = noLoc (HsFunTy a b)
 
-ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocName ->  HtmlTable
+ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocName ->  (Html, Maybe Html)
 ppSideBySideField subdocs unicode (ConDeclField (L _ name) ltype _) =
-  argBox (ppBinder False (docNameOcc name)
-    <+> dcolon unicode <+> ppLType unicode ltype) <-> maybeRDocBox mbDoc
+  (ppBinder False (docNameOcc name) <+> dcolon unicode <+> ppLType unicode ltype,
+    fmap docToHtml mbDoc)
   where
     -- don't use cd_fld_doc for same reason we don't use con_doc above
     mbDoc = join $ fmap fst $ lookup name subdocs
diff --git a/src/Haddock/Backends/Xhtml/Layout.hs b/src/Haddock/Backends/Xhtml/Layout.hs
index 86c722b7..3ab93b82 100644
--- a/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/src/Haddock/Backends/Xhtml/Layout.hs
@@ -17,11 +17,12 @@ module Haddock.Backends.Xhtml.Layout (
   sectionName,
   
   shortDeclList,
-  divTopDecl, 
+  divTopDecl,
+  subDecls,
   
   topDeclElem, declElem,
   
-  instHdr, atHdr, methHdr, constrHdr,
+  instHdr, atHdr, methHdr,
   argBox, ndocBox, rdocBox, maybeRDocBox,
   
   vanillaTable, vanillaTable2, spacedTable1, spacedTable5  
@@ -32,6 +33,7 @@ import Haddock.Backends.Xhtml.Types
 import Haddock.Backends.Xhtml.Util
 import Haddock.Types
 
+import Data.Char (isLetter, toLower)
 import Text.XHtml hiding ( name, title, p, quote )
 
 import FastString            ( unpackFS )
@@ -63,6 +65,15 @@ shortDeclList items = ulist << map (li ! [theclass "src short"] <<) items
 divTopDecl :: Html -> Html
 divTopDecl = thediv ! [theclass "top"]
 
+subDecls :: String -> [(Html, Maybe Html)] -> Html
+subDecls _    []    = noHtml
+subDecls name decls = subSection << (subCaption +++ subList)
+  where
+    subSection = thediv ! [theclass $ unwords ["subs", subClass]]
+    subClass = map (\c -> if isLetter c then toLower c else '-') name
+    subCaption = paragraph ! [theclass "caption"] << name
+    subList = dlist << map subEntry decls
+    subEntry (dt,dd) = [dterm ! [theclass "src"] << dt, ddef << nonEmpty dd]
 
 -- a box for displaying code
 declElem :: Html -> Html
@@ -129,8 +140,7 @@ spacedTable1, spacedTable5 :: Html -> Html
 spacedTable1 = table ! [theclass "vanilla",  cellspacing 1, cellpadding 0]
 spacedTable5 = table ! [theclass "vanilla",  cellspacing 5, cellpadding 0]
 
-constrHdr, methHdr, atHdr :: Html
-constrHdr  = h5 << "Constructors"
+methHdr, atHdr :: Html
 methHdr    = h5 << "Methods"
 atHdr      = h5 << "Associated Types"