Add expandable method section for each class instance declaration.

2 files changed, 50 insertions, 18 deletions

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index afbbaad1..22b34228 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -269,7 +269,7 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode
       = subEquations qual $ map (ppTyFamEqn . unLoc) eqns
 
       | otherwise
-      = ppInstances links instances Nothing docname unicode qual
+      = ppInstances links instances Nothing docname splice unicode qual
 
     -- Individual equation of a closed type family
     ppTyFamEqn TyFamEqn { tfe_tycon = n, tfe_rhs = rhs
@@ -493,37 +493,54 @@ ppClassDecl summary links instances fixities loc d subdocs
     ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a+++" | "+++b) $ map (ppMinimal False) fs
       where wrap | p = parens | otherwise = id
 
-    instancesBit = ppInstances links instances (Just sigs) nm unicode qual
+    instancesBit = ppInstances links instances (Just sigs) nm splice unicode qual
 
 ppClassDecl _ _ _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"
 
 
 ppInstances :: LinksInfo
             -> [DocInstance DocName] -> Maybe [Sig DocName] -> DocName
-            -> Unicode -> Qualification
+            -> Splice -> Unicode -> Qualification
             -> Html
-ppInstances links instances _ baseName unicode qual
-  = subInstances qual instName links True (map instDecl instances)
+ppInstances links instances msigs baseName splice unicode qual
+  = subInstances qual instName links True (zipWith instDecl [1..] instances)
   -- force Splice = True to use line URLs
   where
     instName = getOccString $ getName baseName
-    instDecl :: DocInstance DocName -> (SubDecl,Located DocName)
-    instDecl (inst, maybeDoc,l) =
-        ((ppInstHead links unicode qual inst, maybeDoc, []),l)
+    instDecl :: Int -> DocInstance DocName -> (SubDecl,Located DocName)
+    instDecl iid (inst, maybeDoc,l) =
+        ((ppInstHead links splice unicode qual msigs iid inst, maybeDoc, []),l)
 
-ppInstHead :: LinksInfo -> Unicode -> Qualification
-           -> InstHead DocName
+
+ppInstHead :: LinksInfo -> Splice -> Unicode -> Qualification
+           -> Maybe [Sig DocName] -> Int -> InstHead DocName
            -> Html
-ppInstHead _ unicode qual (InstHead {..}) = case ihdInstType of
-    ClassInst cs -> ppContextNoLocs cs unicode qual <+> typ
-    TypeInst rhs -> keyword "type" <+> typ
-        <+> maybe noHtml (\t -> equals <+> ppType unicode qual t) rhs
-    DataInst dd -> keyword "data" <+> typ
-        <+> ppShortDataDecl False True dd unicode qual
+ppInstHead links splice unicode qual msigs iid (InstHead {..}) =
+    case ihdInstType of
+        ClassInst cs | Just sigs <- msigs ->
+            subClsInstance (nameStr ++ "-" ++ show iid) hdr (mets sigs)
+          where
+            hdr = ppContextNoLocs cs unicode qual <+> typ
+            mets = ppInstanceSigs links splice unicode qual
+            nameStr = occNameString . nameOccName $ getName ihdClsName
+        ClassInst cs -> ppContextNoLocs cs unicode qual <+> typ
+        TypeInst rhs -> keyword "type" <+> typ
+            <+> maybe noHtml (\t -> equals <+> ppType unicode qual t) rhs
+        DataInst dd -> keyword "data" <+> typ
+            <+> ppShortDataDecl False True dd unicode qual
   where
     typ = ppAppNameTypes ihdClsName ihdKinds ihdTypes unicode qual
 
 
+ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification
+              -> [Sig DocName]
+              -> [Html]
+ppInstanceSigs links splice unicode qual sigs = do
+    TypeSig lnames (L sspan typ) _ <- sigs
+    let names = map unLoc lnames
+    return $ ppFunSig False links sspan noDocForDecl names typ [] splice unicode qual
+
+
 lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2
 lookupAnySubdoc n = fromMaybe noDocForDecl . lookup n
 
@@ -593,7 +610,8 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl
                                      (map unLoc (con_names (unLoc c)))) fixities
       ]
 
-    instancesBit = ppInstances links instances Nothing docname unicode qual
+    instancesBit = ppInstances links instances Nothing docname
+        splice unicode qual
 
 
 
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
index 4714c1b6..188b4243 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
@@ -31,7 +31,7 @@ module Haddock.Backends.Xhtml.Layout (
   subConstructors,
   subEquations,
   subFields,
-  subInstances,
+  subInstances, subClsInstance,
   subMethods,
   subMinimal,
 
@@ -200,6 +200,20 @@ subInstances qual nm lnks splice = maybe noHtml wrap . instTable
     subCaption = paragraph ! collapseControl id_ True "caption" << "Instances"
     id_ = makeAnchorId $ "i:" ++ nm
 
+
+-- | Generate class instance div with specialized methods.
+subClsInstance :: String -- ^ Section unique id
+               -> Html -- ^ Header contents (instance name and type)
+               -> [Html] -- ^ Method contents (pretty-printed signatures)
+               -> Html
+subClsInstance sid hdr mets =
+    hdrDiv <+> methodDiv
+  where
+    anchorId = makeAnchorId $ "i:" ++ sid
+    hdrDiv = thediv ! collapseControl anchorId False "instance" << hdr
+    methodDiv = thediv ! collapseSection anchorId False [] << subMethods mets
+
+
 subMethods :: [Html] -> Html
 subMethods = divSubDecls "methods" "Methods" . subBlock