Tue Nov 28 11:34:14 UTC 2017

Repository : ssh://git@git.haskell.org/haddock

On branches: 2.17.3.1-spanfix,alexbiehl-patch-1,ghc-8.0,ghc-8.0-facebook,ghc-head,ghc-head1,haddock-quick,headdock-library-1.4.5,ie_avails,issue-303,issue-475,master,pr-filter-maps,pr/cabal-desc,travis,v2.16,v2.17,v2.17.3,v2.18,wip-located-module-as,wip/D2418,wip/T11080-open-data-kinds,wip/T11258,wip/T11430,wip/T12105,wip/T12105-2,wip/T12942,wip/T13163,wip/T14529,wip/T3384,wip/embelleshed-rdr,wip/new-tree-one-param,wip/rae,wip/remove-frames,wip/remove-frames1,wip/revert-ttg-2017-11-20,wip/ttg-2017-10-13,wip/ttg-2017-10-31,wip/ttg-2017-11-06,wip/ttg2-2017-11-10,wip/ttg3-2017-11-12,wip/ttg4-constraints-2017-11-13,wip/ttg6-unrevert-2017-11-22
Link       : http://git.haskell.org/haddock.git/commitdiff/05f35d7defbf702e27211628e26a738fa97ecde8

>---------------------------------------------------------------

commit 05f35d7defbf702e27211628e26a738fa97ecde8
Author: Łukasz Hanuszczak <lukasz.hanuszczak at gmail.com>
Date:   Wed Jul 15 14:27:28 2015 +0200

    Add expandable method section for each class instance declaration.


>---------------------------------------------------------------

05f35d7defbf702e27211628e26a738fa97ecde8
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs   | 52 ++++++++++++++++--------
 haddock-api/src/Haddock/Backends/Xhtml/Layout.hs | 16 +++++++-
 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 afbbaad..22b3422 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 4714c1b..188b424 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
 

