diff options
Diffstat (limited to 'haddock-api/src/Haddock/Backends/Xhtml')
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 141 |
1 files changed, 84 insertions, 57 deletions
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 0b0050df..de37e42a 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -63,9 +63,9 @@ ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdoc TyClD _ d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode pkg qual TyClD _ d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode pkg qual SigD _ (TypeSig _ lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames - (hsSigWcType lty) fixities splice unicode pkg qual + (dropWildCards lty) fixities splice unicode pkg qual SigD _ (PatSynSig _ lnames lty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lnames - (hsSigTypeI lty) fixities splice unicode pkg qual + lty fixities splice unicode pkg qual ForD _ d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode pkg qual InstD _ _ -> noHtml DerivD _ _ -> noHtml @@ -73,25 +73,25 @@ ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdoc ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> - [Located DocName] -> LHsType DocNameI -> [(DocName, Fixity)] -> + [Located DocName] -> LHsSigType DocNameI -> [(DocName, Fixity)] -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppLFunSig summary links loc doc lnames lty fixities splice unicode pkg qual = ppFunSig summary links loc noHtml doc (map unLoc lnames) lty fixities splice unicode pkg qual ppFunSig :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName -> - [DocName] -> LHsType DocNameI -> [(DocName, Fixity)] -> + [DocName] -> LHsSigType DocNameI -> [(DocName, Fixity)] -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppFunSig summary links loc leader doc docnames typ fixities splice unicode pkg qual = ppSigLike summary links loc leader doc docnames fixities (unLoc typ, pp_typ) splice unicode pkg qual HideEmptyContexts where - pp_typ = ppLType unicode qual HideEmptyContexts typ + pp_typ = ppLSigType unicode qual HideEmptyContexts typ -- | Pretty print a pattern synonym ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> [Located DocName] -- ^ names of patterns in declaration - -> LHsType DocNameI -- ^ type of patterns in declaration + -> LHsSigType DocNameI -- ^ type of patterns in declaration -> [(DocName, Fixity)] -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppLPatSig summary links loc doc lnames typ fixities splice unicode pkg qual = @@ -102,7 +102,7 @@ ppLPatSig summary links loc doc lnames typ fixities splice unicode pkg qual = ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName -> - [DocName] -> [(DocName, Fixity)] -> (HsType DocNameI, Html) -> + [DocName] -> [(DocName, Fixity)] -> (HsSigType DocNameI, Html) -> Splice -> Unicode -> Maybe Package -> Qualification -> HideEmptyContexts -> Html ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ) splice unicode pkg qual emptyCtxts = @@ -119,7 +119,7 @@ ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ) | otherwise = html <+> ppFixities fixities qual -ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsType DocNameI +ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsSigType DocNameI -> DocForDecl DocName -> (Html, Html, Html) -> Splice -> Unicode -> Maybe Package -> Qualification -> HideEmptyContexts -> Html @@ -140,15 +140,24 @@ ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) -- If one passes in a list of the available subdocs, any top-level `HsRecTy` -- found will be expanded out into their fields. ppSubSigLike :: Unicode -> Qualification - -> HsType DocNameI -- ^ type signature + -> HsSigType DocNameI -- ^ type signature -> FnArgsDoc DocName -- ^ docs to add -> [(DocName, DocForDecl DocName)] -- ^ all subdocs (useful when -- we expand an `HsRecTy`) -> Html -> HideEmptyContexts -> [SubDecl] -ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_args 0 sep typ +ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_sig_args 0 sep typ where + do_sig_args :: Int -> Html -> HsSigType DocNameI -> [SubDecl] + do_sig_args n leader (HsSig { sig_bndrs = outer_bndrs, sig_body = ltype }) = + case outer_bndrs of + HsOuterExplicit{hso_bndrs = bndrs} -> do_largs n (leader' bndrs) ltype + HsOuterImplicit{} -> do_largs n leader ltype + where + leader' bndrs = leader <+> ppForAllPart unicode qual (mkHsForAllInvisTeleI bndrs) + argDoc n = Map.lookup n argDocs + do_largs :: Int -> Html -> LHsType DocNameI -> [SubDecl] do_largs n leader (L _ t) = do_args n leader t do_args :: Int -> Html -> HsType DocNameI -> [SubDecl] @@ -222,7 +231,7 @@ ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppFor summary links loc doc (ForeignImport _ (L _ name) typ _) fixities splice unicode pkg qual - = ppFunSig summary links loc noHtml doc [name] (hsSigTypeI typ) fixities splice unicode pkg qual + = ppFunSig summary links loc noHtml doc [name] typ fixities splice unicode pkg qual ppFor _ _ _ _ _ _ _ _ _ _ = error "ppFor" @@ -233,13 +242,14 @@ ppTySyn :: Bool -> LinksInfo -> [(DocName, Fixity)] -> SrcSpan ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars , tcdRhs = ltype }) splice unicode pkg qual - = ppTypeOrFunSig summary links loc [name] (unLoc ltype) doc + = ppTypeOrFunSig summary links loc [name] sig_type doc (full <+> fixs, hdr <+> fixs, spaceHtml +++ equals) splice unicode pkg qual ShowEmptyToplevelContexts where + sig_type = mkHsImplicitSigTypeI ltype hdr = hsep ([keyword "type", ppBinder summary occ] ++ ppTyVars unicode qual (hsQTvExplicit ltyvars)) - full = hdr <+> equals <+> ppPatSigType unicode qual ltype + full = hdr <+> equals <+> ppPatSigType unicode qual (noLoc sig_type) occ = nameOccName . getName $ name fixs | summary = noHtml @@ -253,15 +263,14 @@ ppTypeSig summary nms pp_ty unicode = where htmlNames = intersperse (stringToHtml ", ") $ map (ppBinder summary) nms - ppSimpleSig :: LinksInfo -> Splice -> Unicode -> Qualification -> HideEmptyContexts -> SrcSpan - -> [DocName] -> HsType DocNameI + -> [DocName] -> HsSigType DocNameI -> Html ppSimpleSig links splice unicode qual emptyCtxts loc names typ = topDeclElem' names $ ppTypeSig True occNames ppTyp unicode where topDeclElem' = topDeclElem links loc splice - ppTyp = ppType unicode qual emptyCtxts typ + ppTyp = ppSigType unicode qual emptyCtxts typ occNames = map getOccName names @@ -301,9 +310,9 @@ ppFamDecl summary associated links instances fixities loc doc decl splice unicod -- Individual equation of a closed type family ppFamDeclEqn :: TyFamInstEqn DocNameI -> SubDecl - ppFamDeclEqn (HsIB { hsib_body = FamEqn { feqn_tycon = L _ n - , feqn_rhs = rhs - , feqn_pats = ts } }) + ppFamDeclEqn (FamEqn { feqn_tycon = L _ n + , feqn_rhs = rhs + , feqn_pats = ts }) = ( ppAppNameTypeArgs n ts unicode qual <+> equals <+> ppType unicode qual HideEmptyContexts (unLoc rhs) , Nothing @@ -497,7 +506,7 @@ ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, t -- ToDo: add associated type defaults - [ ppFunSig summary links loc noHtml doc names (hsSigTypeI typ) + [ ppFunSig summary links loc noHtml doc names typ [] splice unicode pkg qual | L _ (ClassOpSig _ False lnames typ) <- sigs , let doc = lookupAnySubdoc (head names) subdocs @@ -561,14 +570,14 @@ ppClassDecl summary links instances fixities loc d subdocs lookupDAT name = Map.lookup (getName name) defaultAssocTys defaultAssocTys = Map.fromList [ (getName name, (vs, typ)) - | L _ (TyFamInstDecl (HsIB _ (FamEqn { feqn_rhs = typ - , feqn_tycon = L _ name - , feqn_pats = vs }))) <- atsDefs + | L _ (TyFamInstDecl (FamEqn { feqn_rhs = typ + , feqn_tycon = L _ name + , feqn_pats = vs })) <- atsDefs ] -- Methods methodBit = subMethods - [ ppFunSig summary links loc noHtml doc [name] (hsSigTypeI typ) + [ ppFunSig summary links loc noHtml doc [name] typ subfixs splice unicode pkg qual <+> subDefaults (maybeToList defSigs) @@ -583,7 +592,7 @@ ppClassDecl summary links instances fixities loc d subdocs -- Default methods ppDefaultFunSig n (t, d') = ppFunSig summary links loc (keyword "default") - d' [n] (hsSigTypeI t) [] splice unicode pkg qual + d' [n] t [] splice unicode pkg qual lookupDM name = Map.lookup (getOccString name) defaultMethods defaultMethods = Map.fromList @@ -709,7 +718,7 @@ ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification ppInstanceSigs links splice unicode qual sigs = do TypeSig _ lnames typ <- sigs let names = map unLoc lnames - L _ rtyp = hsSigWcType typ + L _ rtyp = dropWildCards typ -- Instance methods signatures are synified and thus don't have a useful -- SrcSpan value. Use the methods name location instead. return $ ppSimpleSig links splice unicode qual HideEmptyContexts (getLoc $ head $ lnames) names rtyp @@ -772,7 +781,7 @@ ppShortDataDecl summary dataInst dataDecl pats unicode qual pats1 = [ hsep [ keyword "pattern" , hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames , dcolon unicode - , ppPatSigType unicode qual (hsSigTypeI typ) + , ppPatSigType unicode qual typ ] | (SigD _ (PatSynSig _ lnames typ),_) <- pats ] @@ -851,7 +860,7 @@ ppShortConstrParts summary dataInst con unicode qual in case det of -- Prefix constructor, e.g. 'Just a' - PrefixCon args -> + PrefixCon _ args -> ( header_ <+> hsep (ppOcc : map (ppLParendType unicode qual HideEmptyContexts . hsScaledThing) args) , noHtml , noHtml @@ -878,7 +887,7 @@ ppShortConstrParts summary dataInst con unicode qual -- GADT constructor, e.g. 'Foo :: Int -> Foo' ConDeclGADT {} -> - ( hsep [ ppOcc, dcolon unicode, ppLType unicode qual HideEmptyContexts (getGADTConType con) ] + ( hsep [ ppOcc, dcolon unicode, ppLSigType unicode qual HideEmptyContexts (getGADTConType con) ] , noHtml , noHtml ) @@ -922,7 +931,7 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con) header_ = ppConstrHdr forall_ tyVars context unicode qual in case det of -- Prefix constructor, e.g. 'Just a' - PrefixCon args + PrefixCon _ args | hasArgDocs -> header_ <+> ppOcc <+> fixity | otherwise -> hsep [ header_ <+> ppOcc , hsep (map (ppLParendType unicode qual HideEmptyContexts . hsScaledThing) args) @@ -947,24 +956,26 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con) | otherwise -> hsep [ ppOcc , dcolon unicode -- ++AZ++ make this prepend "{..}" when it is a record style GADT - , ppLType unicode qual HideEmptyContexts (getGADTConType con) + , ppLSigType unicode qual HideEmptyContexts (getGADTConType con) , fixity ] - fieldPart = case (con, getConArgsI con) of - -- Record style GADTs - (ConDeclGADT{}, RecCon _) -> [ doConstrArgsWithDocs [] ] - - -- Regular record declarations - (_, RecCon (L _ fields)) -> [ doRecordFields fields ] - - -- Any GADT or a regular H98 prefix data constructor - (_, PrefixCon args) | hasArgDocs -> [ doConstrArgsWithDocs args ] - - -- An infix H98 data constructor - (_, InfixCon arg1 arg2) | hasArgDocs -> [ doConstrArgsWithDocs [arg1,arg2] ] - - _ -> [] + fieldPart = case con of + ConDeclGADT{con_g_args = con_args'} -> case con_args' of + -- GADT record declarations + RecConGADT _ -> [ doConstrArgsWithDocs [] ] + -- GADT prefix data constructors + PrefixConGADT args | hasArgDocs -> [ doConstrArgsWithDocs args ] + _ -> [] + + ConDeclH98{con_args = con_args'} -> case con_args' of + -- H98 record declarations + RecCon (L _ fields) -> [ doRecordFields fields ] + -- H98 prefix data constructors + PrefixCon _ args | hasArgDocs -> [ doConstrArgsWithDocs args ] + -- H98 infix data constructor + InfixCon arg1 arg2 | hasArgDocs -> [ doConstrArgsWithDocs [arg1,arg2] ] + _ -> [] doRecordFields fields = subFields pkg qual (map (ppSideBySideField subdocs unicode qual) (map unLoc fields)) @@ -1049,18 +1060,17 @@ ppSideBySidePat fixities unicode qual lnames typ (doc, argDocs) = | otherwise = hsep [ keyword "pattern" , ppOcc , dcolon unicode - , ppPatSigType unicode qual (hsSigTypeI typ) + , ppPatSigType unicode qual typ , fixity ] fieldPart | not hasArgDocs = [] - | otherwise = [ subFields Nothing qual (ppSubSigLike unicode qual (unLoc patTy) + | otherwise = [ subFields Nothing qual (ppSubSigLike unicode qual (unLoc typ) argDocs [] (dcolon unicode) emptyCtxt) ] - patTy = hsSigTypeI typ - emptyCtxt = patSigContext patTy + emptyCtxt = patSigContext typ -- | Print the LHS of a data\/newtype declaration. @@ -1114,6 +1124,9 @@ ppLType unicode qual emptyCtxts y = ppType unicode qual emptyCtxts (unLoc ppLParendType unicode qual emptyCtxts y = ppParendType unicode qual emptyCtxts (unLoc y) ppLFunLhType unicode qual emptyCtxts y = ppFunLhType unicode qual emptyCtxts (unLoc y) +ppLSigType :: Unicode -> Qualification -> HideEmptyContexts -> LHsSigType DocNameI -> Html +ppLSigType unicode qual emptyCtxts y = ppSigType unicode qual emptyCtxts (unLoc y) + ppCtxType :: Unicode -> Qualification -> HsType DocNameI -> Html ppCtxType unicode qual ty = ppr_mono_ty (reparenTypePrec PREC_CTX ty) unicode qual HideEmptyContexts @@ -1122,6 +1135,9 @@ ppType unicode qual emptyCtxts ty = ppr_mono_ty (reparenTypePrec PREC_TOP ppParendType unicode qual emptyCtxts ty = ppr_mono_ty (reparenTypePrec PREC_CON ty) unicode qual emptyCtxts ppFunLhType unicode qual emptyCtxts ty = ppr_mono_ty (reparenTypePrec PREC_FUN ty) unicode qual emptyCtxts +ppSigType :: Unicode -> Qualification -> HideEmptyContexts -> HsSigType DocNameI -> Html +ppSigType unicode qual emptyCtxts sig_ty = ppr_sig_ty (reparenSigType sig_ty) unicode qual emptyCtxts + ppLHsTypeArg :: Unicode -> Qualification -> HideEmptyContexts -> LHsTypeArg DocNameI -> Html ppLHsTypeArg unicode qual emptyCtxts (HsValArg ty) = ppLParendType unicode qual emptyCtxts ty ppLHsTypeArg unicode qual emptyCtxts (HsTypeArg _ ki) = atSign unicode <> @@ -1156,18 +1172,18 @@ ppLKind unicode qual y = ppKind unicode qual (unLoc y) ppKind :: Unicode -> Qualification -> HsKind DocNameI -> Html ppKind unicode qual ki = ppr_mono_ty (reparenTypePrec PREC_TOP ki) unicode qual HideEmptyContexts -patSigContext :: LHsType name -> HideEmptyContexts -patSigContext typ | hasNonEmptyContext typ && isFirstContextEmpty typ = ShowEmptyToplevelContexts - | otherwise = HideEmptyContexts +patSigContext :: LHsSigType DocNameI -> HideEmptyContexts +patSigContext sig_typ | hasNonEmptyContext typ && isFirstContextEmpty typ = ShowEmptyToplevelContexts + | otherwise = HideEmptyContexts where - hasNonEmptyContext :: LHsType name -> Bool + typ = sig_body (unLoc sig_typ) + hasNonEmptyContext t = case unLoc t of HsForAllTy _ _ s -> hasNonEmptyContext s HsQualTy _ cxt s -> if null (unLoc cxt) then hasNonEmptyContext s else True HsFunTy _ _ _ s -> hasNonEmptyContext s _ -> False - isFirstContextEmpty :: LHsType name -> Bool isFirstContextEmpty t = case unLoc t of HsForAllTy _ _ s -> isFirstContextEmpty s @@ -1178,10 +1194,16 @@ patSigContext typ | hasNonEmptyContext typ && isFirstContextEmpty typ = ShowEmp -- | Pretty-print a pattern signature (all this does over 'ppLType' is slot in -- the right 'HideEmptyContext' value) -ppPatSigType :: Unicode -> Qualification -> LHsType DocNameI -> Html +ppPatSigType :: Unicode -> Qualification -> LHsSigType DocNameI -> Html ppPatSigType unicode qual typ = - let emptyCtxts = patSigContext typ in ppLType unicode qual emptyCtxts typ + let emptyCtxts = patSigContext typ in ppLSigType unicode qual emptyCtxts typ +ppHsOuterTyVarBndrs :: RenderableBndrFlag flag + => Unicode -> Qualification -> HsOuterTyVarBndrs flag DocNameI -> Html +ppHsOuterTyVarBndrs unicode qual outer_bndrs = case outer_bndrs of + HsOuterImplicit{} -> noHtml + HsOuterExplicit{hso_bndrs = bndrs} -> + hsep (forallSymbol unicode : ppTyVars unicode qual bndrs) +++ dot ppForAllPart :: Unicode -> Qualification -> HsForAllTelescope DocNameI -> Html ppForAllPart unicode qual tele = case tele of @@ -1191,6 +1213,10 @@ ppForAllPart unicode qual tele = case tele of HsForAllInvis { hsf_invis_bndrs = bndrs } -> hsep (forallSymbol unicode : ppTyVars unicode qual bndrs) +++ dot +ppr_sig_ty :: HsSigType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html +ppr_sig_ty (HsSig { sig_bndrs = outer_bndrs, sig_body = ltype }) unicode qual emptyCtxts + = ppHsOuterTyVarBndrs unicode qual outer_bndrs <+> ppr_mono_lty ltype unicode qual emptyCtxts + ppr_mono_lty :: LHsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html ppr_mono_lty ty = ppr_mono_ty (unLoc ty) @@ -1236,7 +1262,7 @@ ppr_mono_ty (HsRecTy {}) _ _ _ = toHtml "{..}" -- Can now legally occur in ConDeclGADT, the output here is to provide a -- placeholder in the signature, which is followed by the field -- declarations. -ppr_mono_ty (XHsType (NHsCoreTy {})) _ _ _ = error "ppr_mono_ty HsCoreTy" +ppr_mono_ty (XHsType {}) _ _ _ = error "ppr_mono_ty HsCoreTy" ppr_mono_ty (HsExplicitListTy _ IsPromoted tys) u q _ = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys ppr_mono_ty (HsExplicitListTy _ NotPromoted tys) u q _ = brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys ppr_mono_ty (HsExplicitTupleTy _ tys) u q _ = promoQuote $ parenList $ map (ppLType u q HideEmptyContexts) tys @@ -1272,3 +1298,4 @@ ppr_mono_ty (HsTyLit _ n) _ _ _ = ppr_tylit n ppr_tylit :: HsTyLit -> Html ppr_tylit (HsNumTy _ n) = toHtml (show n) ppr_tylit (HsStrTy _ s) = toHtml (show s) +ppr_tylit (HsCharTy _ c) = toHtml (show c) |