From a1cc87c864242377833ab383f1df72583ab4a01d Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Mon, 25 May 2020 17:44:36 -0400 Subject: Use HsForAllTelescope (GHC#18235) --- haddock-api/src/Haddock/Backends/Hoogle.hs | 2 +- haddock-api/src/Haddock/Backends/LaTeX.hs | 24 ++-- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 60 +++++----- haddock-api/src/Haddock/Convert.hs | 139 ++++++++++++++++-------- haddock-api/src/Haddock/GhcUtils.hs | 32 ++++-- haddock-api/src/Haddock/Interface/Create.hs | 2 +- haddock-api/src/Haddock/Interface/Rename.hs | 17 ++- haddock-api/src/Haddock/Interface/Specialize.hs | 24 +++- haddock-api/src/Haddock/Types.hs | 4 + haddock-api/src/Haddock/Utils.hs | 6 +- 10 files changed, 198 insertions(+), 112 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 e03611b2..27a7d804 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -71,7 +71,7 @@ dropHsDocTy :: HsType a -> HsType a dropHsDocTy = f where g (L src x) = L src (f x) - f (HsForAllTy x fvf a e) = HsForAllTy x fvf a (g e) + 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) diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index b49fc74e..0c323ae5 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -474,10 +474,9 @@ ppSubSigLike unicode typ argDocs subdocs leader = do_args 0 leader typ arg_doc n = rDoc . fmap _doc $ Map.lookup n argDocs do_args :: Int -> LaTeX -> HsType DocNameI -> [(LaTeX, LaTeX)] - do_args _n leader (HsForAllTy _ fvf tvs ltype) + do_args _n leader (HsForAllTy _ tele ltype) = [ ( decltt leader - , decltt (hsep (forallSymbol unicode : ppTyVars tvs ++ - [ppForAllSeparator unicode fvf])) + , decltt (ppHsForAllTelescope tele unicode) <+> ppLType unicode ltype ) ] do_args n leader (HsQualTy _ lctxt ltype) @@ -506,12 +505,6 @@ ppSubSigLike unicode typ argDocs subdocs leader = do_args 0 leader typ gadtOpen = text "\\{" -ppForAllSeparator :: Bool -> ForallVisFlag -> LaTeX -ppForAllSeparator unicode fvf = - case fvf of - ForallVis -> text "\\ " <> arrow unicode - ForallInvis -> dot - ppTypeSig :: [Name] -> HsType DocNameI -> Bool -> LaTeX ppTypeSig nms ty unicode = hsep (punctuate comma $ map ppSymName nms) @@ -519,6 +512,14 @@ ppTypeSig nms ty unicode = <+> ppType unicode ty +ppHsForAllTelescope :: HsForAllTelescope DocNameI -> Bool -> LaTeX +ppHsForAllTelescope tele unicode = case tele of + HsForAllVis { hsf_vis_bndrs = bndrs } -> + hsep (forallSymbol unicode : ppTyVars bndrs) <> text "\\" <> arrow unicode + HsForAllInvis { hsf_invis_bndrs = bndrs } -> + hsep (forallSymbol unicode : ppTyVars bndrs) <> dot + + ppTyVars :: [LHsTyVarBndr flag DocNameI] -> [LaTeX] ppTyVars = map (ppSymName . getName . hsLTyVarNameI) @@ -1040,9 +1041,8 @@ ppr_mono_lty ty unicode = ppr_mono_ty (unLoc ty) unicode ppr_mono_ty :: HsType DocNameI -> Bool -> LaTeX -ppr_mono_ty (HsForAllTy _ fvf tvs ty) unicode - = sep [ hsep (forallSymbol unicode : ppTyVars tvs) <> - ppForAllSeparator unicode fvf +ppr_mono_ty (HsForAllTy _ tele ty) unicode + = sep [ ppHsForAllTelescope tele unicode , ppr_mono_lty ty unicode ] ppr_mono_ty (HsQualTy _ ctxt ty) unicode = sep [ ppLContext ctxt unicode diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 36bc04c3..5163fb6b 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -151,10 +151,10 @@ ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_args 0 sep typ do_largs n leader (L _ t) = do_args n leader t do_args :: Int -> Html -> HsType DocNameI -> [SubDecl] - do_args n leader (HsForAllTy _ fvf tvs ltype) + do_args n leader (HsForAllTy _ tele ltype) = do_largs n leader' ltype where - leader' = leader <+> ppForAll tvs unicode qual fvf + leader' = leader <+> ppForAll tele unicode qual do_args n leader (HsQualTy _ lctxt ltype) | null (unLoc lctxt) @@ -189,20 +189,22 @@ ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_args 0 sep typ -ppForAll :: [LHsTyVarBndr flag DocNameI] -> Unicode -> Qualification -> ForallVisFlag +ppForAll :: HsForAllTelescope DocNameI -> Unicode -> Qualification -> Html -ppForAll tvs unicode qual fvf = - case [ppKTv n k | L _ (KindedTyVar _ _ (L _ n) k) <- tvs] of - [] -> noHtml - ts -> forallSymbol unicode <+> hsep ts +++ ppForAllSeparator unicode fvf - where ppKTv n k = parens $ - ppTyName (getName n) <+> dcolon unicode <+> ppLKind unicode qual k - -ppForAllSeparator :: Unicode -> ForallVisFlag -> Html -ppForAllSeparator unicode fvf = - case fvf of - ForallVis -> spaceHtml +++ arrow unicode - ForallInvis -> dot +ppForAll tele unicode qual = case tele of + HsForAllVis { hsf_vis_bndrs = bndrs } -> + pp_bndrs bndrs (spaceHtml +++ arrow unicode) + HsForAllInvis { hsf_invis_bndrs = bndrs } -> + pp_bndrs bndrs dot + where + pp_bndrs :: [LHsTyVarBndr flag DocNameI] -> Html -> Html + pp_bndrs tvs forall_separator = + case [pp_ktv n k | L _ (KindedTyVar _ _ (L _ n) k) <- tvs] of + [] -> noHtml + ts -> forallSymbol unicode <+> hsep ts +++ forall_separator + + pp_ktv n k = parens $ + ppTyName (getName n) <+> dcolon unicode <+> ppLKind unicode qual k ppFixities :: [(DocName, Fixity)] -> Qualification -> Html ppFixities [] _ = noHtml @@ -1146,16 +1148,16 @@ patSigContext typ | hasNonEmptyContext typ && isFirstContextEmpty typ = ShowEmp hasNonEmptyContext :: LHsType name -> Bool 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 + 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 - HsQualTy _ cxt _ -> null (unLoc cxt) - HsFunTy _ _ s -> isFirstContextEmpty s + HsForAllTy _ _ s -> isFirstContextEmpty s + HsQualTy _ cxt _ -> null (unLoc cxt) + HsFunTy _ _ s -> isFirstContextEmpty s _ -> False @@ -1165,19 +1167,21 @@ ppPatSigType :: Unicode -> Qualification -> LHsType DocNameI -> Html ppPatSigType unicode qual typ = let emptyCtxts = patSigContext typ in ppLType unicode qual emptyCtxts typ -ppForAllPart :: RenderableBndrFlag flag => - Unicode -> Qualification -> ForallVisFlag -> [LHsTyVarBndr flag DocNameI] -> Html -ppForAllPart unicode qual fvf tvs = - hsep (forallSymbol unicode : ppTyVars unicode qual tvs) +++ - ppForAllSeparator unicode fvf +ppForAllPart :: Unicode -> Qualification -> HsForAllTelescope DocNameI -> Html +ppForAllPart unicode qual tele = case tele of + HsForAllVis { hsf_vis_bndrs = bndrs } -> + hsep (forallSymbol unicode : ppTyVars unicode qual bndrs) +++ + spaceHtml +++ arrow unicode + HsForAllInvis { hsf_invis_bndrs = bndrs } -> + hsep (forallSymbol unicode : ppTyVars unicode qual bndrs) +++ dot ppr_mono_lty :: LHsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html ppr_mono_lty ty = ppr_mono_ty (unLoc ty) ppr_mono_ty :: HsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html -ppr_mono_ty (HsForAllTy _ fvf tvs ty) unicode qual emptyCtxts - = ppForAllPart unicode qual fvf tvs <+> ppr_mono_lty ty unicode qual emptyCtxts +ppr_mono_ty (HsForAllTy _ tele ty) unicode qual emptyCtxts + = ppForAllPart unicode qual tele <+> ppr_mono_lty ty unicode qual emptyCtxts ppr_mono_ty (HsQualTy _ ctxt ty) unicode qual emptyCtxts = ppLContext ctxt unicode qual emptyCtxts <+> ppr_mono_lty ty unicode qual emptyCtxts diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 0020fc4c..b45b6eab 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -19,6 +19,8 @@ module Haddock.Convert ( PrintRuntimeReps(..), ) where +#include "HsVersions.h" + import GHC.Data.Bag ( emptyBag ) import GHC.Types.Basic ( TupleSort(..), SourceText(..), LexicalFixity(..) , PromotionFlag(..), DefMethSpec(..) ) @@ -44,7 +46,9 @@ import GHC.Builtin.Types ( eqTyConName, listTyConName, liftedTypeKindTyConName import GHC.Builtin.Names ( hasKey, eqTyConKey, ipClassKey, tYPETyConKey , liftedRepDataConKey ) import GHC.Types.Unique ( getUnique ) -import GHC.Utils.Misc ( chkAppend,dropList, filterByList, filterOut ) +import GHC.Utils.Misc ( chkAppend, debugIsOn, dropList, equalLength + , filterByList, filterOut ) +import GHC.Utils.Outputable ( assertPanic ) import GHC.Types.Var import GHC.Types.Var.Set import GHC.Types.SrcLoc @@ -53,7 +57,7 @@ import Haddock.Types import Haddock.Interface.Specialize import Haddock.GhcUtils ( orderedFVs, defaultRuntimeRepVars ) -import Data.Maybe ( catMaybes, maybeToList ) +import Data.Maybe ( catMaybes, mapMaybe, maybeToList ) -- | Whether or not to default 'RuntimeRep' variables to 'LiftedRep'. Check @@ -395,7 +399,7 @@ synifyDataCon use_gadt_syntax dc = ConDeclGADT { con_g_ext = [] , con_names = [name] , con_forall = noLoc $ not $ null user_tvbndrs - , con_qvars = map synifyInvisTyVar user_tvbndrs + , con_qvars = map synifyTyVarBndr user_tvbndrs , con_mb_cxt = ctx , con_args = hat , con_res_ty = synifyType WithinType [] res_ty @@ -404,7 +408,7 @@ synifyDataCon use_gadt_syntax dc = ConDeclH98 { con_ext = noExtField , con_name = name , con_forall = noLoc False - , con_ex_tvs = map (synifyInvisTyVar . (mkTyCoVarBinder InferredSpec)) ex_tvs + , con_ex_tvs = map (synifyTyVarBndr . (mkTyCoVarBinder InferredSpec)) ex_tvs , con_mb_cxt = ctx , con_args = hat , con_doc = Nothing } @@ -450,27 +454,25 @@ synifyTyVars ktvs = HsQTvs { hsq_ext = [] , hsq_explicit = map synifyTyVar ktvs } synifyTyVar :: TyVar -> LHsTyVarBndr () GhcRn -synifyTyVar = synifyTyVar' emptyVarSet +synifyTyVar = synify_ty_var emptyVarSet () + +synifyTyVarBndr :: VarBndr TyVar flag -> LHsTyVarBndr flag GhcRn +synifyTyVarBndr = synifyTyVarBndr' emptyVarSet -synifyInvisTyVar :: InvisTVBinder -> LHsTyVarBndr Specificity GhcRn -synifyInvisTyVar = synifyInvisTyVar' emptyVarSet +synifyTyVarBndr' :: VarSet -> VarBndr TyVar flag -> LHsTyVarBndr flag GhcRn +synifyTyVarBndr' no_kinds (Bndr tv spec) = synify_ty_var no_kinds spec tv --- | Like 'synifyTyVar', but accepts a set of variables for which to omit kind +-- | Like 'synifyTyVarBndr', but accepts a set of variables for which to omit kind -- signatures (even if they don't have the lifted type kind). -synifyTyVar' :: VarSet -> TyVar -> LHsTyVarBndr () GhcRn -synifyTyVar' no_kinds tv +synify_ty_var :: VarSet -> flag -> TyVar -> LHsTyVarBndr flag GhcRn +synify_ty_var no_kinds flag tv | isLiftedTypeKind kind || tv `elemVarSet` no_kinds - = noLoc (UserTyVar noExtField () (noLoc name)) - | otherwise = noLoc (KindedTyVar noExtField () (noLoc name) (synifyKindSig kind)) + = noLoc (UserTyVar noExtField flag (noLoc name)) + | otherwise = noLoc (KindedTyVar noExtField flag (noLoc name) (synifyKindSig kind)) where kind = tyVarKind tv name = getName tv -synifyInvisTyVar' :: VarSet -> InvisTVBinder -> LHsTyVarBndr Specificity GhcRn -synifyInvisTyVar' no_kinds (Bndr tv spec) = case (synifyTyVar' no_kinds tv) of - L l (UserTyVar ne _ n) -> L l (UserTyVar ne spec n) - L l (KindedTyVar ne _ n k) -> L l (KindedTyVar ne spec n k) - -- | Annotate (with HsKingSig) a type if the first parameter is True -- and if the type contains a free variable. -- This is used to synify type patterns for poly-kinded tyvars in @@ -626,39 +628,56 @@ synifyType _ vs (AppTy t1 t2) = let s1 = synifyType WithinType vs t1 s2 = synifyType WithinType vs t2 in noLoc $ HsAppTy noExtField s1 s2 -synifyType s vs funty@(FunTy InvisArg _ _) = synifyForAllType s Inferred vs funty +synifyType s vs funty@(FunTy InvisArg _ _) = synifySigmaType s vs funty synifyType _ vs (FunTy VisArg t1 t2) = let s1 = synifyType WithinType vs t1 s2 = synifyType WithinType vs t2 in noLoc $ HsFunTy noExtField s1 s2 synifyType s vs forallty@(ForAllTy (Bndr _ argf) _ty) = - synifyForAllType s argf vs forallty + case argf of + Required -> synifyVisForAllType vs forallty + Invisible _ -> synifySigmaType s vs forallty synifyType _ _ (LitTy t) = noLoc $ HsTyLit noExtField $ synifyTyLit t synifyType s vs (CastTy t _) = synifyType s vs t synifyType _ _ (CoercionTy {}) = error "synifyType:Coercion" --- | Process a 'Type' which starts with a forall or a constraint into --- an 'HsType' -synifyForAllType +-- | Process a 'Type' which starts with a visible @forall@ into an 'HsType' +synifyVisForAllType + :: [TyVar] -- ^ free variables in the type to convert + -> Type -- ^ the forall type to convert + -> LHsType GhcRn +synifyVisForAllType vs ty = + let (tvs, rho) = tcSplitForAllTysReqPreserveSynonyms ty + + sTvs = map synifyTyVarBndr tvs + + -- Figure out what the type variable order would be inferred in the + -- absence of an explicit forall + tvs' = orderedFVs (mkVarSet vs) [rho] + + in noLoc $ HsForAllTy { hst_tele = mkHsForAllVisTele sTvs + , hst_xforall = noExtField + , hst_body = synifyType WithinType (tvs' ++ vs) rho } + +-- | Process a 'Type' which starts with an invisible @forall@ or a constraint +-- into an 'HsType' +synifySigmaType :: SynifyTypeState -- ^ what to do with the 'forall' - -> ArgFlag -- ^ the visibility of the @forall@ -> [TyVar] -- ^ free variables in the type to convert -> Type -- ^ the forall type to convert -> LHsType GhcRn -synifyForAllType s argf vs ty = - let (tvs, ctx, tau) = tcSplitSigmaTySameVisPreserveSynonyms argf ty - inv_tvs = map to_invis_bndr tvs +synifySigmaType s vs ty = + let (tvs, ctx, tau) = tcSplitSigmaTyPreserveSynonyms ty sPhi = HsQualTy { hst_ctxt = synifyCtx ctx , hst_xqual = noExtField , hst_body = synifyType WithinType (tvs' ++ vs) tau } - sTy = HsForAllTy { hst_fvf = argToForallVisFlag argf - , hst_bndrs = sTvs + sTy = HsForAllTy { hst_tele = mkHsForAllInvisTele sTvs , hst_xforall = noExtField , hst_body = noLoc sPhi } - sTvs = map synifyInvisTyVar inv_tvs + sTvs = map synifyTyVarBndr tvs -- Figure out what the type variable order would be inferred in the -- absence of an explicit forall @@ -672,12 +691,7 @@ synifyForAllType s argf vs ty = | not (null tvs) -> noLoc sTy | otherwise -> noLoc sPhi - ImplicitizeForAll -> implicitForAll [] vs inv_tvs ctx (synifyType WithinType) tau - - where - to_invis_bndr :: TyVarBinder -> InvisTVBinder - to_invis_bndr (Bndr tv Required) = Bndr tv SpecifiedSpec - to_invis_bndr (Bndr tv (Invisible spec)) = Bndr tv spec + ImplicitizeForAll -> implicitForAll [] vs tvs ctx (synifyType WithinType) tau -- | Put a forall in if there are any type variables which require -- explicit kind annotations or if the inferred type variable order @@ -701,13 +715,12 @@ implicitForAll tycons vs tvs ctx synInner tau = HsQualTy { hst_ctxt = synifyCtx ctx , hst_xqual = noExtField , hst_body = synInner (tvs' ++ vs) tau } - sTy = HsForAllTy { hst_fvf = ForallInvis - , hst_bndrs = sTvs + sTy = HsForAllTy { hst_tele = mkHsForAllInvisTele sTvs , hst_xforall = noExtField , hst_body = noLoc sPhi } no_kinds_needed = noKindTyVars tycons tau - sTvs = map (synifyInvisTyVar' no_kinds_needed) tvs + sTvs = map (synifyTyVarBndr' no_kinds_needed) tvs -- Figure out what the type variable order would be inferred in the -- absence of an explicit forall @@ -850,22 +863,54 @@ See https://github.com/haskell/haddock/issues/879 for a bug where this invariant didn't hold. -} --- | A version of 'TcType.tcSplitSigmaTySameVis' that preserves type synonyms. +-- | A version of 'TcType.tcSplitSigmaTy' that: +-- +-- 1. Preserves type synonyms. +-- 2. Returns 'InvisTVBinder's instead of 'TyVar's. -- -- See Note [Invariant: Never expand type synonyms] -tcSplitSigmaTySameVisPreserveSynonyms :: ArgFlag -> Type -> ([TyVarBinder], ThetaType, Type) -tcSplitSigmaTySameVisPreserveSynonyms argf ty = - case tcSplitForAllTysSameVisPreserveSynonyms argf ty of +tcSplitSigmaTyPreserveSynonyms :: Type -> ([InvisTVBinder], ThetaType, Type) +tcSplitSigmaTyPreserveSynonyms ty = + case tcSplitForAllTysInvisPreserveSynonyms ty of (tvs, rho) -> case tcSplitPhiTyPreserveSynonyms rho of (theta, tau) -> (tvs, theta, tau) -- | See Note [Invariant: Never expand type synonyms] -tcSplitForAllTysSameVisPreserveSynonyms :: ArgFlag -> Type -> ([TyVarBinder], Type) -tcSplitForAllTysSameVisPreserveSynonyms supplied_argf ty = split ty ty [] +tcSplitSomeForAllTysPreserveSynonyms :: + (ArgFlag -> Bool) -> Type -> ([TyCoVarBinder], Type) +tcSplitSomeForAllTysPreserveSynonyms argf_pred ty = split ty ty [] + where + split _ (ForAllTy tvb@(Bndr _ argf) ty') tvs + | argf_pred argf = split ty' ty' (tvb:tvs) + split orig_ty _ tvs = (reverse tvs, orig_ty) + +-- | See Note [Invariant: Never expand type synonyms] +tcSplitForAllTysReqPreserveSynonyms :: Type -> ([ReqTVBinder], Type) +tcSplitForAllTysReqPreserveSynonyms ty = + let (all_bndrs, body) = tcSplitSomeForAllTysPreserveSynonyms isVisibleArgFlag ty + req_bndrs = mapMaybe mk_req_bndr_maybe all_bndrs in + ASSERT( req_bndrs `equalLength` all_bndrs ) + (req_bndrs, body) where - split _ (ForAllTy tvbndr@(Bndr _ argf) ty') tvs - | argf `sameVis` supplied_argf = split ty' ty' (tvbndr:tvs) - split orig_ty _ tvs = (reverse tvs, orig_ty) + mk_req_bndr_maybe :: TyCoVarBinder -> Maybe ReqTVBinder + mk_req_bndr_maybe (Bndr tv argf) = case argf of + Required -> Just $ Bndr tv () + Invisible _ -> Nothing + +-- | See Note [Invariant: Never expand type synonyms] +tcSplitForAllTysInvisPreserveSynonyms :: Type -> ([InvisTVBinder], Type) +tcSplitForAllTysInvisPreserveSynonyms ty = + let (all_bndrs, body) = tcSplitSomeForAllTysPreserveSynonyms isInvisibleArgFlag ty + inv_bndrs = mapMaybe mk_inv_bndr_maybe all_bndrs in + ASSERT( inv_bndrs `equalLength` all_bndrs ) + (inv_bndrs, body) + where + mk_inv_bndr_maybe :: TyCoVarBinder -> Maybe InvisTVBinder + mk_inv_bndr_maybe (Bndr tv argf) = case argf of + Invisible s -> Just $ Bndr tv s + Required -> Nothing + +-- | See Note [Invariant: Never expand type synonyms] -- | See Note [Invariant: Never expand type synonyms] tcSplitPhiTyPreserveSynonyms :: Type -> (ThetaType, Type) diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 1239377d..73a2bac6 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -34,8 +34,8 @@ import GHC import GHC.Core.Class import GHC.Driver.Session import GHC.Types.SrcLoc ( advanceSrcLoc ) -import GHC.Types.Var ( VarBndr(..), TyVarBinder, tyVarKind, updateTyVarKind, - isInvisibleArgFlag ) +import GHC.Types.Var ( Specificity, VarBndr(..), TyVarBinder + , tyVarKind, updateTyVarKind, isInvisibleArgFlag ) import GHC.Types.Var.Set ( VarSet, emptyVarSet ) import GHC.Types.Var.Env ( TyVarEnv, extendVarEnv, elemVarEnv, emptyVarEnv ) import GHC.Core.TyCo.Rep ( Type(..) ) @@ -178,6 +178,11 @@ 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 } + getConArgsI :: ConDecl DocNameI -> HsConDeclDetails DocNameI getConArgsI d = con_args d @@ -190,9 +195,8 @@ getGADTConType (ConDeclGADT { con_forall = L _ has_forall , con_qvars = qtvs , con_mb_cxt = mcxt, con_args = args , con_res_ty = res_ty }) - | has_forall = noLoc (HsForAllTy { hst_fvf = ForallInvis - , hst_xforall = noExtField - , hst_bndrs = qtvs + | has_forall = noLoc (HsForAllTy { hst_xforall = noExtField + , hst_tele = mkHsForAllInvisTeleI qtvs , hst_body = theta_ty }) | otherwise = theta_ty where @@ -245,9 +249,8 @@ getGADTConTypeG (ConDeclGADT { con_forall = L _ has_forall , con_qvars = qtvs , con_mb_cxt = mcxt, con_args = args , con_res_ty = res_ty }) - | has_forall = noLoc (HsForAllTy { hst_fvf = ForallInvis - , hst_xforall = noExtField - , hst_bndrs = qtvs + | has_forall = noLoc (HsForAllTy { hst_xforall = noExtField + , hst_tele = mkHsForAllInvisTele qtvs , hst_body = theta_ty }) | otherwise = theta_ty where @@ -309,8 +312,8 @@ reparenTypePrec = go go _ (HsExplicitTupleTy x tys) = HsExplicitTupleTy x (map reparenLType tys) go p (HsIParamTy x n ty) = paren p PREC_CTX $ HsIParamTy x n (reparenLType ty) - go p (HsForAllTy x fvf tvs ty) - = paren p PREC_CTX $ HsForAllTy x fvf (map (fmap reparenTyVar) tvs) (reparenLType ty) + go p (HsForAllTy x tele ty) + = paren p PREC_CTX $ HsForAllTy x (reparenHsForAllTelescope tele) (reparenLType ty) go p (HsQualTy x ctxt ty) = paren p PREC_FUN $ HsQualTy x (fmap (map reparenLType) ctxt) (reparenLType ty) go p (HsFunTy x ty1 ty2) @@ -350,6 +353,15 @@ reparenType = reparenTypePrec PREC_TOP reparenLType :: (XParTy a ~ NoExtField) => LHsType a -> LHsType a reparenLType = fmap reparenType +-- | Add parentheses around the types in an 'HsForAllTelescope' (see 'reparenTypePrec') +reparenHsForAllTelescope :: (XParTy a ~ NoExtField) + => HsForAllTelescope a -> HsForAllTelescope a +reparenHsForAllTelescope (HsForAllVis x bndrs) = + HsForAllVis x (map (fmap reparenTyVar) bndrs) +reparenHsForAllTelescope (HsForAllInvis x bndrs) = + HsForAllInvis x (map (fmap reparenTyVar) bndrs) +reparenHsForAllTelescope v@XHsForAllTelescope{} = v + -- | Add parenthesis around the types in a 'HsTyVarBndr' (see 'reparenTypePrec') reparenTyVar :: (XParTy a ~ NoExtField) => HsTyVarBndr flag a -> HsTyVarBndr flag a reparenTyVar (UserTyVar x flag n) = UserTyVar x flag n diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 5e09fec6..108e9f66 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -476,7 +476,7 @@ subordinates instMap decl = case decl of extract_deriv_ty (L l ty) = case ty of -- deriving (forall a. C a {- ^ Doc comment -}) - HsForAllTy{ hst_fvf = ForallInvis + HsForAllTy{ hst_tele = HsForAllInvis{} , hst_body = L _ (HsDocTy _ _ doc) } -> Just (l, doc) -- deriving (C a {- ^ Doc comment -}) diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 848acb1f..a0c118f8 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -223,11 +223,11 @@ renameMaybeInjectivityAnn = traverse renameInjectivityAnn renameType :: HsType GhcRn -> RnM (HsType DocNameI) renameType t = case t of - HsForAllTy { hst_fvf = fvf, hst_bndrs = tyvars, hst_body = ltype } -> do - tyvars' <- mapM renameLTyVarBndr tyvars - ltype' <- renameLType ltype - return (HsForAllTy { hst_fvf = fvf, hst_xforall = noExtField - , hst_bndrs = tyvars', hst_body = ltype' }) + HsForAllTy { hst_tele = tele, hst_body = ltype } -> do + tele' <- renameHsForAllTelescope tele + ltype' <- renameLType ltype + return (HsForAllTy { hst_xforall = noExtField + , hst_tele = tele', hst_body = ltype' }) HsQualTy { hst_ctxt = lcontext , hst_body = ltype } -> do lcontext' <- renameLContext lcontext @@ -304,6 +304,13 @@ renameLHsQTyVars (HsQTvs { hsq_explicit = tvs }) ; return (HsQTvs { hsq_ext = noExtField , hsq_explicit = tvs' }) } +renameHsForAllTelescope :: HsForAllTelescope GhcRn -> RnM (HsForAllTelescope DocNameI) +renameHsForAllTelescope tele = case tele of + HsForAllVis x bndrs -> do bndrs' <- mapM renameLTyVarBndr bndrs + pure $ HsForAllVis x bndrs' + HsForAllInvis x bndrs -> do bndrs' <- mapM renameLTyVarBndr bndrs + pure $ HsForAllInvis x bndrs' + renameLTyVarBndr :: LHsTyVarBndr flag GhcRn -> RnM (LHsTyVarBndr flag DocNameI) renameLTyVarBndr (L loc (UserTyVar x fl (L l n))) = do { n' <- rename n diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index cbfea762..e137c258 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -206,12 +206,16 @@ freeVariables = everythingWithState Set.empty Set.union query where query term ctx = case cast term :: Maybe (HsType GhcRn) of - Just (HsForAllTy _ _ bndrs _) -> - (Set.empty, Set.union ctx (bndrsNames bndrs)) + 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 (HsForAllVis _ bndrs) = bndrsNames bndrs + teleNames (HsForAllInvis _ bndrs) = bndrsNames bndrs + bndrsNames = Set.fromList . map (getName . tyVarName . unLoc) @@ -244,9 +248,9 @@ data RenameEnv name = RenameEnv renameType :: HsType GhcRn -> Rename (IdP GhcRn) (HsType GhcRn) -renameType (HsForAllTy x fvf bndrs lt) = - HsForAllTy x fvf - <$> mapM (located renameBinder) bndrs +renameType (HsForAllTy x tele lt) = + HsForAllTy x + <$> renameForAllTelescope tele <*> renameLType lt renameType (HsQualTy x lctxt lt) = HsQualTy x @@ -291,11 +295,21 @@ renameLTypes = mapM renameLType renameContext :: HsContext GhcRn -> Rename (IdP GhcRn) (HsContext GhcRn) renameContext = renameLTypes +renameForAllTelescope :: HsForAllTelescope GhcRn + -> Rename (IdP GhcRn) (HsForAllTelescope GhcRn) +renameForAllTelescope (HsForAllVis x bndrs) = + HsForAllVis x <$> mapM renameLBinder bndrs +renameForAllTelescope (HsForAllInvis x bndrs) = + HsForAllInvis x <$> mapM renameLBinder bndrs + renameBinder :: HsTyVarBndr flag GhcRn -> Rename (IdP GhcRn) (HsTyVarBndr flag GhcRn) renameBinder (UserTyVar x fl lname) = UserTyVar x fl <$> located renameName lname renameBinder (KindedTyVar x fl lname lkind) = KindedTyVar x fl <$> located renameName lname <*> located renameType lkind +renameLBinder :: LHsTyVarBndr flag GhcRn -> Rename (IdP GhcRn) (LHsTyVarBndr flag GhcRn) +renameLBinder = located renameBinder + -- | Core renaming logic. renameName :: (Eq name, SetName name) => name -> Rename name name renameName name = do diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index e8670012..21c7d19b 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -695,6 +695,10 @@ type instance XTyLit DocNameI = NoExtField type instance XWildCardTy DocNameI = NoExtField type instance XXType DocNameI = NewHsTypeX +type instance XHsForAllVis DocNameI = NoExtField +type instance XHsForAllInvis DocNameI = NoExtField +type instance XXHsForAllTelescope DocNameI = NoExtCon + type instance XUserTyVar DocNameI = NoExtField type instance XKindedTyVar DocNameI = NoExtField type instance XXTyVarBndr DocNameI = NoExtCon diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 010bd8bc..d72b9004 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -138,9 +138,9 @@ addClassContext cls tvs0 (L pos (ClassOpSig _ _ lname ltype)) = L pos (TypeSig noExtField lname (mkEmptySigWcType (go (hsSigType ltype)))) -- The mkEmptySigWcType is suspicious where - go (L loc (HsForAllTy { hst_fvf = fvf, hst_bndrs = tvs, hst_body = ty })) - = L loc (HsForAllTy { hst_fvf = fvf, hst_xforall = noExtField - , hst_bndrs = tvs, hst_body = go ty }) + go (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 })) = L loc (HsQualTy { hst_xqual = noExtField , hst_ctxt = add_ctxt ctxt, hst_body = ty }) -- cgit v1.2.3