Commit 5dcae88b authored by niteria's avatar niteria

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