diff options
Diffstat (limited to 'haddock-api/src/Haddock/Backends/Xhtml/Decl.hs')
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 173 |
1 files changed, 141 insertions, 32 deletions
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index d54f4e16..49149b8c 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -1,4 +1,6 @@ {-# LANGUAGE TransformListComp #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE Rank2Types #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Backends.Html.Decl @@ -18,7 +20,6 @@ module Haddock.Backends.Xhtml.Decl ( tyvarNames ) where - import Haddock.Backends.Xhtml.DocMarkup import Haddock.Backends.Xhtml.Layout import Haddock.Backends.Xhtml.Names @@ -28,7 +29,6 @@ import Haddock.GhcUtils import Haddock.Types import Haddock.Doc (combineDocumentation) -import Control.Applicative import Data.List ( intersperse, sort ) import qualified Data.Map as Map import Data.Maybe @@ -38,8 +38,7 @@ import GHC import GHC.Exts import Name import BooleanFormula -import RdrName ( rdrNameOcc, mkRdrUnqual ) -import PrelNames ( mkUnboundName ) +import RdrName ( rdrNameOcc ) ppDecl :: Bool -> LinksInfo -> LHsDecl DocName -> DocForDecl DocName -> [DocInstance DocName] -> [(DocName, Fixity)] @@ -220,11 +219,32 @@ ppTyName :: Name -> Html ppTyName = ppName Prefix +ppSimpleSig :: LinksInfo -> Splice -> Unicode -> Qualification -> SrcSpan + -> [DocName] -> HsType DocName + -> Html +ppSimpleSig links splice unicode qual loc names typ = + topDeclElem' names $ ppTypeSig True occNames ppTyp unicode + where + topDeclElem' = topDeclElem links loc splice + ppTyp = ppType unicode qual typ + occNames = map getOccName names + + -------------------------------------------------------------------------------- -- * Type families -------------------------------------------------------------------------------- +ppFamilyInfo :: Bool -> FamilyInfo DocName -> Html +ppFamilyInfo assoc OpenTypeFamily + | assoc = keyword "type" + | otherwise = keyword "type family" +ppFamilyInfo assoc DataFamily + | assoc = keyword "data" + | otherwise = keyword "data family" +ppFamilyInfo _ (ClosedTypeFamily _) = keyword "type family" + + ppTyFamHeader :: Bool -> Bool -> FamilyDecl DocName -> Unicode -> Qualification -> Html ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info @@ -243,18 +263,25 @@ ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info ) <+> ppFamDeclBinderWithVars summary d <+> - - (case result of - NoSig -> noHtml - KindSig kind -> dcolon unicode <+> ppLKind unicode qual kind - TyVarSig (L _ bndr) -> equals <+> ppHsTyVarBndr unicode qual bndr - ) <+> + ppResultSig result unicode qual <+> (case injectivity of Nothing -> noHtml Just (L _ injectivityAnn) -> ppInjectivityAnn unicode qual injectivityAnn ) +ppResultSig :: FamilyResultSig DocName -> Unicode -> Qualification -> Html +ppResultSig result unicode qual = case result of + NoSig -> noHtml + KindSig kind -> dcolon unicode <+> ppLKind unicode qual kind + TyVarSig (L _ bndr) -> equals <+> ppHsTyVarBndr unicode qual bndr + +ppPseudoFamilyHeader :: Unicode -> Qualification -> PseudoFamilyDecl DocName + -> Html +ppPseudoFamilyHeader unicode qual (PseudoFamilyDecl { .. }) = + ppFamilyInfo True pfdInfo <+> + ppAppNameTypes (unLoc pfdLName) [] (map unLoc pfdTyVars) unicode qual <+> + ppResultSig (unLoc pfdKindSig) unicode qual ppInjectivityAnn :: Bool -> Qualification -> InjectivityAnn DocName -> Html ppInjectivityAnn unicode qual (InjectivityAnn lhs rhs) = @@ -282,7 +309,7 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode = subEquations qual $ map (ppTyFamEqn . unLoc) $ fromMaybe [] mb_eqns | otherwise - = ppInstances instances docname unicode qual + = ppInstances links (OriginFamily docname) instances splice unicode qual -- Individual equation of a closed type family ppTyFamEqn TyFamEqn { tfe_tycon = n, tfe_rhs = rhs @@ -291,6 +318,18 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode <+> equals <+> ppType unicode qual (unLoc rhs) , Nothing, [] ) + + +ppPseudoFamilyDecl :: LinksInfo -> Splice -> Unicode -> Qualification + -> PseudoFamilyDecl DocName + -> Html +ppPseudoFamilyDecl links splice unicode qual + decl@(PseudoFamilyDecl { pfdLName = L loc name, .. }) = + wrapper $ ppPseudoFamilyHeader unicode qual decl + where + wrapper = topDeclElem links loc splice [name] + + -------------------------------------------------------------------------------- -- * Associated Types -------------------------------------------------------------------------------- @@ -450,6 +489,8 @@ ppClassDecl summary links instances fixities loc d subdocs | otherwise = classheader +++ docSection Nothing qual d +++ minimalBit +++ atBit +++ methodBit +++ instancesBit where + sigs = map unLoc lsigs + classheader | any isUserLSig lsigs = topDeclElem links loc splice [nm] (hdr unicode qual <+> keyword "where" <+> fixs) | otherwise = topDeclElem links loc splice [nm] (hdr unicode qual <+> fixs) @@ -480,10 +521,10 @@ ppClassDecl summary links instances fixities loc d subdocs -- there are different subdocs for different names in a single -- type signature? - minimalBit = case [ s | L _ (MinimalSig _ (L _ s)) <- lsigs ] of + minimalBit = case [ s | MinimalSig _ (L _ s) <- sigs ] of -- Miminal complete definition = every shown method And xs : _ | sort [getName n | L _ (Var (L _ n)) <- xs] == - sort [getName n | L _ (TypeSig ns _) <- lsigs, L _ n <- ns] + sort [getName n | TypeSig ns _ <- sigs, L _ n <- ns] -> noHtml -- Minimal complete definition = the only shown method @@ -503,31 +544,93 @@ ppClassDecl summary links instances fixities loc d subdocs where wrap | p = parens | otherwise = id ppMinimal p (Parens x) = ppMinimal p (unLoc x) - instancesBit = ppInstances instances nm unicode qual + instancesBit = ppInstances links (OriginClass nm) instances + splice unicode qual ppClassDecl _ _ _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" -ppInstances :: [DocInstance DocName] -> DocName -> Unicode -> Qualification -> Html -ppInstances instances baseName unicode qual - = subInstances qual instName (map instDecl instances) +ppInstances :: LinksInfo + -> InstOrigin DocName -> [DocInstance DocName] + -> Splice -> Unicode -> Qualification + -> Html +ppInstances links origin instances splice unicode qual + = subInstances qual instName links True (zipWith instDecl [1..] instances) + -- force Splice = True to use line URLs + where + 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 :: LinksInfo -> Splice -> Unicode -> Qualification + -> Maybe (MDoc DocName) + -> InstOrigin DocName -> Int -> InstHead DocName + -> SubDecl +ppInstHead links splice unicode qual mdoc origin no ihd@(InstHead {..}) = + case ihdInstType of + ClassInst { .. } -> + ( subInstHead iid $ ppContextNoLocs clsiCtx unicode qual <+> typ + , mdoc + , [subInstDetails iid ats sigs] + ) + where + iid = instanceId origin no ihd + sigs = ppInstanceSigs links splice unicode qual clsiSigs + ats = ppInstanceAssocTys links splice unicode qual clsiAssocTys + TypeInst rhs -> + (ptype, mdoc, []) + where + ptype = keyword "type" <+> typ <+> prhs + prhs = maybe noHtml (\t -> equals <+> ppType unicode qual t) rhs + DataInst dd -> + (pdata, mdoc, []) + where + pdata = keyword "data" <+> typ <+> pdecl + pdecl = ppShortDataDecl False True dd unicode qual + where + typ = ppAppNameTypes ihdClsName ihdKinds ihdTypes unicode qual + + +ppInstanceAssocTys :: LinksInfo -> Splice -> Unicode -> Qualification + -> [PseudoFamilyDecl DocName] + -> [Html] +ppInstanceAssocTys links splice unicode qual = + map ppFamilyDecl' where - instName = getOccString $ getName baseName - instDecl :: DocInstance DocName -> SubDecl - instDecl (inst, maybeDoc) = (instHead inst, maybeDoc, []) - instHead (n, ks, ts, ClassInst cs) = ppContextNoLocs cs unicode qual - <+> ppAppNameTypes n ks ts unicode qual - instHead (n, ks, ts, TypeInst rhs) = keyword "type" - <+> ppAppNameTypes n ks ts unicode qual - <+> maybe noHtml (\t -> equals <+> ppType unicode qual t) rhs - instHead (n, ks, ts, DataInst dd) = keyword "data" - <+> ppAppNameTypes n ks ts unicode qual - <+> ppShortDataDecl False True dd unicode qual + ppFamilyDecl' = ppPseudoFamilyDecl links splice unicode qual + + +ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification + -> [Sig DocName] + -> [Html] +ppInstanceSigs links splice unicode qual sigs = do + TypeSig lnames typ <- sigs + let names = map unLoc lnames + L loc rtyp = get_type typ + return $ ppSimpleSig links splice unicode qual loc names rtyp + where + get_type = hswc_body . hsib_body + 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 + [ qual origin + , ":" ++ getOccString origin + , ":" ++ (occNameString . getOccName . ihdClsName) ihd + , ":" ++ show no + ] + where + qual (OriginClass _) = "ic" + qual (OriginData _) = "id" + qual (OriginFamily _) = "if" + + ------------------------------------------------------------------------------- -- * Data & newtype declarations ------------------------------------------------------------------------------- @@ -595,7 +698,8 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl (map unLoc (getConNames (unLoc c)))) fixities ] - instancesBit = ppInstances instances docname unicode qual + instancesBit = ppInstances links (OriginData docname) instances + splice unicode qual @@ -862,8 +966,8 @@ ppr_mono_ty _ (HsRecTy {}) _ _ = toHtml "{..}" -- placeholder in the signature, which is followed by the field -- declarations. ppr_mono_ty _ (HsCoreTy {}) _ _ = error "ppr_mono_ty HsCoreTy" -ppr_mono_ty _ (HsExplicitListTy _ tys) u q = quote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys -ppr_mono_ty _ (HsExplicitTupleTy _ tys) u q = quote $ parenList $ map (ppLType u q) tys +ppr_mono_ty _ (HsExplicitListTy _ tys) u q = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys +ppr_mono_ty _ (HsExplicitTupleTy _ tys) u q = promoQuote $ parenList $ map (ppLType u q) tys ppr_mono_ty _ (HsAppsTy {}) _ _ = error "ppr_mono_ty HsAppsTy" ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode qual @@ -878,7 +982,12 @@ ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode qual = maybeParen ctxt_prec pREC_FUN $ ppr_mono_lty pREC_OP ty1 unicode qual <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode qual where - ppr_op = ppLDocName qual Infix op + -- `(:)` is valid in type signature only as constructor to promoted list + -- and needs to be quoted in code so we explicitly quote it here too. + ppr_op + | (getOccString . getName . unLoc) op == ":" = promoQuote ppr_op' + | otherwise = ppr_op' + ppr_op' = ppLDocName qual Infix op ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual -- = parens (ppr_mono_lty pREC_TOP ty) |