From ad9cbad7312a64e6757c32bd9488c55ba4f2fec9 Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Wed, 23 Sep 2020 20:37:34 -0400 Subject: Adapt to HsOuterTyVarBndrs These changes accompany ghc/ghc!4107, which aims to be a fix for #16762. --- haddock-api/src/Haddock/Backends/Hoogle.hs | 61 ++++++++-------- haddock-api/src/Haddock/Backends/LaTeX.hs | 66 +++++++++++------ haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 94 ++++++++++++++++--------- haddock-api/src/Haddock/Convert.hs | 44 ++++++------ haddock-api/src/Haddock/GhcUtils.hs | 76 +++++++++++++------- haddock-api/src/Haddock/Interface/Create.hs | 17 ++--- haddock-api/src/Haddock/Interface/Rename.hs | 70 +++++++++--------- haddock-api/src/Haddock/Interface/Specialize.hs | 69 ++++++++++++------ haddock-api/src/Haddock/Syb.hs | 17 ++++- haddock-api/src/Haddock/Types.hs | 11 ++- haddock-api/src/Haddock/Utils.hs | 34 ++++++--- 11 files changed, 350 insertions(+), 209 deletions(-) (limited to 'haddock-api/src') diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 8939664d..44841bc5 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -71,27 +71,31 @@ ppModule dflags iface = --------------------------------------------------------------------- -- Utility functions -dropHsDocTy :: HsType (GhcPass p) -> HsType (GhcPass p) -dropHsDocTy = f +dropHsDocTy :: HsSigType (GhcPass p) -> HsSigType (GhcPass p) +dropHsDocTy = drop_sig_ty where - g (L src x) = L src (f x) - f (HsForAllTy x a e) = HsForAllTy x a (g e) - f (HsQualTy x a e) = HsQualTy x a (g e) - f (HsBangTy x a b) = HsBangTy x a (g b) - f (HsAppTy x a b) = HsAppTy x (g a) (g b) - f (HsAppKindTy x a b) = HsAppKindTy x (g a) (g b) - f (HsFunTy x w a b) = HsFunTy x w (g a) (g b) - f (HsListTy x a) = HsListTy x (g a) - f (HsTupleTy x a b) = HsTupleTy x a (map g b) - f (HsOpTy x a b c) = HsOpTy x (g a) b (g c) - f (HsParTy x a) = HsParTy x (g a) - f (HsKindSig x a b) = HsKindSig x (g a) b - f (HsDocTy _ a _) = f $ unL a - f x = x - -outHsType :: (OutputableBndrId p) - => DynFlags -> HsType (GhcPass p) -> String -outHsType dflags = out dflags . reparenType . dropHsDocTy + drop_sig_ty (HsSig x a b) = HsSig x a (drop_lty b) + drop_sig_ty x@XHsSigType{} = x + + drop_lty (L src x) = L src (drop_ty x) + + drop_ty (HsForAllTy x a e) = HsForAllTy x a (drop_lty e) + drop_ty (HsQualTy x a e) = HsQualTy x a (drop_lty e) + drop_ty (HsBangTy x a b) = HsBangTy x a (drop_lty b) + drop_ty (HsAppTy x a b) = HsAppTy x (drop_lty a) (drop_lty b) + drop_ty (HsAppKindTy x a b) = HsAppKindTy x (drop_lty a) (drop_lty b) + drop_ty (HsFunTy x w a b) = HsFunTy x w (drop_lty a) (drop_lty b) + drop_ty (HsListTy x a) = HsListTy x (drop_lty a) + drop_ty (HsTupleTy x a b) = HsTupleTy x a (map drop_lty b) + drop_ty (HsOpTy x a b c) = HsOpTy x (drop_lty a) b (drop_lty c) + drop_ty (HsParTy x a) = HsParTy x (drop_lty a) + drop_ty (HsKindSig x a b) = HsKindSig x (drop_lty a) b + drop_ty (HsDocTy _ a _) = drop_ty $ unL a + drop_ty x = x + +outHsSigType :: (OutputableBndrId p, NoGhcTcPass p ~ p) + => DynFlags -> HsSigType (GhcPass p) -> String +outHsSigType dflags = out dflags . reparenSigType . dropHsDocTy dropComment :: String -> String @@ -135,8 +139,8 @@ ppExport dflags ExportDecl { expItemDecl = L _ decl f (TyClD _ d@SynDecl{}) = ppSynonym dflags d f (TyClD _ d@ClassDecl{}) = ppClass dflags d subdocs f (TyClD _ (FamDecl _ d)) = ppFam dflags d - f (ForD _ (ForeignImport _ name typ _)) = [pp_sig dflags [name] (hsSigType typ)] - f (ForD _ (ForeignExport _ name typ _)) = [pp_sig dflags [name] (hsSigType typ)] + f (ForD _ (ForeignImport _ name typ _)) = [pp_sig dflags [name] typ] + f (ForD _ (ForeignExport _ name typ _)) = [pp_sig dflags [name] typ] f (SigD _ sig) = ppSig dflags sig f _ = [] @@ -145,8 +149,8 @@ ppExport _ _ = [] ppSigWithDoc :: DynFlags -> Sig GhcRn -> [(Name, DocForDecl Name)] -> [String] ppSigWithDoc dflags sig subdocs = case sig of - TypeSig _ names t -> concatMap (mkDocSig "" (hsSigWcType t)) names - PatSynSig _ names t -> concatMap (mkDocSig "pattern " (hsSigType t)) names + TypeSig _ names t -> concatMap (mkDocSig "" (dropWildCards t)) names + PatSynSig _ names t -> concatMap (mkDocSig "pattern " t) names _ -> [] where mkDocSig leader typ n = mkSubdoc dflags n subdocs @@ -155,9 +159,9 @@ ppSigWithDoc dflags sig subdocs = case sig of ppSig :: DynFlags -> Sig GhcRn -> [String] ppSig dflags x = ppSigWithDoc dflags x [] -pp_sig :: DynFlags -> [Located Name] -> LHsType GhcRn -> String +pp_sig :: DynFlags -> [Located Name] -> LHsSigType GhcRn -> String pp_sig dflags names (L _ typ) = - operator prettyNames ++ " :: " ++ outHsType dflags typ + operator prettyNames ++ " :: " ++ outHsSigType dflags typ where prettyNames = intercalate ", " $ map (out dflags) names @@ -250,7 +254,8 @@ ppCtor dflags dat subdocs con@ConDeclH98 { con_args = con_args' } funs = foldr1 (\x y -> reL $ HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) x y) apps = foldl1 (\x y -> reL $ HsAppTy noExtField x y) - typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unL $ funs flds) + typeSig nm flds = operator nm ++ " :: " ++ + outHsSigType dflags (unL $ mkEmptySigType $ funs flds) -- We print the constructors as comma-separated list. See GHC -- docs for con_names on why it is a list to begin with. @@ -269,7 +274,7 @@ ppCtor dflags _dat subdocs con@(ConDeclGADT { }) where f = [typeSig name (getGADTConTypeG con)] - typeSig nm ty = operator nm ++ " :: " ++ outHsType dflags (unL ty) + typeSig nm ty = operator nm ++ " :: " ++ outHsSigType dflags (unL ty) name = out dflags $ map unL $ getConNames con ppFixity :: DynFlags -> (Name, Fixity) -> [String] diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index d0528322..3a774ace 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -210,10 +210,10 @@ processExports (e : es) = processExport e $$ processExports es -isSimpleSig :: ExportItem DocNameI -> Maybe ([DocName], HsType DocNameI) +isSimpleSig :: ExportItem DocNameI -> Maybe ([DocName], HsSigType DocNameI) isSimpleSig ExportDecl { expItemDecl = L _ (SigD _ (TypeSig _ lnames t)) , expItemMbDoc = (Documentation Nothing Nothing, argDocs) } - | Map.null argDocs = Just (map unLoc lnames, unLoc (hsSigWcType t)) + | Map.null argDocs = Just (map unLoc lnames, unLoc (dropWildCards t)) isSimpleSig _ = Nothing @@ -296,7 +296,7 @@ ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of -- | Just _ <- tcdTyPats d -> ppTyInst False loc doc d unicode -- Family instances happen via FamInst now TyClD _ d@ClassDecl{} -> ppClassDecl instances doc subdocs d unicode - SigD _ (TypeSig _ lnames ty) -> ppFunSig (doc, fnArgsDoc) (map unLoc lnames) (hsSigWcType ty) unicode + SigD _ (TypeSig _ lnames ty) -> ppFunSig (doc, fnArgsDoc) (map unLoc lnames) (dropWildCards ty) unicode SigD _ (PatSynSig _ lnames ty) -> ppLPatSig (doc, fnArgsDoc) (map unLoc lnames) ty unicode ForD _ d -> ppFor (doc, fnArgsDoc) d unicode InstD _ _ -> empty @@ -308,7 +308,7 @@ ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of ppFor :: DocForDecl DocName -> ForeignDecl DocNameI -> Bool -> LaTeX ppFor doc (ForeignImport _ (L _ name) typ _) unicode = - ppFunSig doc [name] (hsSigTypeI typ) unicode + ppFunSig doc [name] typ unicode ppFor _ _ _ = error "ppFor error in Haddock.Backends.LaTeX" -- error "foreign declarations are currently not supported by --latex" @@ -343,9 +343,9 @@ ppFamDecl doc instances decl unicode = -- Individual equations of a closed type family ppFamDeclEqn :: TyFamInstEqn DocNameI -> LaTeX - 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 }) = hsep [ ppAppNameTypeArgs n ts unicode , equals , ppType unicode (unLoc rhs) @@ -396,7 +396,7 @@ ppTySyn :: DocForDecl DocName -> TyClDecl DocNameI -> Bool -> LaTeX ppTySyn doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars , tcdRhs = ltype }) unicode - = ppTypeOrFunSig (unLoc ltype) doc (full, hdr, char '=') unicode + = ppTypeOrFunSig (mkHsImplicitSigTypeI ltype) doc (full, hdr, char '=') unicode where hdr = hsep (keyword "type" : ppDocBinder name @@ -411,7 +411,7 @@ ppTySyn _ _ _ = error "declaration not supported by ppTySyn" ------------------------------------------------------------------------------- -ppFunSig :: DocForDecl DocName -> [DocName] -> LHsType DocNameI +ppFunSig :: DocForDecl DocName -> [DocName] -> LHsSigType DocNameI -> Bool -> LaTeX ppFunSig doc docnames (L _ typ) unicode = ppTypeOrFunSig typ doc @@ -437,12 +437,12 @@ ppLPatSig doc docnames ty unicode ) unicode where - typ = unLoc (hsSigTypeI ty) + typ = unLoc ty names = map getName docnames -- | Pretty-print a type, adding documentation to the whole type and its -- arguments as needed. -ppTypeOrFunSig :: HsType DocNameI +ppTypeOrFunSig :: HsSigType DocNameI -> DocForDecl DocName -- ^ documentation -> ( LaTeX -- first-line (no-argument docs only) , LaTeX -- first-line (argument docs only) @@ -462,13 +462,24 @@ ppTypeOrFunSig typ (doc, argDocs) (pref1, pref2, sep0) unicode -- to the arguments. The output is a list of (leader/seperator, argument and -- its doc) ppSubSigLike :: Bool -- ^ unicode - -> HsType DocNameI -- ^ type signature + -> HsSigType DocNameI -- ^ type signature -> FnArgsDoc DocName -- ^ docs to add -> [(DocName, DocForDecl DocName)] -- ^ all subdocs (useful when we have `HsRecTy`) -> LaTeX -- ^ seperator (beginning of first line) -> [(LaTeX, LaTeX)] -- ^ arguments (leader/sep, type) -ppSubSigLike unicode typ argDocs subdocs leader = do_args 0 leader typ +ppSubSigLike unicode typ argDocs subdocs leader = do_sig_args 0 leader typ where + do_sig_args :: Int -> LaTeX -> HsSigType DocNameI -> [(LaTeX, LaTeX)] + do_sig_args n leader (HsSig { sig_bndrs = outer_bndrs, sig_body = ltype }) = + case outer_bndrs of + HsOuterExplicit{hso_bndrs = bndrs} -> + [ ( decltt leader + , decltt (ppHsForAllTelescope (mkHsForAllInvisTeleI bndrs) unicode) + <+> ppLType unicode ltype + ) ] + HsOuterImplicit{} -> do_largs n leader ltype + + do_largs :: Int -> LaTeX -> LHsType DocNameI -> [(LaTeX, LaTeX)] do_largs n leader (L _ t) = do_args n leader t arg_doc n = rDoc . fmap _doc $ Map.lookup n argDocs @@ -505,12 +516,16 @@ ppSubSigLike unicode typ argDocs subdocs leader = do_args 0 leader typ gadtOpen = text "\\{" -ppTypeSig :: [Name] -> HsType DocNameI -> Bool -> LaTeX +ppTypeSig :: [Name] -> HsSigType DocNameI -> Bool -> LaTeX ppTypeSig nms ty unicode = hsep (punctuate comma $ map ppSymName nms) <+> dcolon unicode - <+> ppType unicode ty + <+> ppSigType unicode ty +ppHsOuterTyVarBndrs :: HsOuterTyVarBndrs flag DocNameI -> Bool -> LaTeX +ppHsOuterTyVarBndrs (HsOuterImplicit{}) _ = empty +ppHsOuterTyVarBndrs (HsOuterExplicit{hso_bndrs = bndrs}) unicode = + hsep (forallSymbol unicode : ppTyVars bndrs) <> dot ppHsForAllTelescope :: HsForAllTelescope DocNameI -> Bool -> LaTeX ppHsForAllTelescope tele unicode = case tele of @@ -617,7 +632,7 @@ ppClassDecl instances doc subdocs methodTable = text "\\haddockpremethods{}" <> emph (text "Methods") $$ - vcat [ ppFunSig doc names (hsSigWcType typ) unicode + vcat [ ppFunSig doc names (dropWildCards typ) unicode | L _ (TypeSig _ lnames typ) <- lsigs , let doc = lookupAnySubdoc (head names) subdocs names = map unLoc lnames ] @@ -793,7 +808,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = | otherwise -> hsep [ ppOcc , dcolon unicode -- ++AZ++ make this prepend "{..}" when it is a record style GADT - , ppLType unicode (getGADTConType con) + , ppLSigType unicode (getGADTConType con) ] fieldPart = case con of @@ -868,18 +883,16 @@ ppSideBySidePat lnames typ (doc, argDocs) unicode = | otherwise = hsep [ keyword "pattern" , ppOcc , dcolon unicode - , ppLType unicode (hsSigTypeI typ) + , ppLSigType unicode typ ] fieldPart | not hasArgDocs = empty | otherwise = vcat [ empty <-> text "\\qquad" <+> l <+> text "\\enspace" <+> r - | (l,r) <- ppSubSigLike unicode (unLoc patTy) argDocs [] (dcolon unicode) + | (l,r) <- ppSubSigLike unicode (unLoc typ) argDocs [] (dcolon unicode) ] - patTy = hsSigTypeI typ - mDoc = fmap _doc $ combineDocumentation doc @@ -1000,12 +1013,18 @@ ppLType unicode y = ppType unicode (unLoc y) ppLParendType unicode y = ppParendType unicode (unLoc y) ppLFunLhType unicode y = ppFunLhType unicode (unLoc y) +ppLSigType :: Bool -> LHsSigType DocNameI -> LaTeX +ppLSigType unicode y = ppSigType unicode (unLoc y) + ppType, ppParendType, ppFunLhType, ppCtxType :: Bool -> HsType DocNameI -> LaTeX ppType unicode ty = ppr_mono_ty (reparenTypePrec PREC_TOP ty) unicode ppParendType unicode ty = ppr_mono_ty (reparenTypePrec PREC_TOP ty) unicode ppFunLhType unicode ty = ppr_mono_ty (reparenTypePrec PREC_FUN ty) unicode ppCtxType unicode ty = ppr_mono_ty (reparenTypePrec PREC_CTX ty) unicode +ppSigType :: Bool -> HsSigType DocNameI -> LaTeX +ppSigType unicode sig_ty = ppr_sig_ty (reparenSigType sig_ty) unicode + ppLHsTypeArg :: Bool -> LHsTypeArg DocNameI -> LaTeX ppLHsTypeArg unicode (HsValArg ty) = ppLParendType unicode ty ppLHsTypeArg unicode (HsTypeArg _ ki) = atSign unicode <> @@ -1038,6 +1057,11 @@ ppKind unicode ki = ppr_mono_ty (reparenTypePrec PREC_TOP ki) unicode -- Drop top-level for-all type variables in user style -- since they are implicit in Haskell +ppr_sig_ty :: HsSigType DocNameI -> Bool -> LaTeX +ppr_sig_ty (HsSig { sig_bndrs = outer_bndrs, sig_body = ltype }) unicode + = sep [ ppHsOuterTyVarBndrs outer_bndrs unicode + , ppr_mono_lty ltype unicode ] + ppr_mono_lty :: LHsType DocNameI -> Bool -> LaTeX ppr_mono_lty ty unicode = ppr_mono_ty (unLoc ty) unicode diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index d80f8e95..8b9739f1 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -62,9 +62,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 @@ -72,25 +72,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 doc (map unLoc lnames) lty fixities splice unicode pkg qual ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> - [DocName] -> LHsType DocNameI -> [(DocName, Fixity)] -> + [DocName] -> LHsSigType DocNameI -> [(DocName, Fixity)] -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppFunSig summary links loc doc docnames typ fixities splice unicode pkg qual = ppSigLike summary links loc mempty 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 = @@ -101,7 +101,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 = @@ -118,7 +118,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 @@ -139,15 +139,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 <+> ppForAll (mkHsForAllInvisTeleI bndrs) unicode qual + 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] @@ -239,7 +248,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 doc [name] (hsSigTypeI typ) fixities splice unicode pkg qual + = ppFunSig summary links loc doc [name] typ fixities splice unicode pkg qual ppFor _ _ _ _ _ _ _ _ _ _ = error "ppFor" @@ -250,13 +259,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 @@ -276,13 +286,13 @@ ppTyName = ppName Prefix 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 @@ -322,9 +332,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 @@ -518,7 +528,7 @@ ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, t -- ToDo: add associated type defaults - [ ppFunSig summary links loc doc names (hsSigTypeI typ) + [ ppFunSig summary links loc doc names typ [] splice unicode pkg qual | L _ (ClassOpSig _ False lnames typ) <- sigs , let doc = lookupAnySubdoc (head names) subdocs @@ -568,7 +578,7 @@ ppClassDecl summary links instances fixities loc d subdocs doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs subfixs = [ f | f@(n',_) <- fixities, n == n' ] ] - methodBit = subMethods [ ppFunSig summary links loc doc [name] (hsSigTypeI typ) + methodBit = subMethods [ ppFunSig summary links loc doc [name] typ subfixs splice unicode pkg qual | L _ (ClassOpSig _ _ lnames typ) <- lsigs , name <- map unLoc lnames @@ -692,7 +702,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 @@ -755,7 +765,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 ] @@ -863,7 +873,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 ) @@ -933,7 +943,7 @@ 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 ] @@ -1037,18 +1047,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. @@ -1102,6 +1111,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 @@ -1110,6 +1122,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 <> @@ -1144,10 +1159,12 @@ 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 DocNameI -> 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 + typ = sig_body (unLoc sig_typ) + hasNonEmptyContext t = case unLoc t of HsForAllTy _ _ s -> hasNonEmptyContext s @@ -1164,9 +1181,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 @@ -1176,6 +1200,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) diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index c0347e56..2f342ba4 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -58,7 +58,7 @@ import GHC.Parser.Annotation (IsUnicodeSyntax(..)) import Haddock.Types import Haddock.Interface.Specialize import Haddock.GhcUtils ( orderedFVs, defaultRuntimeRepVars ) - +import Haddock.Utils ( mkEmptySigType ) import Data.Maybe ( catMaybes, mapMaybe, maybeToList ) @@ -104,15 +104,14 @@ tyThingToLHsDecl prr t = case t of extractFamDefDecl :: FamilyDecl GhcRn -> Type -> TyFamDefltDecl GhcRn extractFamDefDecl fd rhs = - TyFamInstDecl $ HsIB { hsib_ext = hsq_ext (fdTyVars fd) - , hsib_body = FamEqn + TyFamInstDecl $ FamEqn { feqn_ext = noExtField , feqn_tycon = fdLName fd - , feqn_bndrs = Nothing + , feqn_bndrs = HsOuterImplicit{hso_ximplicit = hsq_ext (fdTyVars fd)} , feqn_pats = map (HsValArg . hsLTyVarBndrToType) $ hsq_explicit $ fdTyVars fd , feqn_fixity = fdFixity fd - , feqn_rhs = synifyType WithinType [] rhs }} + , feqn_rhs = synifyType WithinType [] rhs } extractAtItem :: ClassATItem @@ -170,14 +169,14 @@ synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs }) annot_typats = zipWith3 annotHsType (mkIsPolyTvs fam_tvs) args_types_only typats hs_rhs = synifyType WithinType [] rhs - in HsIB { hsib_ext = map tyVarName tkvs - , hsib_body = FamEqn { feqn_ext = noExtField - , feqn_tycon = name - , feqn_bndrs = Nothing + outer_bndrs = HsOuterImplicit{hso_ximplicit = map tyVarName tkvs} -- TODO: this must change eventually - , feqn_pats = map HsValArg annot_typats - , feqn_fixity = synifyFixity name - , feqn_rhs = hs_rhs } } + in FamEqn { feqn_ext = noExtField + , feqn_tycon = name + , feqn_bndrs = outer_bndrs + , feqn_pats = map HsValArg annot_typats + , feqn_fixity = synifyFixity name + , feqn_rhs = hs_rhs } where fam_tvs = tyConVisibleTyVars tc @@ -371,6 +370,12 @@ synifyDataCon use_gadt_syntax dc = (_univ_tvs, ex_tvs, _eq_spec, theta, arg_tys, res_ty) = dataConFullSig dc user_tvbndrs = dataConUserTyVarBinders dc -- Used for GADT data constructors + outer_bndrs | null user_tvbndrs + = HsOuterImplicit { hso_ximplicit = [] } + | otherwise + = HsOuterExplicit { hso_xexplicit = noExtField + , hso_bndrs = map synifyTyVarBndr user_tvbndrs } + -- skip any EqTheta, use 'orig'inal syntax ctx | null theta = Nothing | otherwise = Just $ synifyCtx theta @@ -407,10 +412,9 @@ synifyDataCon use_gadt_syntax dc = then do let hat = mk_gadt_arg_tys return $ noLoc $ ConDeclGADT - { con_g_ext = [] + { con_g_ext = noExtField , con_names = [name] - , con_forall = noLoc $ not $ null user_tvbndrs - , con_qvars = map synifyTyVarBndr user_tvbndrs + , con_bndrs = noLoc outer_bndrs , con_mb_cxt = ctx , con_g_args = hat , con_res_ty = synifyType WithinType [] res_ty @@ -531,17 +535,17 @@ data SynifyTypeState synifySigType :: SynifyTypeState -> [TyVar] -> Type -> LHsSigType GhcRn --- The empty binders is a bit suspicious; --- what if the type has free variables? -synifySigType s vs ty = mkEmptyImplicitBndrs (synifyType s vs ty) +-- The use of mkEmptySigType (which uses empty binders in OuterImplicit) +-- is a bit suspicious; what if the type has free variables? +synifySigType s vs ty = mkEmptySigType (synifyType s vs ty) synifySigWcType :: SynifyTypeState -> [TyVar] -> Type -> LHsSigWcType GhcRn -- Ditto (see synifySigType) -synifySigWcType s vs ty = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs (synifyType s vs ty)) +synifySigWcType s vs ty = mkEmptyWildCardBndrs (mkEmptySigType (synifyType s vs ty)) synifyPatSynSigType :: PatSyn -> LHsSigType GhcRn -- Ditto (see synifySigType) -synifyPatSynSigType ps = mkEmptyImplicitBndrs (synifyPatSynType ps) +synifyPatSynSigType ps = mkEmptySigType (synifyPatSynType ps) -- | Depending on the first argument, try to default all type variables of kind -- 'RuntimeRep' to 'LiftedType'. diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index d6d12e4e..39d6d3fd 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -123,30 +123,28 @@ getConNamesI :: ConDecl DocNameI -> [Located DocName] getConNamesI ConDeclH98 {con_name = name} = [name] getConNamesI ConDeclGADT {con_names = names} = names -hsImplicitBodyI :: HsImplicitBndrs DocNameI thing -> thing -hsImplicitBodyI (HsIB { hsib_body = body }) = body - -hsSigTypeI :: LHsSigType DocNameI -> LHsType DocNameI -hsSigTypeI = hsImplicitBodyI - mkHsForAllInvisTeleI :: [LHsTyVarBndr Specificity DocNameI] -> HsForAllTelescope DocNameI mkHsForAllInvisTeleI invis_bndrs = HsForAllInvis { hsf_xinvis = noExtField, hsf_invis_bndrs = invis_bndrs } -getGADTConType :: ConDecl DocNameI -> LHsType DocNameI +mkHsImplicitSigTypeI :: LHsType DocNameI -> HsSigType DocNameI +mkHsImplicitSigTypeI body = + HsSig { sig_ext = noExtField + , sig_bndrs = HsOuterImplicit{hso_ximplicit = noExtField} + , sig_body = body } + +getGADTConType :: ConDecl DocNameI -> LHsSigType DocNameI -- The full type of a GADT data constructor We really only get this in -- order to pretty-print it, and currently only in Haddock's code. So -- we are cavalier about locations and extensions, hence the -- 'undefined's -getGADTConType (ConDeclGADT { con_forall = L _ has_forall - , con_qvars = qtvs +getGADTConType (ConDeclGADT { con_bndrs = L _ outer_bndrs , con_mb_cxt = mcxt, con_g_args = args , con_res_ty = res_ty }) - | has_forall = noLoc (HsForAllTy { hst_xforall = noExtField - , hst_tele = mkHsForAllInvisTeleI qtvs - , hst_body = theta_ty }) - | otherwise = theta_ty + = noLoc (HsSig { sig_ext = noExtField + , sig_bndrs = outer_bndrs + , sig_body = theta_ty }) where theta_ty | Just theta <- mcxt = noLoc (HsQualTy { hst_xqual = noExtField, hst_ctxt = theta, hst_body = tau_ty }) @@ -188,19 +186,17 @@ tcdNameI = unLoc . tyClDeclLNameI -- ------------------------------------- -getGADTConTypeG :: ConDecl GhcRn -> LHsType GhcRn +getGADTConTypeG :: ConDecl GhcRn -> LHsSigType GhcRn -- The full type of a GADT data constructor We really only get this in -- order to pretty-print it, and currently only in Haddock's code. So -- we are cavalier about locations and extensions, hence the -- 'undefined's -getGADTConTypeG (ConDeclGADT { con_forall = L _ has_forall - , con_qvars = qtvs +getGADTConTypeG (ConDeclGADT { con_bndrs = L _ outer_bndrs , con_mb_cxt = mcxt, con_g_args = args , con_res_ty = res_ty }) - | has_forall = noLoc (HsForAllTy { hst_xforall = noExtField - , hst_tele = mkHsForAllInvisTele qtvs - , hst_body = theta_ty }) - | otherwise = theta_ty + = noLoc (HsSig { sig_ext = noExtField + , sig_bndrs = outer_bndrs + , sig_body = theta_ty }) where theta_ty | Just theta <- mcxt = noLoc (HsQualTy { hst_xqual = noExtField, hst_ctxt = theta, hst_body = tau_ty }) @@ -244,7 +240,9 @@ data Precedence -- -- We cannot add parens that may be required by fixities because we do not have -- any fixity information to work with in the first place :(. -reparenTypePrec :: forall a. (XParTy a ~ NoExtField, MapXRec a, UnXRec a, WrapXRec a) => Precedence -> HsType a -> HsType a +reparenTypePrec :: forall a. ( XParTy a ~ NoExtField, NoGhcTc a ~ a + , MapXRec a, UnXRec a, WrapXRec a ) + => Precedence -> HsType a -> HsType a reparenTypePrec = go where @@ -294,15 +292,37 @@ reparenTypePrec = go -- | Add parenthesis around the types in a 'HsType' (see 'reparenTypePrec') -reparenType :: (XParTy a ~ NoExtField, MapXRec a, UnXRec a, WrapXRec a) => HsType a -> HsType a +reparenType :: ( XParTy a ~ NoExtField, NoGhcTc a ~ a + , MapXRec a, UnXRec a, WrapXRec a ) + => HsType a -> HsType a reparenType = reparenTypePrec PREC_TOP -- | Add parenthesis around the types in a 'LHsType' (see 'reparenTypePrec') -reparenLType :: forall a. (XParTy a ~ NoExtField, MapXRec a, UnXRec a, WrapXRec a) => LHsType a -> LHsType a +reparenLType :: forall a. ( XParTy a ~ NoExtField, NoGhcTc a ~ a + , MapXRec a, UnXRec a, WrapXRec a ) + => LHsType a -> LHsType a reparenLType = mapXRec @a reparenType +-- | Add parentheses around the types in an 'HsSigType' (see 'reparenTypePrec') +reparenSigType :: forall a. ( XParTy a ~ NoExtField, NoGhcTc a ~ a + , MapXRec a, UnXRec a, WrapXRec a ) + => HsSigType a -> HsSigType a +reparenSigType (HsSig x bndrs body) = + HsSig x (reparenOuterTyVarBndrs bndrs) (reparenLType body) +reparenSigType v@XHsSigType{} = v + +-- | Add parentheses around the types in an 'HsOuterTyVarBndrs' (see 'reparenTypePrec') +reparenOuterTyVarBndrs :: forall flag a. ( XParTy a ~ NoExtField, NoGhcTc a ~ a + , MapXRec a, UnXRec a, WrapXRec a ) + => HsOuterTyVarBndrs flag a -> HsOuterTyVarBndrs flag a +reparenOuterTyVarBndrs imp@HsOuterImplicit{} = imp +reparenOuterTyVarBndrs (HsOuterExplicit x exp_bndrs) = + HsOuterExplicit x (map (mapXRec @(NoGhcTc a) reparenTyVar) exp_bndrs) +reparenOuterTyVarBndrs v@XHsOuterTyVarBndrs{} = v + -- | Add parentheses around the types in an 'HsForAllTelescope' (see 'reparenTypePrec') -reparenHsForAllTelescope :: forall a. (XParTy a ~ NoExtField, MapXRec a, UnXRec a, WrapXRec a) +reparenHsForAllTelescope :: forall a. ( XParTy a ~ NoExtField, NoGhcTc a ~ a + , MapXRec a, UnXRec a, WrapXRec a ) => HsForAllTelescope a -> HsForAllTelescope a reparenHsForAllTelescope (HsForAllVis x bndrs) = HsForAllVis x (map (mapXRec @a reparenTyVar) bndrs) @@ -311,13 +331,17 @@ reparenHsForAllTelescope (HsForAllInvis x bndrs) = reparenHsForAllTelescope v@XHsForAllTelescope{} = v -- | Add parenthesis around the types in a 'HsTyVarBndr' (see 'reparenTypePrec') -reparenTyVar :: (XParTy a ~ NoExtField, MapXRec a, UnXRec a, WrapXRec a) => HsTyVarBndr flag a -> HsTyVarBndr flag a +reparenTyVar :: ( XParTy a ~ NoExtField, NoGhcTc a ~ a + , MapXRec a, UnXRec a, WrapXRec a ) + => HsTyVarBndr flag a -> HsTyVarBndr flag a reparenTyVar (UserTyVar x flag n) = UserTyVar x flag n reparenTyVar (KindedTyVar x flag n kind) = KindedTyVar x flag n (reparenLType kind) reparenTyVar v@XTyVarBndr{} = v -- | Add parenthesis around the types in a 'ConDeclField' (see 'reparenTypePrec') -reparenConDeclField :: (XParTy a ~ NoExtField, MapXRec a, UnXRec a, WrapXRec a) => ConDeclField a -> ConDeclField a +reparenConDeclField :: ( XParTy a ~ NoExtField, NoGhcTc a ~ a + , MapXRec a, UnXRec a, WrapXRec a ) + => ConDeclField a -> ConDeclField a reparenConDeclField (ConDeclField x n t d) = ConDeclField x n (reparenLType t) d reparenConDeclField c@XConDeclField{} = c diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index ecaf1a5d..a0e56f07 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -422,7 +422,7 @@ mkMaps dflags pkgName gre instances decls = do -- The CoAx's loc is the whole line, but only for TFs. The -- workaround is to dig into the family instance declaration and -- get the identifier with the right location. - TyFamInstD _ (TyFamInstDecl d') -> getLoc (feqn_tycon (hsib_body d')) + TyFamInstD _ (TyFamInstDecl d') -> getLoc (feqn_tycon d') _ -> getInstLoc d names l (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See note [2]. names _ decl = getMainDeclBinder decl @@ -904,26 +904,23 @@ extractDecl declMap name decl | isValName name , Just (famInst:_) <- M.lookup name declMap -> extractDecl declMap name famInst - InstD _ (DataFamInstD _ (DataFamInstDecl (HsIB { hsib_body = - FamEqn { feqn_tycon = L _ n + InstD _ (DataFamInstD _ (DataFamInstDecl + (FamEqn { feqn_tycon = L _ n , feqn_pats = tys - , feqn_rhs = defn }}))) -> + , feqn_rhs = defn }))) -> if isDataConName name then SigD noExtField <$> extractPatternSyn name n tys (dd_cons defn) else SigD noExtField <$> extractRecSel name n tys (dd_cons defn) InstD _ (ClsInstD _ ClsInstDecl { cid_datafam_insts = insts }) | isDataConName name -> - let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body = - FamEqn { feqn_rhs = dd - } - })) <- insts + let matches = [ d' | L _ d'@(DataFamInstDecl (FamEqn { feqn_rhs = dd })) <- insts , name `elem` map unLoc (concatMap (getConNames . unLoc) (dd_cons dd)) ] in case matches of [d0] -> extractDecl declMap name (noLoc (InstD noExtField (DataFamInstD noExtField d0))) _ -> error "internal: extractDecl (ClsInstD)" | otherwise -> - let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body = d })) + let matches = [ d' | L _ d'@(DataFamInstDecl d) <- insts -- , L _ ConDecl { con_details = RecCon rec } <- dd_cons (feqn_rhs d) , Just rec <- map (getRecConArgs_maybe . unLoc) (dd_cons (feqn_rhs d)) @@ -963,7 +960,7 @@ extractPatternSyn nm t tvs cons = ConDeclH98 { con_mb_cxt = Just cxt } -> noLoc (HsQualTy noExtField cxt typ) _ -> typ typ'' = noLoc (HsQualTy noExtField (noLoc []) typ') - in PatSynSig noExtField [noLoc nm] (mkEmptyImplicitBndrs typ'') + in PatSynSig noExtField [noLoc nm] (mkEmptySigType typ'') longArrow :: [LHsType GhcRn] -> LHsType GhcRn -> LHsType GhcRn longArrow inputs output = foldr (\x y -> noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) x y)) output inputs diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index e7d19dfe..a1e712e0 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -191,10 +191,10 @@ renameLTypeArg (HsTypeArg l ki) = do { ki' <- renameLKind ki renameLTypeArg (HsArgPar sp) = return $ HsArgPar sp renameLSigType :: LHsSigType GhcRn -> RnM (LHsSigType DocNameI) -renameLSigType = renameImplicit renameLType +renameLSigType = mapM renameSigType renameLSigWcType :: LHsSigWcType GhcRn -> RnM (LHsSigWcType DocNameI) -renameLSigWcType = renameWc (renameImplicit renameLType) +renameLSigWcType = renameWc renameLSigType renameLKind :: LHsKind GhcRn -> RnM (LHsKind DocNameI) renameLKind = renameLType @@ -294,6 +294,12 @@ renameType t = case t of HsSpliceTy _ s -> renameHsSpliceTy s HsWildCardTy a -> pure (HsWildCardTy a) +renameSigType :: HsSigType GhcRn -> RnM (HsSigType DocNameI) +renameSigType (HsSig { sig_bndrs = bndrs, sig_body = body }) = do + bndrs' <- renameOuterTyVarBndrs bndrs + body' <- renameLType body + pure $ HsSig { sig_ext = noExtField, sig_bndrs = bndrs', sig_body = body' } + -- | Rename splices, but _only_ those that turn out to be for types. -- I think this is actually safe for our possible inputs: -- @@ -486,21 +492,20 @@ renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars , con_forall = forall -- Remove when #18311 is fixed , con_args = details', con_doc = mbldoc' }) -renameCon ConDeclGADT { con_names = lnames, con_qvars = ltyvars +renameCon ConDeclGADT { con_names = lnames, con_bndrs = bndrs , con_mb_cxt = lcontext, con_g_args = details - , con_res_ty = res_ty, con_forall = forall + , con_res_ty = res_ty , con_doc = mbldoc } = do lnames' <- mapM renameL lnames - ltyvars' <- mapM renameLTyVarBndr ltyvars + bndrs' <- mapM renameOuterTyVarBndrs bndrs lcontext' <- traverse renameLContext lcontext details' <- renameGADTDetails details res_ty' <- renameLType res_ty mbldoc' <- mapM renameLDocHsSyn mbldoc return (ConDeclGADT - { con_g_ext = noExtField, con_names = lnames', con_qvars = ltyvars' + { con_g_ext = noExtField, con_names = lnames', con_bndrs = bndrs' , con_mb_cxt = lcontext', con_g_args = details' - , con_res_ty = res_ty', con_doc = mbldoc' - , con_forall = forall}) -- Remove when #18311 is fixed + , con_res_ty = res_ty', con_doc = mbldoc' }) renameHsScaled :: HsScaled GhcRn (LHsType GhcRn) -> RnM (HsScaled DocNameI (LHsType DocNameI)) @@ -618,32 +623,26 @@ renameTyFamInstD (TyFamInstDecl { tfid_eqn = eqn }) ; return (TyFamInstDecl { tfid_eqn = eqn' }) } renameTyFamInstEqn :: TyFamInstEqn GhcRn -> RnM (TyFamInstEqn DocNameI) -renameTyFamInstEqn eqn - = renameImplicit rename_ty_fam_eqn eqn - where - rename_ty_fam_eqn - :: FamEqn GhcRn (LHsType GhcRn) - -> RnM (FamEqn DocNameI (LHsType DocNameI)) - rename_ty_fam_eqn (FamEqn { feqn_tycon = tc, feqn_bndrs = bndrs - , feqn_pats = pats, feqn_fixity = fixity - , feqn_rhs = rhs }) - = do { tc' <- renameL tc - ; bndrs' <- traverse (mapM renameLTyVarBndr) bndrs - ; pats' <- mapM renameLTypeArg pats - ; rhs' <- renameLType rhs - ; return (FamEqn { feqn_ext = noExtField - , feqn_tycon = tc' - , feqn_bndrs = bndrs' - , feqn_pats = pats' - , feqn_fixity = fixity - , feqn_rhs = rhs' }) } +renameTyFamInstEqn (FamEqn { feqn_tycon = tc, feqn_bndrs = bndrs + , feqn_pats = pats, feqn_fixity = fixity + , feqn_rhs = rhs }) + = do { tc' <- renameL tc + ; bndrs' <- renameOuterTyVarBndrs bndrs + ; pats' <- mapM renameLTypeArg pats + ; rhs' <- renameLType rhs + ; return (FamEqn { feqn_ext = noExtField + , feqn_tycon = tc' + , feqn_bndrs = bndrs' + , feqn_pats = pats' + , feqn_fixity = fixity + , feqn_rhs = rhs' }) } renameTyFamDefltD :: TyFamDefltDecl GhcRn -> RnM (TyFamDefltDecl DocNameI) renameTyFamDefltD = renameTyFamInstD renameDataFamInstD :: DataFamInstDecl GhcRn -> RnM (DataFamInstDecl DocNameI) renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn }) - = do { eqn' <- renameImplicit rename_data_fam_eqn eqn + = do { eqn' <- rename_data_fam_eqn eqn ; return (DataFamInstDecl { dfid_eqn = eqn' }) } where rename_data_fam_eqn @@ -653,7 +652,7 @@ renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn }) , feqn_pats = pats, feqn_fixity = fixity , feqn_rhs = defn }) = do { tc' <- renameL tc - ; bndrs' <- traverse (mapM renameLTyVarBndr) bndrs + ; bndrs' <- renameOuterTyVarBndrs bndrs ; pats' <- mapM renameLTypeArg pats ; defn' <- renameDataDefn defn ; return (FamEqn { feqn_ext = noExtField @@ -663,13 +662,12 @@ renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn }) , feqn_fixity = fixity , feqn_rhs = defn' }) } -renameImplicit :: (in_thing -> RnM out_thing) - -> HsImplicitBndrs GhcRn in_thing - -> RnM (HsImplicitBndrs DocNameI out_thing) -renameImplicit rn_thing (HsIB { hsib_body = thing }) - = do { thing' <- rn_thing thing - ; return (HsIB { hsib_body = thing' - , hsib_ext = noExtField }) } +renameOuterTyVarBndrs :: HsOuterTyVarBndrs flag GhcRn + -> RnM (HsOuterTyVarBndrs flag DocNameI) +renameOuterTyVarBndrs (HsOuterImplicit{}) = + pure $ HsOuterImplicit{hso_ximplicit = noExtField} +renameOuterTyVarBndrs (HsOuterExplicit{hso_bndrs = exp_bndrs}) = + HsOuterExplicit noExtField <$> mapM renameLTyVarBndr exp_bndrs renameWc :: (in_thing -> RnM out_thing) -> HsWildCardBndrs GhcRn in_thing diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index 35e5258f..b19f52d0 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -56,7 +56,7 @@ specialize specs = go spec_map0 -- -- Again, it is just a convenience function around 'specialize'. Note that -- length of type list should be the same as the number of binders. -specializeTyVarBndrs :: LHsQTyVars GhcRn -> [HsType GhcRn] -> HsType GhcRn -> HsType GhcRn +specializeTyVarBndrs :: Data a => LHsQTyVars GhcRn -> [HsType GhcRn] -> a -> a specializeTyVarBndrs bndrs typs = specialize $ zip bndrs' typs where @@ -77,13 +77,13 @@ specializeSig :: LHsQTyVars GhcRn -> [HsType GhcRn] -> Sig GhcRn -> Sig GhcRn specializeSig bndrs typs (TypeSig _ lnames typ) = - TypeSig noExtField lnames (typ {hswc_body = (hswc_body typ) {hsib_body = noLoc typ'}}) + TypeSig noExtField lnames (typ {hswc_body = noLoc typ'}) where - true_type :: HsType GhcRn - true_type = unLoc (hsSigWcType typ) - typ' :: HsType GhcRn + true_type :: HsSigType GhcRn + true_type = unLoc (dropWildCards typ) + typ' :: HsSigType GhcRn typ' = rename fv $ specializeTyVarBndrs bndrs typs true_type - fv = foldr Set.union Set.empty . map freeVariables $ typs + fv = foldr Set.union Set.empty . map freeVariablesType $ typs specializeSig _ _ sig = sig @@ -207,25 +207,37 @@ setInternalOccName occ name = nname' = mkInternalName (nameUnique nname) occ (nameSrcSpan nname) --- | Compute set of free variables of given type. -freeVariables :: HsType GhcRn -> Set Name -freeVariables = - everythingWithState Set.empty Set.union query +-- | Compute set of free variables of a given 'HsType'. +freeVariablesType :: HsType GhcRn -> Set Name +freeVariablesType = + everythingWithState Set.empty Set.union + (mkQ (\ctx -> (Set.empty, ctx)) queryType) + +-- | Compute set of free variables of a given 'HsType'. +freeVariablesSigType :: HsSigType GhcRn -> Set Name +freeVariablesSigType = + everythingWithState Set.empty Set.union + (mkQ (\ctx -> (Set.empty, ctx)) queryType `extQ` querySigType) + +queryType :: HsType GhcRn -> Set Name -> (Set Name, Set Name) +queryType term ctx = case term of + HsForAllTy _ tele _ -> + (Set.empty, Set.union ctx (teleNames tele)) + HsTyVar _ _ (L _ name) + | getName name `Set.member` ctx -> (Set.empty, ctx) + | otherwise -> (Set.singleton $ getName name, ctx) + _ -> (Set.empty, ctx) where - query :: forall a . Data a => a -> Set Name -> (Set Name, Set Name) - query term ctx = case cast term :: Maybe (HsType GhcRn) of - Just (HsForAllTy _ tele _) -> - (Set.empty, Set.union ctx (teleNames tele)) - Just (HsTyVar _ _ (L _ name)) - | getName name `Set.member` ctx -> (Set.empty, ctx) - | otherwise -> (Set.singleton $ getName name, ctx) - _ -> (Set.empty, ctx) - teleNames :: HsForAllTelescope GhcRn -> Set Name teleNames (HsForAllVis _ bndrs) = bndrsNames bndrs teleNames (HsForAllInvis _ bndrs) = bndrsNames bndrs - bndrsNames = Set.fromList . map (getName . tyVarName . unLoc) +querySigType :: HsSigType GhcRn -> Set Name -> (Set Name, Set Name) +querySigType (HsSig { sig_bndrs = outer_bndrs }) ctx = + (Set.empty, Set.union ctx (bndrsNames (hsOuterExplicitBndrs outer_bndrs))) + +bndrsNames :: [LHsTyVarBndr flag GhcRn] -> Set Name +bndrsNames = Set.fromList . map (getName . tyVarName . unLoc) -- | Make given type visually unambiguous. @@ -236,12 +248,12 @@ freeVariables = -- different type variable than latter one. Applying 'rename' function -- will fix that type to be visually unambiguous again (making it something -- like @(a -> b0) -> b@). -rename :: Set Name -> HsType GhcRn -> HsType GhcRn -rename fv typ = evalState (renameType typ) env +rename :: Set Name -> HsSigType GhcRn -> HsSigType GhcRn +rename fv typ = evalState (renameSigType typ) env where env = RenameEnv { rneHeadFVs = Map.fromList . map mkPair . Set.toList $ fv - , rneSigFVs = Set.map getNameRep $ freeVariables typ + , rneSigFVs = Set.map getNameRep $ freeVariablesSigType typ , rneCtx = Map.empty } mkPair name = (getNameRep name, name) @@ -256,6 +268,17 @@ data RenameEnv name = RenameEnv } +renameSigType :: HsSigType GhcRn -> Rename (IdP GhcRn) (HsSigType GhcRn) +renameSigType (HsSig x bndrs body) = + HsSig x <$> renameOuterTyVarBndrs bndrs <*> renameLType body + +renameOuterTyVarBndrs :: HsOuterTyVarBndrs flag GhcRn + -> Rename (IdP GhcRn) (HsOuterTyVarBndrs flag GhcRn) +renameOuterTyVarBndrs (HsOuterImplicit imp_tvs) = + HsOuterImplicit <$> mapM renameName imp_tvs +renameOuterTyVarBndrs (HsOuterExplicit x exp_bndrs) = + HsOuterExplicit x <$> mapM renameLBinder exp_bndrs + renameType :: HsType GhcRn -> Rename (IdP GhcRn) (HsType GhcRn) renameType (HsForAllTy x tele lt) = HsForAllTy x diff --git a/haddock-api/src/Haddock/Syb.hs b/haddock-api/src/Haddock/Syb.hs index 7e34ae8c..fc946c8e 100644 --- a/haddock-api/src/Haddock/Syb.hs +++ b/haddock-api/src/Haddock/Syb.hs @@ -6,7 +6,7 @@ module Haddock.Syb ( everything, everythingButType, everythingWithState , everywhere, everywhereButType - , mkT + , mkT, mkQ, extQ , combine ) where @@ -91,6 +91,21 @@ mkT f = case cast f of Just f' -> f' Nothing -> id +-- | Create generic query. +-- +-- Another function stolen from SYB package. +mkQ :: (Typeable a, Typeable b) => r -> (b -> r) -> a -> r +(r `mkQ` br) a = case cast a of + Just b -> br b + Nothing -> r + + +-- | Extend a generic query by a type-specific case. +-- +-- Another function stolen from SYB package. +extQ :: (Typeable a, Typeable b) => (a -> q) -> (b -> q) -> a -> q +extQ f g a = maybe (f a) g (cast a) + -- | Combine two queries into one using alternative combinator. combine :: Alternative f => (forall a. Data a => a -> f r) -> (forall a. Data a => a -> f r) diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 6aad5dd1..7b261f4e 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -755,9 +755,14 @@ type instance XFamDecl DocNameI = NoExtField type instance XXFamilyDecl DocNameI = NoExtCon type instance XXTyClDecl DocNameI = NoExtCon -type instance XHsIB DocNameI _ = NoExtField -type instance XHsWC DocNameI _ = NoExtField -type instance XXHsImplicitBndrs DocNameI _ = NoExtCon +type instance XHsWC DocNameI _ = NoExtField + +type instance XHsOuterExplicit DocNameI _ = NoExtField +type instance XHsOuterImplicit DocNameI = NoExtField +type instance XXHsOuterTyVarBndrs DocNameI = NoExtCon + +type instance XHsSig DocNameI = NoExtField +type instance XXHsSigType DocNameI = NoExtCon type instance XHsQTvs DocNameI = NoExtField type instance XConDeclField DocNameI = NoExtField diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 1177fb18..aec7f9ab 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -17,7 +17,8 @@ module Haddock.Utils ( -- * Misc utilities restrictTo, emptyHsQTvs, toDescription, toInstalledDescription, - mkEmptySigWcType, addClassContext, lHsQTyVarsToTypes, + mkEmptySigWcType, mkEmptySigType, + addClassContext, lHsQTyVarsToTypes, -- * Filename utilities moduleHtmlFile, moduleHtmlFile', @@ -131,21 +132,38 @@ mkMeta x = emptyMetaDoc { _doc = x } mkEmptySigWcType :: LHsType GhcRn -> LHsSigWcType GhcRn -- Dubious, because the implicit binders are empty even -- though the type might have free varaiables -mkEmptySigWcType ty = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs ty) +mkEmptySigWcType ty = mkEmptyWildCardBndrs (mkEmptySigType ty) + +mkEmptySigType :: LHsType GhcRn -> LHsSigType GhcRn +-- Dubious, because the implicit binders are empty even +-- though the type might have free varaiables +mkEmptySigType lty@(L loc ty) = L loc $ case ty of + HsForAllTy { hst_tele = HsForAllInvis { hsf_invis_bndrs = bndrs } + , hst_body = body } + -> HsSig { sig_ext = noExtField + , sig_bndrs = HsOuterExplicit { hso_xexplicit = noExtField + , hso_bndrs = bndrs } + , sig_body = body } + _ -> HsSig { sig_ext = noExtField + , sig_bndrs = HsOuterImplicit{hso_ximplicit = []} + , sig_body = lty } addClassContext :: Name -> LHsQTyVars GhcRn -> LSig GhcRn -> LSig GhcRn -- Add the class context to a class-op signature addClassContext cls tvs0 (L pos (ClassOpSig _ _ lname ltype)) - = L pos (TypeSig noExtField lname (mkEmptySigWcType (go (hsSigType ltype)))) - -- The mkEmptySigWcType is suspicious + = L pos (TypeSig noExtField lname (mkEmptyWildCardBndrs (go_sig_ty ltype))) where - go (L loc (HsForAllTy { hst_tele = tele, hst_body = ty })) + go_sig_ty (L loc (HsSig { sig_bndrs = bndrs, sig_body = ty })) + = L loc (HsSig { sig_ext = noExtField + , sig_bndrs = bndrs, sig_body = go_ty ty }) + + go_ty (L loc (HsForAllTy { hst_tele = tele, hst_body = ty })) = L loc (HsForAllTy { hst_xforall = noExtField - , hst_tele = tele, hst_body = go ty }) - go (L loc (HsQualTy { hst_ctxt = ctxt, hst_body = ty })) + , hst_tele = tele, hst_body = go_ty ty }) + go_ty (L loc (HsQualTy { hst_ctxt = ctxt, hst_body = ty })) = L loc (HsQualTy { hst_xqual = noExtField , hst_ctxt = add_ctxt ctxt, hst_body = ty }) - go (L loc ty) + go_ty (L loc ty) = L loc (HsQualTy { hst_xqual = noExtField , hst_ctxt = add_ctxt (L loc []), hst_body = L loc ty }) -- cgit v1.2.3