diff options
Diffstat (limited to 'haddock-api/src/Haddock/Backends/Xhtml')
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 40 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Layout.hs | 14 |
2 files changed, 40 insertions, 14 deletions
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 49149b8c..a7a0a2d6 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -16,7 +16,7 @@ module Haddock.Backends.Xhtml.Decl ( ppDecl, - ppTyName, ppTyFamHeader, ppTypeApp, + ppTyName, ppTyFamHeader, ppTypeApp, ppOrphanInstances, tyvarNames ) where @@ -561,14 +561,32 @@ ppInstances links origin instances splice unicode qual instName = getOccString origin instDecl :: Int -> DocInstance DocName -> (SubDecl,Located DocName) instDecl no (inst, mdoc, loc) = - ((ppInstHead links splice unicode qual mdoc origin no inst), loc) + ((ppInstHead links splice unicode qual mdoc origin False no inst), loc) + + +ppOrphanInstances :: LinksInfo + -> [DocInstance DocName] + -> Splice -> Unicode -> Qualification + -> Html +ppOrphanInstances links instances splice unicode qual + = subOrphanInstances qual links True (zipWith instDecl [1..] instances) + where + instOrigin :: InstHead name -> InstOrigin name + instOrigin inst = OriginClass (ihdClsName inst) + + instDecl :: Int -> DocInstance DocName -> (SubDecl,Located DocName) + instDecl no (inst, mdoc, loc) = + ((ppInstHead links splice unicode qual mdoc (instOrigin inst) True no inst), loc) ppInstHead :: LinksInfo -> Splice -> Unicode -> Qualification -> Maybe (MDoc DocName) - -> InstOrigin DocName -> Int -> InstHead DocName + -> InstOrigin DocName + -> Bool -- ^ Is instance orphan + -> Int -- ^ Normal + -> InstHead DocName -> SubDecl -ppInstHead links splice unicode qual mdoc origin no ihd@(InstHead {..}) = +ppInstHead links splice unicode qual mdoc origin orphan no ihd@(InstHead {..}) = case ihdInstType of ClassInst { .. } -> ( subInstHead iid $ ppContextNoLocs clsiCtx unicode qual <+> typ @@ -576,7 +594,7 @@ ppInstHead links splice unicode qual mdoc origin no ihd@(InstHead {..}) = , [subInstDetails iid ats sigs] ) where - iid = instanceId origin no ihd + iid = instanceId origin no orphan ihd sigs = ppInstanceSigs links splice unicode qual clsiSigs ats = ppInstanceAssocTys links splice unicode qual clsiAssocTys TypeInst rhs -> @@ -618,8 +636,9 @@ lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2 lookupAnySubdoc n = fromMaybe noDocForDecl . lookup n -instanceId :: InstOrigin DocName -> Int -> InstHead DocName -> String -instanceId origin no ihd = concat +instanceId :: InstOrigin DocName -> Int -> Bool -> InstHead DocName -> String +instanceId origin no orphan ihd = concat $ + [ "o:" | orphan ] ++ [ qual origin , ":" ++ getOccString origin , ":" ++ (occNameString . getOccName . ihdClsName) ihd @@ -826,7 +845,7 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Unicode -> Qualification -> ConDeclField DocName -> SubDecl ppSideBySideField subdocs unicode qual (ConDeclField names ltype _) = - (hsep (punctuate comma (map ((ppBinder False) . rdrNameOcc . rdrNameFieldOcc . unLoc) names)) <+> dcolon unicode <+> ppLType unicode qual ltype, + (hsep (punctuate comma (map ((ppBinder False) . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names)) <+> dcolon unicode <+> ppLType unicode qual ltype, mbDoc, []) where @@ -837,7 +856,7 @@ ppSideBySideField subdocs unicode qual (ConDeclField names ltype _) = ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocName -> Html ppShortField summary unicode qual (ConDeclField names ltype _) - = hsep (punctuate comma (map ((ppBinder summary) . rdrNameOcc . rdrNameFieldOcc . unLoc) names)) + = hsep (punctuate comma (map ((ppBinder summary) . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names)) <+> dcolon unicode <+> ppLType unicode qual ltype @@ -997,9 +1016,6 @@ ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode qual = ppr_mono_lty ctxt_prec ty unicode qual ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ _ = char '_' - -ppr_mono_ty _ (HsWildCardTy (NamedWildCard (L _ name))) _ q = ppDocName q Prefix True name - ppr_mono_ty _ (HsTyLit n) _ _ = ppr_tylit n ppr_tylit :: HsTyLit -> Html diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs index d24ed9c4..98df09fe 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, subInstHead, subInstDetails, + subInstances, subOrphanInstances, subInstHead, subInstDetails, subMethods, subMinimal, @@ -200,7 +200,17 @@ subInstances qual nm lnks splice = maybe noHtml wrap . instTable subCaption = paragraph ! collapseControl id_ True "caption" << "Instances" id_ = makeAnchorId $ "i:" ++ nm - + +subOrphanInstances :: Qualification + -> LinksInfo -> Bool + -> [(SubDecl,Located DocName)] -> Html +subOrphanInstances qual lnks splice = maybe noHtml wrap . instTable + where + wrap = ((h1 << "Orphan instances") +++) + instTable = fmap (thediv ! collapseSection id_ True [] <<) . subTableSrc qual lnks splice + id_ = makeAnchorId $ "orphans" + + subInstHead :: String -- ^ Instance unique id (for anchor generation) -> Html -- ^ Header content (instance name and type) -> Html |