[Git][ghc/ghc][wip/int-index/decl-invis-binders] Refactor rnLHsTyVarBndrVisFlag, mkExplicitTyConBinder
Vladislav Zavialov (@int-index)
gitlab at gitlab.haskell.org
Wed Jan 25 10:36:17 UTC 2023
Vladislav Zavialov pushed to branch wip/int-index/decl-invis-binders at Glasgow Haskell Compiler / GHC
Commits:
40a21608 by Vladislav Zavialov at 2023-01-25T13:32:34+03:00
Refactor rnLHsTyVarBndrVisFlag, mkExplicitTyConBinder
- - - - -
6 changed files:
- compiler/GHC/Core/TyCon.hs
- compiler/GHC/Rename/HsType.hs
- compiler/GHC/Tc/Gen/HsType.hs
- compiler/GHC/Tc/Gen/Splice.hs
- compiler/GHC/Tc/TyCl.hs
- compiler/GHC/Types/Var.hs
Changes:
=====================================
compiler/GHC/Core/TyCon.hs
=====================================
@@ -24,6 +24,7 @@ module GHC.Core.TyCon(
mkNamedTyConBinder, mkNamedTyConBinders,
mkRequiredTyConBinder,
mkAnonTyConBinder, mkAnonTyConBinders,
+ anonToRequiredTcb,
tyConBinderForAllTyFlag, tyConBndrVisForAllTyFlag, isNamedTyConBinder,
isVisibleTyConBinder, isInvisibleTyConBinder,
isVisibleTcbVis, isInvisSpecTcbVis,
@@ -487,6 +488,13 @@ mkRequiredTyConBinder dep_set tv
| tv `elemVarSet` dep_set = mkNamedTyConBinder Required tv
| otherwise = mkAnonTyConBinder tv
+-- | Turn AnonTCB into a NamedTCB if the tv is mentioned in the dependent set
+anonToRequiredTcb :: TyCoVarSet -- variables that are used dependently
+ -> TyConBinder
+ -> TyConBinder
+anonToRequiredTcb dep_set (Bndr tv AnonTCB) = mkRequiredTyConBinder dep_set tv
+anonToRequiredTcb _ bndr = bndr
+
tyConBinderForAllTyFlag :: TyConBinder -> ForAllTyFlag
tyConBinderForAllTyFlag (Bndr _ vis) = tyConBndrVisForAllTyFlag vis
=====================================
compiler/GHC/Rename/HsType.hs
=====================================
@@ -1244,14 +1244,10 @@ rnLHsTyVarBndrVisFlag
:: LHsTyVarBndr (HsBndrVis GhcPs) GhcRn
-> RnM (LHsTyVarBndr (HsBndrVis GhcRn) GhcRn)
rnLHsTyVarBndrVisFlag (L loc bndr) = do
- let lbndr = L loc $ case bndr of
- UserTyVar x flag lname -> UserTyVar x (rnHsBndrVis flag) lname
- KindedTyVar x flag lname kind -> KindedTyVar x (rnHsBndrVis flag) lname kind
- unlessXOptM LangExt.TypeAbstractions $
- let invis = case bndr of
- UserTyVar _ flag _ -> isHsBndrInvisible flag
- KindedTyVar _ flag _ _ -> isHsBndrInvisible flag
- in when invis $ addErr (TcRnIllegalInvisTyVarBndr lbndr)
+ let flag = rnHsBndrVis (hsTyVarBndrFlag bndr)
+ lbndr = L loc (setHsTyVarBndrFlag flag bndr)
+ unlessXOptM LangExt.TypeAbstractions $ do
+ when (isHsBndrInvisible flag) $ addErr (TcRnIllegalInvisTyVarBndr lbndr)
return lbndr
rnHsBndrVis :: HsBndrVis GhcPs -> HsBndrVis GhcRn
=====================================
compiler/GHC/Tc/Gen/HsType.hs
=====================================
@@ -2392,14 +2392,9 @@ kcCheckDeclHeader_cusk name flav
specified = scopedSort scoped_kvs
-- NB: maintain the L-R order of scoped_kvs
- mkExplicitTyConBinder (Bndr tv flag) =
- case flag of
- HsBndrRequired -> mkRequiredTyConBinder mentioned_kv_set tv
- HsBndrInvisible{} -> mkNamedTyConBinder Specified tv
-
all_tcbs = mkNamedTyConBinders Inferred inferred
++ mkNamedTyConBinders Specified specified
- ++ map mkExplicitTyConBinder tc_bndrs
+ ++ map (mkExplicitTyConBinder mentioned_kv_set) tc_bndrs
-- Eta expand if necessary; we are building a PolyTyCon
; (eta_tcbs, res_kind) <- etaExpandAlgTyCon flav skol_info all_tcbs res_kind
@@ -2472,12 +2467,9 @@ kcInferDeclHeader name flav
-- recursive group.
-- See Note [Inferring kinds for type declarations] in GHC.Tc.TyCl
- mkExplicitTyConBinder (Bndr tv flag) =
- case flag of
- HsBndrRequired -> mkAnonTyConBinder tv -- See Note [No polymorphic recursion]
- HsBndrInvisible{} -> mkNamedTyConBinder Specified tv
+ dep_set = emptyVarSet -- See Note [Empty dep_set in kcInferDeclHeader]
- tc_binders = map mkExplicitTyConBinder tc_bndrs
+ tc_binders = map (mkExplicitTyConBinder dep_set) tc_bndrs
-- Also, note that tc_binders has the tyvars from only the
-- user-written tyvarbinders. See S1 in Note [How TcTyCons work]
-- in GHC.Tc.TyCl
@@ -2501,6 +2493,37 @@ kcInferDeclHeader name flav
ctxt_kind | tcFlavourIsOpen flav = TheKind liftedTypeKind
| otherwise = AnyKind
+{- Note [Empty dep_set in kcInferDeclHeader]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The dep_set determines the choice between
+ 1. non-dependent quantification (AnonTCB):
+ k -> r
+ 2. dependent quantification (NamedTCB Required):
+ forall (a::k) -> r
+
+We want dependent quantification if the variable 'a' is mentioned in 'r'.
+This is checked in mkRequiredTyConBinder.
+
+* In kcCheckDeclHeader_cusk we compute the dep_set using candidateQTyVarsOfKinds.
+* In kcInferDeclHeader we can't do that because this set can be affected when
+ metavariables are filled in during kind inference.
+
+By using emptyVarSet, we end up with AnonTCB even for dependent variables.
+But no worries: we can compute the dep_set later, in generaliseTcTyCon,
+and use anonToRequiredTcb to change AnonTCB to NamedTCB Required.
+
+See also: Note [No polymorphic recursion]
+-}
+
+-- | Create a TyConBinder for a user-written type variable binder.
+mkExplicitTyConBinder :: TyCoVarSet -- variables that are used dependently
+ -> VarBndr TyVar (HsBndrVis GhcRn)
+ -> TyConBinder
+mkExplicitTyConBinder dep_set (Bndr tv flag) =
+ case flag of
+ HsBndrRequired -> mkRequiredTyConBinder dep_set tv
+ HsBndrInvisible{} -> mkNamedTyConBinder Specified tv
+
-- | Kind-check a declaration header against a standalone kind signature.
-- See Note [kcCheckDeclHeader_sig]
kcCheckDeclHeader_sig
@@ -2643,7 +2666,7 @@ matchUpSigWithDecl sig_tcbs sig_res_kind hs_bndrs thing_inside
= failWithTc (TcRnTooManyBinders sig_res_kind hs_bndrs)
go subst (tcb : tcbs') hs_bndrs@(hs_bndr : hs_bndrs')
- | zippable (binderFlag tcb) (getLHsTyVarBndrVis hs_bndr)
+ | zippable (binderFlag tcb) (hsTyVarBndrFlag (unLoc hs_bndr))
= -- Visible TyConBinder, so match up with the hs_bndrs
do { let Bndr tv vis = tcb
tv' = updateTyVarKind (substTy subst) $
@@ -2691,10 +2714,6 @@ matchUpSigWithDecl sig_tcbs sig_res_kind hs_bndrs thing_inside
skippable :: TyConBndrVis -> Bool
skippable vis = not (isVisibleTcbVis vis)
-getLHsTyVarBndrVis :: LHsTyVarBndr (HsBndrVis GhcRn) GhcRn -> HsBndrVis GhcRn
-getLHsTyVarBndrVis (L _ (UserTyVar _ bvis _)) = bvis
-getLHsTyVarBndrVis (L _ (KindedTyVar _ bvis _ _)) = bvis
-
substTyConBinderX :: Subst -> TyConBinder -> (Subst, TyConBinder)
substTyConBinderX subst (Bndr tv vis)
= (subst', Bndr tv' vis)
=====================================
compiler/GHC/Tc/Gen/Splice.hs
=====================================
@@ -2256,9 +2256,8 @@ reifyDataCon isGadtDataCon tys dc
subst_tv_binders subst tv_bndrs =
let tvs = binderVars tv_bndrs
- flags = binderFlags tv_bndrs
(subst', tvs') = substTyVarBndrs subst tvs
- tv_bndrs' = map (\(tv,fl) -> Bndr tv fl) (zip tvs' flags)
+ tv_bndrs' = setBndrVars "subst_tv_binders" tvs' tv_bndrs
in (subst', tv_bndrs')
{-
=====================================
compiler/GHC/Tc/TyCl.hs
=====================================
@@ -929,16 +929,14 @@ generaliseTcTyCon (tc, skol_info, scoped_prs, tc_res_kind)
; let dep_fv_set = candidateKindVars dvs1
inferred_tcbs = mkNamedTyConBinders Inferred inferred
specified_tcbs = mkNamedTyConBinders Specified sorted_spec_tvs
- required_tcbs = zipWith mkExplicitTyConBinder (tyConBinders tc) req_tvs
- mkExplicitTyConBinder (Bndr _ flag) tv =
- case flag of
- NamedTCB vis -> mkNamedTyConBinder vis tv
- AnonTCB -> mkRequiredTyConBinder dep_fv_set tv
+ explicit_tcbs =
+ map (anonToRequiredTcb dep_fv_set) $
+ setBndrVars "explicit_tcbs" req_tvs (tyConBinders tc)
-- Step 5: Assemble the final list.
all_tcbs = concat [ inferred_tcbs
, specified_tcbs
- , required_tcbs ]
+ , explicit_tcbs ]
flav = tyConFlavour tc
-- Eta expand
@@ -958,7 +956,7 @@ generaliseTcTyCon (tc, skol_info, scoped_prs, tc_res_kind)
, text "dep_fv_set =" <+> ppr dep_fv_set
, text "inferred_tcbs =" <+> ppr inferred_tcbs
, text "specified_tcbs =" <+> ppr specified_tcbs
- , text "required_tcbs =" <+> ppr required_tcbs
+ , text "explicit_tcbs =" <+> ppr explicit_tcbs
, text "final_tcbs =" <+> ppr final_tcbs ]
-- Step 7: Check for validity.
=====================================
compiler/GHC/Types/Var.hs
=====================================
@@ -93,6 +93,7 @@ module GHC.Types.Var (
isTyVarBinder,
tyVarSpecToBinder, tyVarSpecToBinders, tyVarReqToBinder, tyVarReqToBinders,
mapVarBndr, mapVarBndrs,
+ setBndrVar, setBndrVars,
-- ** Constructing TyVar's
mkTyVar, mkTcTyVar,
@@ -761,6 +762,12 @@ mapVarBndr f (Bndr v fl) = Bndr (f v) fl
mapVarBndrs :: (var -> var') -> [VarBndr var flag] -> [VarBndr var' flag]
mapVarBndrs f = map (mapVarBndr f)
+setBndrVar :: var' -> VarBndr var flag -> VarBndr var' flag
+setBndrVar v (Bndr _ flag) = Bndr v flag
+
+setBndrVars :: String -> [var'] -> [VarBndr var flag] -> [VarBndr var' flag]
+setBndrVars msg = zipWithEqual msg setBndrVar
+
instance Outputable tv => Outputable (VarBndr tv ForAllTyFlag) where
ppr (Bndr v Required) = ppr v
ppr (Bndr v Specified) = char '@' <> ppr v
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/40a216086cf429cf8200fcc59c7fd57f9cfa9130
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/40a216086cf429cf8200fcc59c7fd57f9cfa9130
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230125/7309ae86/attachment-0001.html>
More information about the ghc-commits
mailing list