Commit 5dcae88b authored by niteria's avatar niteria
Browse files

Rename "open" subst functions

This is the renaming that @simonpj requested:
```
· zipOpenTCvSubst  -> zipTvSubst   (It only deals with tyvars)

· zipOpenTCvSubstCoVars -> zipCvSubst   (it only deals with
covars)

· zipOpenTCvSubstBinders ->  zipTyBinderSubst  (it only deals
with TyBinders, not covars)
```
plus the `mk` variant.

Test Plan: ./validate

Reviewers: simonpj, goldfire, austin, bgamari

Subscribers: thomie, simonpj

Differential Revision: https://phabricator.haskell.org/D1853

GHC Trac Issues: #11371
parent 00cbbab3
......@@ -974,7 +974,7 @@ dataConInstSig (MkData { dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs
, substTheta subst (eqSpecPreds eq_spec ++ theta)
, substTys subst arg_tys)
where
univ_subst = zipOpenTCvSubst univ_tvs univ_tys
univ_subst = zipTvSubst univ_tvs univ_tys
(subst, ex_tvs') = mapAccumL Type.substTyVarBndr univ_subst ex_tvs
......
......@@ -522,7 +522,7 @@ mkDataConRep dflags fam_envs wrap_name mb_bangs data_con
where
(univ_tvs, ex_tvs, eq_spec, theta, orig_arg_tys, _orig_res_ty)
= dataConFullSig data_con
res_ty_args = substTyVars (mkTopTCvSubst (map eqSpecPair eq_spec)) univ_tvs
res_ty_args = substTyVars (mkTvSubstPrs (map eqSpecPair eq_spec)) univ_tvs
tycon = dataConTyCon data_con -- The representation TyCon (not family)
wrap_ty = dataConUserType data_con
......@@ -563,7 +563,7 @@ mkDataConRep dflags fam_envs wrap_name mb_bangs data_con
mk_boxer :: [Boxer] -> DataConBoxer
mk_boxer boxers = DCB (\ ty_args src_vars ->
do { let (ex_vars, term_vars) = splitAtList ex_tvs src_vars
subst1 = mkTopTCvSubst (univ_tvs `zip` ty_args)
subst1 = mkTvSubstPrs (univ_tvs `zip` ty_args)
subst2 = extendTCvSubstList subst1 ex_tvs
(mkTyVarTys ex_vars)
; (rep_ids, binds) <- go subst2 boxers term_vars
......
......@@ -1557,7 +1557,7 @@ dataConInstPat fss uniqs con inst_tys
(ex_fss, id_fss) = splitAt n_ex fss
-- Make the instantiating substitution for universals
univ_subst = zipOpenTCvSubst univ_tvs inst_tys
univ_subst = zipTvSubst univ_tvs inst_tys
-- Make existential type variables, applyingn and extending the substitution
(full_subst, ex_bndrs) = mapAccumL mk_ex_var univ_subst
......
......@@ -723,7 +723,7 @@ mkOneConFull x usupply con = (con_abs, constraints)
Just (tc, tys) -> ASSERT( tc == data_tc ) tys
Nothing -> pprPanic "mkOneConFull: Not TyConApp:" (ppr res_ty)
subst1 = zipOpenTCvSubst univ_tvs tc_args
subst1 = zipTvSubst univ_tvs tc_args
(subst, ex_tvs') = cloneTyVarBndrs subst1 ex_tvs usupply1
......
......@@ -623,7 +623,7 @@ dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields
mk_alt upd_fld_env con
= do { let (univ_tvs, ex_tvs, eq_spec,
prov_theta, _req_theta, arg_tys, _) = conLikeFullSig con
subst = mkTopTCvSubst (univ_tvs `zip` in_inst_tys)
subst = mkTvSubstPrs (univ_tvs `zip` in_inst_tys)
-- I'm not bothering to clone the ex_tvs
; eqs_vars <- mapM newPredVarDs (substTheta subst (eqSpecPreds eq_spec))
......
......@@ -157,7 +157,7 @@ mkDataConStupidTheta tycon arg_tys univ_tvs
| null stupid_theta = [] -- The common case
| otherwise = filter in_arg_tys stupid_theta
where
tc_subst = zipOpenTCvSubst (tyConTyVars tycon) (mkTyVarTys univ_tvs)
tc_subst = zipTvSubst (tyConTyVars tycon) (mkTyVarTys univ_tvs)
stupid_theta = substTheta tc_subst (tyConStupidTheta tycon)
-- Start by instantiating the master copy of the
-- stupid theta, taken from the TyCon
......@@ -205,8 +205,8 @@ buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder
(ex_tvs1, prov_theta1, cont_tau) = tcSplitSigmaTy cont_sigma
(arg_tys1, _) = tcSplitFunTys cont_tau
twiddle = char '~'
subst = zipOpenTCvSubst (univ_tvs1 ++ ex_tvs1)
(mkTyVarTys (univ_tvs ++ ex_tvs))
subst = zipTvSubst (univ_tvs1 ++ ex_tvs1)
(mkTyVarTys (univ_tvs ++ ex_tvs))
------------------------------------------------------
type TcMethInfo = (Name, Type, Maybe (DefMethSpec Type))
......
......@@ -569,7 +569,7 @@ tcIfaceDataCons tycon_name tycon tc_tyvars if_cons
-- Remember, tycon is the representation tycon
; let orig_res_ty = mkFamilyTyConApp tycon
(substTyVars (mkTopTCvSubst (map eqSpecPair eq_spec))
(substTyVars (mkTvSubstPrs (map eqSpecPair eq_spec))
tc_tyvars)
; prom_rep_name <- newTyConRepName dc_name
......
......@@ -577,9 +577,9 @@ bindLocalsAtBreakpoint hsc_env apStack_fhv (Just BreakInfo{..}) = do
-- Similarly, clone the type variables mentioned in the types
-- we have here, *and* make them all RuntimeUnk tyars
newTyVars us tvs
= mkTopTCvSubst [ (tv, mkTyVarTy (mkRuntimeUnkTyVar name (tyVarKind tv)))
| (tv, uniq) <- varSetElems tvs `zip` uniqsFromSupply us
, let name = setNameUnique (tyVarName tv) uniq ]
= mkTvSubstPrs [ (tv, mkTyVarTy (mkRuntimeUnkTyVar name (tyVarKind tv)))
| (tv, uniq) <- varSetElems tvs `zip` uniqsFromSupply us
, let name = setNameUnique (tyVarName tv) uniq ]
rttiEnvironment :: HscEnv -> IO HscEnv
rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
......
......@@ -1002,13 +1002,13 @@ inferConstraints main_cls cls_tys inst_ty rep_tc rep_tc_args
mkThetaOrigin DerivOrigin TypeLevel $
substTheta cls_subst (classSCTheta main_cls)
cls_subst = ASSERT( equalLength cls_tvs inst_tys )
zipOpenTCvSubst cls_tvs inst_tys
zipTvSubst cls_tvs inst_tys
-- Stupid constraints
stupid_constraints = mkThetaOrigin DerivOrigin TypeLevel $
substTheta tc_subst (tyConStupidTheta rep_tc)
tc_subst = ASSERT( equalLength rep_tc_tvs all_rep_tc_args )
zipOpenTCvSubst rep_tc_tvs all_rep_tc_args
zipTvSubst rep_tc_tvs all_rep_tc_args
-- Extra Data constraints
-- The Data class (only) requires that for
......@@ -1574,7 +1574,7 @@ mkNewTypeEqn dflags overlap_mode tvs
inst_ty = mkTyConApp tycon tc_args
inst_tys = cls_tys ++ [inst_ty]
sc_theta = mkThetaOrigin DerivOrigin TypeLevel $
substTheta (zipOpenTCvSubst cls_tyvars inst_tys) $
substTheta (zipTvSubst cls_tyvars inst_tys) $
classSCTheta cls
-- Next we collect Coercible constraints between
......@@ -1889,7 +1889,7 @@ simplifyDeriv pred tvs theta
; let min_theta = mkMinimalBySCs (bagToList good)
subst_skol = zipOpenTCvSubst tvs_skols $ mkTyVarTys tvs
subst_skol = zipTvSubst tvs_skols $ mkTyVarTys tvs
-- The reverse substitution (sigh)
; return (substTheta subst_skol min_theta) }
......
......@@ -956,7 +956,7 @@ flatten_one (TyConApp tc tys)
-- Expand type synonyms that mention type families
-- on the RHS; see Note [Flattening synonyms]
| Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys
, let expanded_ty = mkAppTys (substTy (mkTopTCvSubst tenv) rhs) tys'
, let expanded_ty = mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys'
= do { mode <- getMode
; let used_tcs = tyConsOfType rhs
; case mode of
......
......@@ -791,7 +791,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
; let (clas, inst_tys) = tcSplitDFunHead inst_head
(class_tyvars, sc_theta, _, op_items) = classBigSig clas
sc_theta' = substTheta (zipOpenTCvSubst class_tyvars inst_tys) sc_theta
sc_theta' = substTheta (zipTvSubst class_tyvars inst_tys) sc_theta
; traceTc "tcInstDecl2" (vcat [ppr inst_tyvars, ppr inst_tys, ppr dfun_theta, ppr sc_theta'])
......
......@@ -737,7 +737,7 @@ tcDataConPat penv (L con_span con_name) data_con pat_ty arg_pats thing_inside
; let all_arg_tys = eqSpecPreds eq_spec ++ theta ++ arg_tys
; checkExistentials ex_tvs all_arg_tys penv
; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX
(zipOpenTCvSubst univ_tvs ctxt_res_tys) ex_tvs
(zipTvSubst univ_tvs ctxt_res_tys) ex_tvs
-- Get location from monad, not from ex_tvs
; let -- pat_ty' = mkTyConApp tycon ctxt_res_tys
......@@ -1011,7 +1011,7 @@ addDataConStupidTheta data_con inst_tys
-- The origin should always report "occurrence of C"
-- even when C occurs in a pattern
stupid_theta = dataConStupidTheta data_con
tenv = mkTopTCvSubst (dataConUnivTyVars data_con `zip` inst_tys)
tenv = mkTvSubstPrs (dataConUnivTyVars data_con `zip` inst_tys)
-- NB: inst_tys can be longer than the univ tyvars
-- because the constructor might have existentials
inst_theta = substTheta tenv stupid_theta
......
......@@ -1017,7 +1017,7 @@ mkOneRecordSelector all_cons idDetails fl
(univ_tvs, _, eq_spec, _, req_theta, _, data_ty) = conLikeFullSig con1
eq_subst = mkTopTCvSubst (map eqSpecPair eq_spec)
eq_subst = mkTvSubstPrs (map eqSpecPair eq_spec)
inst_tys = substTyVars eq_subst univ_tvs
unit_rhs = mkLHsTupleExpr []
......
......@@ -146,8 +146,8 @@ module TcType (
-- Type substitutions
TCvSubst(..), -- Representation visible to a few friends
TvSubstEnv, emptyTCvSubst,
mkOpenTCvSubst, zipOpenTCvSubst,
mkTopTCvSubst, notElemTCvSubst, unionTCvSubst,
zipTvSubst,
mkTvSubstPrs, notElemTCvSubst, unionTCvSubst,
getTvSubstEnv, setTvSubstEnv, getTCvInScope, extendTCvInScope,
extendTCvInScopeList, extendTCvInScopeSet, extendTCvSubstAndInScope,
Type.lookupTyVar, Type.extendTCvSubst, Type.substTyVarBndr,
......@@ -1757,7 +1757,7 @@ transSuperClasses p
immSuperClasses :: Class -> [Type] -> [PredType]
immSuperClasses cls tys
= substTheta (zipOpenTCvSubst tyvars tys) sc_theta
= substTheta (zipTvSubst tyvars tys) sc_theta
where
(tyvars,sc_theta,_,_) = classBigSig cls
......
......@@ -1237,7 +1237,7 @@ normalise_tc_app tc tys
; case expandSynTyCon_maybe tc ntys of
{ Just (tenv, rhs, ntys') ->
do { (co2, ninst_rhs)
<- normalise_type (substTy (mkTopTCvSubst tenv) rhs)
<- normalise_type (substTy (mkTvSubstPrs tenv) rhs)
; return $
if isReflCo co2
then (args_co, mkTyConApp tc ntys)
......
......@@ -722,8 +722,8 @@ checkAxInstCo (AxiomInstCo ax ind cos)
incomps = coAxBranchIncomps branch
(tys, cotys) = splitAtList tvs (map (pFst . coercionKind) cos)
co_args = map stripCoercionTy cotys
subst = zipOpenTCvSubst tvs tys `composeTCvSubst`
zipOpenTCvSubstCoVars cvs co_args
subst = zipTvSubst tvs tys `composeTCvSubst`
zipCvSubst cvs co_args
target = Type.substTys subst (coAxBranchLHS branch)
in_scope = mkInScopeSet $
unionVarSets (map (tyCoVarsOfTypes . coAxBranchLHS) incomps)
......
......@@ -82,9 +82,9 @@ module TyCoRep (
extendTCvSubst, extendTCvSubstAndInScope, extendTCvSubstList,
extendTCvSubstBinder,
unionTCvSubst, zipTyEnv, zipCoEnv, mkTyCoInScopeSet,
mkOpenTCvSubst, zipOpenTCvSubst, zipOpenTCvSubstCoVars,
zipOpenTCvSubstBinders,
mkTopTCvSubst,
zipTvSubst, zipCvSubst,
zipTyBinderSubst,
mkTvSubstPrs,
substTelescope,
substTyWith, substTyWithCoVars, substTysWith, substTysWithCoVars,
......@@ -1637,7 +1637,7 @@ unionTCvSubst (TCvSubst in_scope1 tenv1 cenv1) (TCvSubst in_scope2 tenv2 cenv2)
(tenv1 `plusVarEnv` tenv2)
(cenv1 `plusVarEnv` cenv2)
-- mkOpenTCvSubst and zipOpenTCvSubst generate the in-scope set from
-- mkTvSubstPrs and zipTvSubst generate the in-scope set from
-- the types given; but it's just a thunk so with a bit of luck
-- it'll never be evaluated
......@@ -1648,50 +1648,46 @@ mkTyCoInScopeSet tys cos
= mkInScopeSet (tyCoVarsOfTypes tys `unionVarSet` tyCoVarsOfCos cos)
-- | Generates the in-scope set for the 'TCvSubst' from the types in the incoming
-- environment, hence "open"
mkOpenTCvSubst :: TvSubstEnv -> CvSubstEnv -> TCvSubst
mkOpenTCvSubst tenv cenv
= TCvSubst (mkTyCoInScopeSet (varEnvElts tenv) (varEnvElts cenv)) tenv cenv
-- | Generates the in-scope set for the 'TCvSubst' from the types in the incoming
-- environment, hence "open". No CoVars, please!
zipOpenTCvSubst :: [TyVar] -> [Type] -> TCvSubst
zipOpenTCvSubst tvs tys
-- environment. No CoVars, please!
zipTvSubst :: [TyVar] -> [Type] -> TCvSubst
zipTvSubst tvs tys
| debugIsOn
, not (all isTyVar tvs) || length tvs /= length tys
= pprTrace "zipOpenTCvSubst" (ppr tvs $$ ppr tys) emptyTCvSubst
= pprTrace "zipTvSubst" (ppr tvs $$ ppr tys) emptyTCvSubst
| otherwise
= TCvSubst (mkInScopeSet (tyCoVarsOfTypes tys)) tenv emptyCvSubstEnv
where
tenv = zipTyEnv tvs tys
-- | Generates the in-scope set for the 'TCvSubst' from the types in the incoming
-- environment, hence "open". No TyVars, please!
zipOpenTCvSubstCoVars :: [CoVar] -> [Coercion] -> TCvSubst
zipOpenTCvSubstCoVars cvs cos
-- environment. No TyVars, please!
zipCvSubst :: [CoVar] -> [Coercion] -> TCvSubst
zipCvSubst cvs cos
| debugIsOn
, not (all isCoVar cvs) || length cvs /= length cos
= pprTrace "zipOpenTCvSubstCoVars" (ppr cvs $$ ppr cos) emptyTCvSubst
= pprTrace "zipCvSubst" (ppr cvs $$ ppr cos) emptyTCvSubst
| otherwise
= TCvSubst (mkInScopeSet (tyCoVarsOfCos cos)) emptyTvSubstEnv cenv
where
cenv = zipCoEnv cvs cos
-- | Create an open TCvSubst combining the binders and types provided.
-- | Create a TCvSubst combining the binders and types provided.
-- NB: It is specifically OK if the lists are of different lengths.
zipOpenTCvSubstBinders :: [TyBinder] -> [Type] -> TCvSubst
zipOpenTCvSubstBinders bndrs tys
zipTyBinderSubst :: [TyBinder] -> [Type] -> TCvSubst
zipTyBinderSubst bndrs tys
= TCvSubst is tenv emptyCvSubstEnv
where
is = mkInScopeSet (tyCoVarsOfTypes tys)
tenv = mkVarEnv [ (tv, ty) | (Named tv _, ty) <- zip bndrs tys ]
-- | Called when doing top-level substitutions. No CoVars, please!
mkTopTCvSubst :: [(TyVar, Type)] -> TCvSubst
mkTopTCvSubst prs =
-- | Generates the in-scope set for the 'TCvSubst' from the types in the
-- incoming environment. No CoVars, please!
mkTvSubstPrs :: [(TyVar, Type)] -> TCvSubst
mkTvSubstPrs prs =
ASSERT2( onlyTyVarsAndNoCoercionTy, text "prs" <+> ppr prs )
mkOpenTCvSubst tenv emptyCvSubstEnv
TCvSubst in_scope tenv emptyCvSubstEnv
where tenv = mkVarEnv prs
in_scope = mkInScopeSet $ tyCoVarsOfTypes $ map snd prs
onlyTyVarsAndNoCoercionTy =
and [ isTyVar tv && not (isCoercionTy ty)
| (tv, ty) <- prs ]
......@@ -1785,11 +1781,10 @@ substTelescope = go_subst emptyTCvSubst
go_subst _ _ _ = panic "substTelescope"
-- | Type substitution making use of an 'TCvSubst' that
-- is assumed to be open, see 'zipOpenTCvSubst'
-- | Type substitution, see 'zipTvSubst'
substTyWith :: [TyVar] -> [Type] -> Type -> Type
substTyWith tvs tys = ASSERT( length tvs == length tys )
substTyUnchecked (zipOpenTCvSubst tvs tys)
substTyUnchecked (zipTvSubst tvs tys)
-- | Substitute tyvars within a type using a known 'InScopeSet'.
-- Pre-condition: the 'in_scope' set should satisfy Note [The substitution
......@@ -1801,33 +1796,30 @@ substTyWithInScope in_scope tvs tys ty =
substTy (mkTCvSubst in_scope (tenv, emptyCvSubstEnv)) ty
where tenv = zipTyEnv tvs tys
-- | Coercion substitution making use of an 'TCvSubst' that
-- is assumed to be open, see 'zipOpenTCvSubst'
-- | Coercion substitution, see 'zipTvSubst'
substCoWith :: [TyVar] -> [Type] -> Coercion -> Coercion
substCoWith tvs tys = ASSERT( length tvs == length tys )
substCo (zipOpenTCvSubst tvs tys)
substCo (zipTvSubst tvs tys)
-- | Substitute covars within a type
substTyWithCoVars :: [CoVar] -> [Coercion] -> Type -> Type
substTyWithCoVars cvs cos = substTy (zipOpenTCvSubstCoVars cvs cos)
substTyWithCoVars cvs cos = substTy (zipCvSubst cvs cos)
-- | Type substitution making use of an 'TCvSubst' that
-- is assumed to be open, see 'zipOpenTCvSubst'
-- | Type substitution, see 'zipTvSubst'
substTysWith :: [TyVar] -> [Type] -> [Type] -> [Type]
substTysWith tvs tys = ASSERT( length tvs == length tys )
substTys (zipOpenTCvSubst tvs tys)
substTys (zipTvSubst tvs tys)
-- | Type substitution making use of an 'TCvSubst' that
-- is assumed to be open, see 'zipOpenTCvSubst'
-- | Type substitution, see 'zipTvSubst'
substTysWithCoVars :: [CoVar] -> [Coercion] -> [Type] -> [Type]
substTysWithCoVars cvs cos = ASSERT( length cvs == length cos )
substTys (zipOpenTCvSubstCoVars cvs cos)
substTys (zipCvSubst cvs cos)
-- | Type substitution using 'Binder's. Anonymous binders
-- simply ignore their matching type.
substTyWithBinders :: [TyBinder] -> [Type] -> Type -> Type
substTyWithBinders bndrs tys = ASSERT( length bndrs == length tys )
substTyUnchecked (zipOpenTCvSubstBinders bndrs tys)
substTyUnchecked (zipTyBinderSubst bndrs tys)
-- | Substitute within a 'Type' after adding the free variables of the type
-- to the in-scope set. This is useful for the case when the free variables
......
......@@ -150,7 +150,7 @@ module Type (
-- ** Manipulating type substitutions
emptyTvSubstEnv, emptyTCvSubst, mkEmptyTCvSubst,
mkTCvSubst, mkOpenTCvSubst, zipOpenTCvSubst, mkTopTCvSubst,
mkTCvSubst, zipTvSubst, mkTvSubstPrs,
notElemTCvSubst,
getTvSubstEnv, setTvSubstEnv,
zapTCvSubst, getTCvInScope,
......@@ -294,7 +294,7 @@ coreView :: Type -> Maybe Type
-- By being non-recursive and inlined, this case analysis gets efficiently
-- joined onto the case analysis that the caller is already doing
coreView (TyConApp tc tys) | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys
= Just (mkAppTys (substTy (mkTopTCvSubst tenv) rhs) tys')
= Just (mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys')
-- The free vars of 'rhs' should all be bound by 'tenv', so it's
-- ok to use 'substTy' here.
-- See also Note [The substitution invariant] in TyCoRep.
......@@ -326,7 +326,7 @@ expandTypeSynonyms ty
where
go subst (TyConApp tc tys)
| Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys
= let subst' = unionTCvSubst subst (mkTopTCvSubst tenv) in
= let subst' = unionTCvSubst subst (mkTvSubstPrs tenv) in
go subst' (mkAppTys rhs tys')
| otherwise
= TyConApp tc (map (go subst) tys)
......@@ -1015,7 +1015,7 @@ mkCastTy ty co = -- NB: don't check if the coercion "from" type matches here;
= let (bndrs, _inner_ki) = splitPiTys kind
(no_dep_bndrs, some_dep_bndrs) = spanEnd isAnonBinder bndrs
(some_dep_args, rest_args) = splitAtList some_dep_bndrs args
dep_subst = zipOpenTCvSubstBinders some_dep_bndrs some_dep_args
dep_subst = zipTyBinderSubst some_dep_bndrs some_dep_args
used_no_dep_bndrs = takeList rest_args no_dep_bndrs
rest_arg_tys = substTys dep_subst (map binderType used_no_dep_bndrs)
co' = mkFunCos Nominal
......@@ -1813,7 +1813,7 @@ mkFamilyTyConApp tc tys
| Just (fam_tc, fam_tys) <- tyConFamInst_maybe tc
, let tvs = tyConTyVars tc
fam_subst = ASSERT2( length tvs == length tys, ppr tc <+> ppr tys )
zipOpenTCvSubst tvs tys
zipTvSubst tvs tys
= mkTyConApp fam_tc (substTys fam_subst fam_tys)
| otherwise
= mkTyConApp tc tys
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment