Commit 850ae8c5 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Two small refactorings

* Define Type.substTyVarBndrs, and use it

* Rename substTyVarBndrCallback to substTyVarBndrUsing,
  and other analogous higher order functions.  I kept
  stumbling over the name.
parent d6216443
......@@ -86,7 +86,7 @@ import Unique( mkAlphaTyVarUnique )
import qualified Data.Data as Data
import Data.Char
import Data.Word
import Data.List( mapAccumL, find )
import Data.List( find )
import qualified Data.Set as Set
{-
......@@ -1189,7 +1189,7 @@ dataConInstSig (MkData { dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs
, substTys subst arg_tys)
where
univ_subst = zipTvSubst univ_tvs univ_tys
(subst, ex_tvs') = mapAccumL Type.substTyVarBndr univ_subst ex_tvs
(subst, ex_tvs') = Type.substTyVarBndrs univ_subst ex_tvs
-- | The \"full signature\" of the 'DataCon' returns, in order:
......
......@@ -642,8 +642,7 @@ deriveStandalone (L loc (DerivDecl _ deriv_ty mbl_deriv_strat overlap_mode))
unmapped_tkvs = filter (\v -> v `notElemTCvSubst` kind_subst
&& not (v `elemVarSet` ki_subst_range))
tvs'
(subst, _) = mapAccumL substTyVarBndr
kind_subst unmapped_tkvs
(subst, _) = substTyVarBndrs kind_subst unmapped_tkvs
(final_deriv_ctxt, final_deriv_ctxt_tys)
= case deriv_ctxt' of
InferContext wc -> (InferContext wc, [])
......@@ -813,8 +812,7 @@ deriveTyData tvs tc tc_args mb_deriv_strat deriv_pred
unmapped_tkvs = filter (\v -> v `notElemTCvSubst` kind_subst
&& not (v `elemVarSet` ki_subst_range))
tkvs'
(subst, _) = mapAccumL substTyVarBndr
kind_subst unmapped_tkvs
(subst, _) = substTyVarBndrs kind_subst unmapped_tkvs
final_tc_args = substTys subst tc_args'
final_cls_tys = substTys subst cls_tys'
final_tkvs = tyCoVarsOfTypesWellScoped $
......@@ -1035,7 +1033,7 @@ the type variable binder for c, since its kind is (k2 -> k2 -> *).
We used to accomplish this by doing the following:
unmapped_tkvs = filter (`notElemTCvSubst` kind_subst) all_tkvs
(subst, _) = mapAccumL substTyVarBndr kind_subst unmapped_tkvs
(subst, _) = substTyVarBndrs kind_subst unmapped_tkvs
Where all_tkvs contains all kind variables in the class and instance types (in
this case, all_tkvs = [k1,k2]). But since kind_subst only has one mapping,
......
......@@ -148,7 +148,7 @@ inferConstraintsDataConArgs inst_ty inst_tys
emptyTCvSubst (catMaybes mbSubsts)
unmapped_tvs = filter (\v -> v `notElemTCvSubst` subst
&& not (v `isInScope` subst)) tvs
(subst', _) = mapAccumL substTyVarBndr subst unmapped_tvs
(subst', _) = substTyVarBndrs subst unmapped_tvs
preds' = map (substPredOrigin subst') preds
inst_tys' = substTys subst' inst_tys
tvs' = tyCoVarsOfTypesWellScoped inst_tys'
......
......@@ -103,7 +103,7 @@ import ErrUtils
import Util
import Unique
import VarSet
import Data.List ( find, mapAccumL )
import Data.List ( find )
import Data.Maybe
import FastString
import BasicTypes hiding( SuccessFlag(..) )
......@@ -1495,8 +1495,7 @@ reifyDataCon isGadtDataCon tys dc
-- See Note [Freshen reified GADT constructors' universal tyvars]
<- freshenTyVarBndrs $
filterOut (`elemVarSet` eq_spec_tvs) g_univ_tvs
; let (tvb_subst, g_user_tvs)
= mapAccumL substTyVarBndr univ_subst g_user_tvs'
; let (tvb_subst, g_user_tvs) = substTyVarBndrs univ_subst g_user_tvs'
g_theta = substTys tvb_subst g_theta'
g_arg_tys = substTys tvb_subst g_arg_tys'
g_res_ty = substTy tvb_subst g_res_ty'
......
......@@ -2147,8 +2147,7 @@ rejigConRes tmpl_bndrs res_tmpl dc_inferred_tvs dc_specified_tvs res_ty
tcMatchTy res_tmpl res_ty
= let (univ_tvs, raw_eqs, kind_subst) = mkGADTVars tmpl_tvs dc_tvs subst
raw_ex_tvs = dc_tvs `minusList` univ_tvs
(arg_subst, substed_ex_tvs)
= mapAccumL substTyVarBndr kind_subst raw_ex_tvs
(arg_subst, substed_ex_tvs) = substTyVarBndrs kind_subst raw_ex_tvs
-- After rejigging the existential tyvars, the resulting substitution
-- gives us exactly what we need to rejig the user-written tyvars,
......
......@@ -81,10 +81,10 @@ module Coercion (
-- ** Lifting
liftCoSubst, liftCoSubstTyVar, liftCoSubstWith, liftCoSubstWithEx,
emptyLiftingContext, extendLiftingContext, extendLiftingContextAndInScope,
liftCoSubstVarBndrCallback, isMappedByLC,
liftCoSubstVarBndrUsing, isMappedByLC,
mkSubstLiftingContext, zapLiftingContext,
substForAllCoBndrCallbackLC, lcTCvSubst, lcInScopeSet,
substForAllCoBndrUsingLC, lcTCvSubst, lcInScopeSet,
LiftCoEnv, LiftingContext(..), liftEnvSubstLeft, liftEnvSubstRight,
substRightCo, substLeftCo, swapLiftCoEnv, lcSubstLeft, lcSubstRight,
......@@ -1621,14 +1621,14 @@ zapLiftingContext :: LiftingContext -> LiftingContext
zapLiftingContext (LC subst _) = LC (zapTCvSubst subst) emptyVarEnv
-- | Like 'substForAllCoBndr', but works on a lifting context
substForAllCoBndrCallbackLC :: Bool
substForAllCoBndrUsingLC :: Bool
-> (Coercion -> Coercion)
-> LiftingContext -> TyVar -> Coercion
-> (LiftingContext, TyVar, Coercion)
substForAllCoBndrCallbackLC sym sco (LC subst lc_env) tv co
substForAllCoBndrUsingLC sym sco (LC subst lc_env) tv co
= (LC subst' lc_env, tv', co')
where
(subst', tv', co') = substForAllCoBndrCallback sym sco subst tv co
(subst', tv', co') = substForAllCoBndrUsing sym sco subst tv co
-- | The \"lifting\" operation which substitutes coercions for type
-- variables in a type to produce a coercion.
......@@ -1687,16 +1687,16 @@ liftCoSubstTyVar (LC subst env) r v
liftCoSubstVarBndr :: LiftingContext -> TyVar
-> (LiftingContext, TyVar, Coercion)
liftCoSubstVarBndr lc tv
= let (lc', tv', h, _) = liftCoSubstVarBndrCallback callback lc tv in
= let (lc', tv', h, _) = liftCoSubstVarBndrUsing callback lc tv in
(lc', tv', h)
where
callback lc' ty' = (ty_co_subst lc' Nominal ty', ())
-- the callback must produce a nominal coercion
liftCoSubstVarBndrCallback :: (LiftingContext -> Type -> (Coercion, a))
liftCoSubstVarBndrUsing :: (LiftingContext -> Type -> (Coercion, a))
-> LiftingContext -> TyVar
-> (LiftingContext, TyVar, Coercion, a)
liftCoSubstVarBndrCallback fun lc@(LC subst cenv) old_var
liftCoSubstVarBndrUsing fun lc@(LC subst cenv) old_var
= ( LC (subst `extendTCvInScope` new_var) new_cenv
, new_var, eta, stuff )
where
......
......@@ -1205,7 +1205,7 @@ Type) pairs.
We also benefit because we can piggyback on the liftCoSubstVarBndr function to
deal with binders. However, I had to modify that function to work with this
application. Thus, we now have liftCoSubstVarBndrCallback, which takes
application. Thus, we now have liftCoSubstVarBndrUsing, which takes
a function used to process the kind of the binder. We don't wish
to lift the kind, but instead normalise it. So, we pass in a callback function
that processes the kind of the binder.
......@@ -1401,7 +1401,7 @@ normalise_tyvar_bndr tv
= do { lc1 <- getLC
; env <- getEnv
; let callback lc ki = runNormM (normalise_type ki) env lc Nominal
; return $ liftCoSubstVarBndrCallback callback lc1 tv }
; return $ liftCoSubstVarBndrUsing callback lc1 tv }
-- | a monad for the normalisation functions, reading 'FamInstEnvs',
-- a 'LiftingContext', and a 'Role'.
......
......@@ -1043,4 +1043,4 @@ and these two imply
optForAllCoBndr :: LiftingContext -> Bool
-> TyVar -> Coercion -> (LiftingContext, TyVar, Coercion)
optForAllCoBndr env sym
= substForAllCoBndrCallbackLC sym (opt_co4_wrap env sym False Nominal) env
= substForAllCoBndrUsingLC sym (opt_co4_wrap env sym False Nominal) env
......@@ -112,12 +112,12 @@ module TyCoRep (
substCoUnchecked, substCoWithUnchecked,
substTyWithInScope,
substTys, substTheta,
lookupTyVar, substTyVarBndr,
lookupTyVar, substTyVarBndr, substTyVarBndrs,
substCo, substCos, substCoVar, substCoVars, lookupCoVar,
substCoVarBndr, cloneTyVarBndr, cloneTyVarBndrs,
substTyVar, substTyVars,
substForAllCoBndr,
substTyVarBndrCallback, substForAllCoBndrCallback,
substTyVarBndrUsing, substForAllCoBndrUsing,
checkValidSubst, isValidTCvSubst,
-- * Tidying type related things up for printing
......@@ -2290,17 +2290,15 @@ isValidTCvSubst (TCvSubst in_scope tenv cenv) =
checkValidSubst :: HasCallStack => TCvSubst -> [Type] -> [Coercion] -> a -> a
checkValidSubst subst@(TCvSubst in_scope tenv cenv) tys cos a
-- TODO (RAE): Change back to ASSERT
= WARN( not ({-#SCC "isValidTCvSubst" #-} isValidTCvSubst subst),
= WARN( not (isValidTCvSubst subst),
text "in_scope" <+> ppr in_scope $$
text "tenv" <+> ppr tenv $$
text "tenvFVs"
<+> ppr (tyCoVarsOfTypesSet tenv) $$
text "tenvFVs" <+> ppr (tyCoVarsOfTypesSet tenv) $$
text "cenv" <+> ppr cenv $$
text "cenvFVs"
<+> ppr (tyCoVarsOfCosSet cenv) $$
text "cenvFVs" <+> ppr (tyCoVarsOfCosSet cenv) $$
text "tys" <+> ppr tys $$
text "cos" <+> ppr cos )
WARN( not ({-#SCC "tysCosFVsInScope" #-} tysCosFVsInScope),
WARN( not tysCosFVsInScope,
text "in_scope" <+> ppr in_scope $$
text "tenv" <+> ppr tenv $$
text "cenv" <+> ppr cenv $$
......@@ -2481,7 +2479,7 @@ subst_co subst co
substForAllCoBndr :: TCvSubst -> TyVar -> Coercion -> (TCvSubst, TyVar, Coercion)
substForAllCoBndr subst
= substForAllCoBndrCallback False (substCo subst) subst
= substForAllCoBndrUsing False (substCo subst) subst
-- | Like 'substForAllCoBndr', but disables sanity checks.
-- The problems that the sanity checks in substCo catch are described in
......@@ -2490,14 +2488,14 @@ substForAllCoBndr subst
-- substCo and remove this function. Please don't use in new code.
substForAllCoBndrUnchecked :: TCvSubst -> TyVar -> Coercion -> (TCvSubst, TyVar, Coercion)
substForAllCoBndrUnchecked subst
= substForAllCoBndrCallback False (substCoUnchecked subst) subst
= substForAllCoBndrUsing False (substCoUnchecked subst) subst
-- See Note [Sym and ForAllCo]
substForAllCoBndrCallback :: Bool -- apply sym to binder?
substForAllCoBndrUsing :: Bool -- apply sym to binder?
-> (Coercion -> Coercion) -- transformation to kind co
-> TCvSubst -> TyVar -> Coercion
-> (TCvSubst, TyVar, Coercion)
substForAllCoBndrCallback sym sco (TCvSubst in_scope tenv cenv)
substForAllCoBndrUsing sym sco (TCvSubst in_scope tenv cenv)
old_var old_kind_co
= ( TCvSubst (in_scope `extendInScopeSet` new_var) new_env cenv
, new_var, new_kind_co )
......@@ -2530,7 +2528,10 @@ lookupCoVar :: TCvSubst -> Var -> Maybe Coercion
lookupCoVar (TCvSubst _ _ cenv) v = lookupVarEnv cenv v
substTyVarBndr :: HasCallStack => TCvSubst -> TyVar -> (TCvSubst, TyVar)
substTyVarBndr = substTyVarBndrCallback substTy
substTyVarBndr = substTyVarBndrUsing substTy
substTyVarBndrs :: HasCallStack => TCvSubst -> [TyVar] -> (TCvSubst, [TyVar])
substTyVarBndrs = mapAccumL substTyVarBndr
-- | Like 'substTyVarBndr' but disables sanity checks.
-- The problems that the sanity checks in substTy catch are described in
......@@ -2538,13 +2539,15 @@ substTyVarBndr = substTyVarBndrCallback substTy
-- The goal of #11371 is to migrate all the calls of substTyUnchecked to
-- substTy and remove this function. Please don't use in new code.
substTyVarBndrUnchecked :: TCvSubst -> TyVar -> (TCvSubst, TyVar)
substTyVarBndrUnchecked = substTyVarBndrCallback substTyUnchecked
substTyVarBndrUnchecked = substTyVarBndrUsing substTyUnchecked
-- | Substitute a tyvar in a binding position, returning an
-- extended subst and a new tyvar.
substTyVarBndrCallback :: (TCvSubst -> Type -> Type) -- ^ the subst function
-> TCvSubst -> TyVar -> (TCvSubst, TyVar)
substTyVarBndrCallback subst_fn subst@(TCvSubst in_scope tenv cenv) old_var
-- Use the supplied function to substitute in the kind
substTyVarBndrUsing
:: (TCvSubst -> Type -> Type) -- ^ Use this to substitute in the kind
-> TCvSubst -> TyVar -> (TCvSubst, TyVar)
substTyVarBndrUsing subst_fn subst@(TCvSubst in_scope tenv cenv) old_var
= ASSERT2( _no_capture, pprTyVar old_var $$ pprTyVar new_var $$ ppr subst )
ASSERT( isTyVar old_var )
(TCvSubst (in_scope `extendInScopeSet` new_var) new_env cenv, new_var)
......
......@@ -177,7 +177,7 @@ module Type (
substTyUnchecked, substTysUnchecked, substThetaUnchecked,
substTyWithUnchecked,
substCoUnchecked, substCoWithUnchecked,
substTyVarBndr, substTyVar, substTyVars,
substTyVarBndr, substTyVarBndrs, substTyVar, substTyVars,
cloneTyVarBndr, cloneTyVarBndrs, lookupTyVar,
-- * Pretty-printing
......@@ -398,7 +398,7 @@ expandTypeSynonyms ty
go subst (FunTy arg res)
= mkFunTy (go subst arg) (go subst res)
go subst (ForAllTy (TvBndr tv vis) t)
= let (subst', tv') = substTyVarBndrCallback go subst tv in
= let (subst', tv') = substTyVarBndrUsing go subst tv in
ForAllTy (TvBndr tv' vis) (go subst' t)
go subst (CastTy ty co) = mkCastTy (go subst ty) (go_co subst co)
go subst (CoercionTy co) = mkCoercionTy (go_co subst co)
......@@ -448,10 +448,10 @@ expandTypeSynonyms ty
go_prov _ p@(PluginProv _) = p
-- the "False" and "const" are to accommodate the type of
-- substForAllCoBndrCallback, which is general enough to
-- substForAllCoBndrUsing, which is general enough to
-- handle coercion optimization (which sometimes swaps the
-- order of a coercion)
go_cobndr subst = substForAllCoBndrCallback False (go_co subst) subst
go_cobndr subst = substForAllCoBndrUsing False (go_co subst) subst
{-
************************************************************************
......
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