better interface to subDecls

2 files changed, 63 insertions, 48 deletions

diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs
index 1245ff62..ffee5bd7 100644
--- a/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/src/Haddock/Backends/Xhtml/Decl.hs
@@ -480,7 +480,7 @@ ppDataDecl summary links instances subdocs loc mbDoc dataDecl unicode
         ResTyGADT _ -> keyword "where"
         _ -> empty                         
 
-    constrBit = subDecls "Constructors" 
+    constrBit = subConstructors 
       (map (ppSideBySideConstr subdocs unicode) cons)
 
     instancesBit = ppInstances instances docname unicode
@@ -553,45 +553,41 @@ ppConstrHdr forall tvs ctxt unicode
       Explicit -> forallSymbol unicode <+> hsep (map ppName tvs) <+> toHtml ". "
       Implicit -> empty
 
-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 -> 
-      (hsep ((header_ unicode +++ ppBinder False occ)
-        : map (ppLParendType unicode) args), 
-      fmap docToHtml mbDoc)
-
-    RecCon fields -> 
-      (header_ unicode +++ ppBinder False occ,
-      fmap docToHtml mbDoc `with` (Just $ doRecordFields fields))
-
-    InfixCon arg1 arg2 -> 
-      (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 Nothing
-    cd@(RecCon fields) -> doGADTCon (hsConDeclArgTys cd) resTy
-                                          (Just $ doRecordFields fields)
-    InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy Nothing
-
+ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LConDecl DocName -> SubDecl
+ppSideBySideConstr subdocs unicode (L _ con) = (decl, mbDoc, fieldPart)
  where 
-    doRecordFields fields = subDecls "Fields" 
+    decl = case con_res con of 
+      ResTyH98 -> case con_details con of 
+        PrefixCon args -> 
+          hsep ((header_ unicode +++ ppBinder False occ)
+            : map (ppLParendType unicode) args)
+    
+        RecCon _ -> header_ unicode +++ ppBinder False occ
+    
+        InfixCon arg1 arg2 -> 
+          hsep [header_ unicode+++ppLParendType unicode arg1,
+            ppBinder False occ,
+            ppLParendType unicode arg2]
+                 
+      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
+        cd@(RecCon _) -> doGADTCon (hsConDeclArgTys cd) resTy
+        InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy
+
+    fieldPart = case con_details con of 
+        RecCon fields -> [doRecordFields fields]
+        _ -> []
+
+    doRecordFields fields = subFields 
       (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
+    doGADTCon :: [LHsType DocName] -> Located (HsType DocName) -> Html
+    doGADTCon args resTy =
+      ppBinder False occ <+> dcolon unicode
         <+> hsep [ppForAll forall ltvs (con_cxt con) unicode,
-                  ppLType unicode (foldr mkFunTy resTy args) ],
-       fmap docToHtml mbDoc `with` fieldsHtml)
+                  ppLType unicode (foldr mkFunTy resTy args) ]
 
-    with a  = maybe a (\b -> Just $ a +++ b)
     header_ = ppConstrHdr forall tyVars context
     occ     = docNameOcc . unLoc . con_name $ con
     ltvs    = con_qvars con
@@ -604,10 +600,11 @@ 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 ->  (Html, Maybe Html)
+ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocName ->  SubDecl
 ppSideBySideField subdocs unicode (ConDeclField (L _ name) ltype _) =
   (ppBinder False (docNameOcc name) <+> dcolon unicode <+> ppLType unicode ltype,
-    fmap docToHtml mbDoc)
+    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 3ab93b82..80dd5ec8 100644
--- a/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/src/Haddock/Backends/Xhtml/Layout.hs
@@ -18,7 +18,9 @@ module Haddock.Backends.Xhtml.Layout (
   
   shortDeclList,
   divTopDecl,
-  subDecls,
+  
+  SubDecl,
+  subConstructors, subFields,
   
   topDeclElem, declElem,
   
@@ -33,7 +35,6 @@ 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 )
@@ -65,15 +66,32 @@ 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)
+
+type SubDecl = (Html, Maybe (Doc DocName), [Html])
+
+divSubDecls :: String -> String -> Maybe Html -> Html
+divSubDecls cssClass captionName = maybe noHtml wrap
+  where
+    wrap = (subSection <<) . (subCaption +++)
+    subSection = thediv ! [theclass $ unwords ["subs", cssClass]]
+    subCaption = paragraph ! [theclass "caption"] << captionName
+
+subDlist :: [SubDecl] -> Maybe Html
+subDlist [] = Nothing
+subDlist decls = Just $ dlist << map subEntry decls
   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]
+    subEntry (decl, mdoc, subs) = Just $
+      dterm ! [theclass "src"] << decl
+      +++ ddef << (fmap docToHtml mdoc `with` subs)
+    Nothing  `with` [] = spaceHtml
+    ma       `with` bs = ma +++ bs
+
+subConstructors :: [(Html, Maybe (Doc DocName), [Html])] -> Html
+subConstructors = divSubDecls "constructors" "Constructors" . subDlist
+
+subFields :: [(Html, Maybe (Doc DocName), [Html])] -> Html
+subFields = divSubDecls "fields" "Fields" . subDlist
+
 
 -- a box for displaying code
 declElem :: Html -> Html