diff options
Diffstat (limited to 'compiler/GHC/Rename')
| -rw-r--r-- | compiler/GHC/Rename/HsType.hs | 56 | ||||
| -rw-r--r-- | compiler/GHC/Rename/Module.hs | 6 |
2 files changed, 42 insertions, 20 deletions
diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs index df6a0f47a8..3f3eb48b68 100644 --- a/compiler/GHC/Rename/HsType.hs +++ b/compiler/GHC/Rename/HsType.hs @@ -23,6 +23,7 @@ module GHC.Rename.HsType ( checkPrecMatch, checkSectionPrec, -- Binding related stuff + bindHsForAllTelescope, bindLHsTyVarBndr, bindLHsTyVarBndrs, WarnUnusedForalls(..), rnImplicitBndrs, bindSigTyVarsFV, bindHsQTyVars, FreeKiTyVars, @@ -204,13 +205,11 @@ rnWcBody ctxt nwc_rdrs hs_ty rn_ty :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars) -- A lot of faff just to allow the extra-constraints wildcard to appear - rn_ty env (HsForAllTy { hst_fvf = fvf, hst_bndrs = tvs - , hst_body = hs_body }) - = bindLHsTyVarBndrs (rtke_ctxt env) WarnUnusedForalls - Nothing tvs $ \ tvs' -> + rn_ty env (HsForAllTy { hst_tele = tele, hst_body = hs_body }) + = bindHsForAllTelescope (rtke_ctxt env) tele $ \ tele' -> do { (hs_body', fvs) <- rn_lty env hs_body - ; return (HsForAllTy { hst_fvf = fvf, hst_xforall = noExtField - , hst_bndrs = tvs', hst_body = hs_body' } + ; return (HsForAllTy { hst_xforall = noExtField + , hst_tele = tele', hst_body = hs_body' } , fvs) } rn_ty env (HsQualTy { hst_ctxt = L cx hs_ctxt @@ -429,9 +428,10 @@ check_inferred_vars ctxt (Just msg) ty = where forallty_bndrs :: LHsType GhcPs -> [HsTyVarBndr Specificity GhcPs] forallty_bndrs (L _ ty) = case ty of - HsParTy _ ty' -> forallty_bndrs ty' - HsForAllTy { hst_bndrs = tvs } -> map unLoc tvs - _ -> [] + HsParTy _ ty' -> forallty_bndrs ty' + HsForAllTy { hst_tele = HsForAllInvis { hsf_invis_bndrs = tvs }} + -> map unLoc tvs + _ -> [] {- ****************************************************** * * @@ -559,14 +559,12 @@ rnLHsTyKi env (L loc ty) rnHsTyKi :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars) -rnHsTyKi env ty@(HsForAllTy { hst_fvf = fvf, hst_bndrs = tyvars - , hst_body = tau }) +rnHsTyKi env ty@(HsForAllTy { hst_tele = tele, hst_body = tau }) = do { checkPolyKinds env ty - ; bindLHsTyVarBndrs (rtke_ctxt env) WarnUnusedForalls - Nothing tyvars $ \ tyvars' -> + ; bindHsForAllTelescope (rtke_ctxt env) tele $ \ tele' -> do { (tau', fvs) <- rnLHsTyKi env tau - ; return ( HsForAllTy { hst_fvf = fvf, hst_xforall = noExtField - , hst_bndrs = tyvars' , hst_body = tau' } + ; return ( HsForAllTy { hst_xforall = noExtField + , hst_tele = tele' , hst_body = tau' } , fvs) } } rnHsTyKi env ty@(HsQualTy { hst_ctxt = lctxt, hst_body = tau }) @@ -1051,6 +1049,19 @@ an LHsQTyVars can be semantically significant. As a result, we suppress -Wunused-foralls warnings in exactly one place: in bindHsQTyVars. -} +bindHsForAllTelescope :: HsDocContext + -> HsForAllTelescope GhcPs + -> (HsForAllTelescope GhcRn -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) +bindHsForAllTelescope doc tele thing_inside = + case tele of + HsForAllVis { hsf_vis_bndrs = bndrs } -> + bindLHsTyVarBndrs doc WarnUnusedForalls Nothing bndrs $ \bndrs' -> + thing_inside $ mkHsForAllVisTele bndrs' + HsForAllInvis { hsf_invis_bndrs = bndrs } -> + bindLHsTyVarBndrs doc WarnUnusedForalls Nothing bndrs $ \bndrs' -> + thing_inside $ mkHsForAllInvisTele bndrs' + -- | Should GHC warn if a quantified type variable goes unused? Usually, the -- answer is \"yes\", but in the particular case of binding 'LHsQTyVars', we -- avoid emitting warnings. @@ -1820,8 +1831,8 @@ extract_lty (L _ ty) acc HsStarTy _ _ -> acc HsKindSig _ ty ki -> extract_lty ty $ extract_lty ki acc - HsForAllTy { hst_bndrs = tvs, hst_body = ty } - -> extract_hs_tv_bndrs tvs acc $ + HsForAllTy { hst_tele = tele, hst_body = ty } + -> extract_hs_for_all_telescope tele acc $ extract_lty ty [] HsQualTy { hst_ctxt = ctxt, hst_body = ty } -> extract_lctxt ctxt $ @@ -1830,6 +1841,17 @@ extract_lty (L _ ty) acc -- We deal with these separately in rnLHsTypeWithWildCards HsWildCardTy {} -> acc +extract_hs_for_all_telescope :: HsForAllTelescope GhcPs + -> FreeKiTyVars -- Accumulator + -> FreeKiTyVars -- Free in body + -> FreeKiTyVars +extract_hs_for_all_telescope tele acc_vars body_fvs = + case tele of + HsForAllVis { hsf_vis_bndrs = bndrs } -> + extract_hs_tv_bndrs bndrs acc_vars body_fvs + HsForAllInvis { hsf_invis_bndrs = bndrs } -> + extract_hs_tv_bndrs bndrs acc_vars body_fvs + extractHsTvBndrs :: [LHsTyVarBndr flag GhcPs] -> FreeKiTyVars -- Free in body -> FreeKiTyVars -- Free in result diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs index 533a794807..e610a60ff3 100644 --- a/compiler/GHC/Rename/Module.hs +++ b/compiler/GHC/Rename/Module.hs @@ -2182,13 +2182,13 @@ rnConDecl (XConDecl (ConDeclGADTPrefixPs { con_gp_names = names, con_gp_ty = ty -- Note [GADT abstract syntax] (Wrinkle: No nested foralls or contexts) -- in GHC.Hs.Type. ; case res_ty of - L l (HsForAllTy { hst_fvf = fvf }) - | ForallVis <- fvf + L l (HsForAllTy { hst_tele = tele }) + | HsForAllVis{} <- tele -> setSrcSpan l $ addErr $ withHsDocContext ctxt $ vcat [ text "Illegal visible, dependent quantification" <+> text "in the type of a term" , text "(GHC does not yet support this)" ] - | ForallInvis <- fvf + | HsForAllInvis{} <- tele -> nested_foralls_contexts_err l ctxt L l (HsQualTy {}) -> nested_foralls_contexts_err l ctxt |