aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorƁukasz Hanuszczak <lukasz.hanuszczak@gmail.com>2015-07-15 14:27:28 +0200
committerMateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk>2015-08-21 18:22:30 +0100
commit05f35d7defbf702e27211628e26a738fa97ecde8 (patch)
treee1f428f13988cc9b237c23196f1f0254933b847a
parent2070c0fa9354365e3e672f5cbee2e04d0ef1fd02 (diff)
Add expandable method section for each class instance declaration.
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs52
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Layout.hs16
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