This commit adds the very convenient function
Subst.substTyWith :: [TyVar] -> [Type] -> Type -> Type
and uses it in various places.
-import {-# SOURCE #-} Subst( substTy, mkTyVarSubst )
+import {-# SOURCE #-} Subst( substTyWith )
import CmdLineOpts ( opt_DictsStrict )
import Type ( Type, TauType, ThetaType,
import CmdLineOpts ( opt_DictsStrict )
import Type ( Type, TauType, ThetaType,
dataConArgTys (MkData {dcRepArgTys = arg_tys, dcTyVars = tyvars,
dcExTyVars = ex_tyvars}) inst_tys
dataConArgTys (MkData {dcRepArgTys = arg_tys, dcTyVars = tyvars,
dcExTyVars = ex_tyvars}) inst_tys
- = map (substTy (mkTyVarSubst (tyvars ++ ex_tyvars) inst_tys)) arg_tys
+ = map (substTyWith (tyvars ++ ex_tyvars) inst_tys) arg_tys
dataConTheta :: DataCon -> ThetaType
dataConTheta dc = dcTheta dc
dataConTheta :: DataCon -> ThetaType
dataConTheta dc = dcTheta dc
dataConInstOrigArgTys :: DataCon -> [Type] -> [Type]
dataConInstOrigArgTys (MkData {dcOrigArgTys = arg_tys, dcTyVars = tyvars,
dcExTyVars = ex_tyvars}) inst_tys
dataConInstOrigArgTys :: DataCon -> [Type] -> [Type]
dataConInstOrigArgTys (MkData {dcOrigArgTys = arg_tys, dcTyVars = tyvars,
dcExTyVars = ex_tyvars}) inst_tys
- = map (substTy (mkTyVarSubst (tyvars ++ ex_tyvars) inst_tys)) arg_tys
+ = map (substTyWith (tyvars ++ ex_tyvars) inst_tys) arg_tys
\end{code}
These two functions get the real argument types of the constructor,
\end{code}
These two functions get the real argument types of the constructor,
import DataCon ( dataConRepType )
import Var ( Var, Id, TyVar, idType, tyVarKind, isTyVar, isId, mustHaveLocalBinding )
import VarSet
import DataCon ( dataConRepType )
import Var ( Var, Id, TyVar, idType, tyVarKind, isTyVar, isId, mustHaveLocalBinding )
import VarSet
-import Subst ( mkTyVarSubst, substTy )
+import Subst ( substTyWith )
import Name ( getSrcLoc )
import PprCore
import ErrUtils ( doIfSet, dumpIfSet_core, ghcExit, Message, showPass,
import Name ( getSrcLoc )
import PprCore
import ErrUtils ( doIfSet, dumpIfSet_core, ghcExit, Message, showPass,
-- error :: forall a:*. String -> a
-- and then apply it to both boxed and unboxed types.
then
-- error :: forall a:*. String -> a
-- and then apply it to both boxed and unboxed types.
then
- returnL (substTy (mkTyVarSubst [tyvar] [arg_ty]) body)
+ returnL (substTyWith [tyvar] [arg_ty] body)
else
addErrL (mkKindErrMsg tyvar arg_ty)
else
addErrL (mkKindErrMsg tyvar arg_ty)
-_interface_ Subst 1
-_exports_ Subst Subst mkTyVarSubst substTy ;
+_interface_ Subst 2
+_exports_ Subst Subst substTyWith ;
_declarations_
1 data Subst;
_declarations_
1 data Subst;
-1 mkTyVarSubst _:_ [Var.TyVar] -> [TypeRep.Type] -> Subst ;;
-1 substTy _:_ Subst -> TypeRep.Type -> TypeRep.Type ;;
+1 substTyWith _:_ [Var.TyVar] -> [TypeRep.Type] -> TypeRep.Type -> TypeRep.Type ;;
-__interface Subst 1 0 where
-__export Subst Subst mkTyVarSubst substTy ;
+__interface Subst 2 0 where
+__export Subst Subst substTyWith ;
-1 mkTyVarSubst :: [Var.TyVar] -> [TypeRep.Type] -> Subst ;
-1 substTy :: Subst -> TypeRep.Type -> TypeRep.Type ;
+1 substTyWith :: [Var.TyVar] -> [TypeRep.Type] -> TypeRep.Type -> TypeRep.Type ;
-- Type stuff
mkTyVarSubst, mkTopTyVarSubst,
-- Type stuff
mkTyVarSubst, mkTopTyVarSubst,
+ substTyWith, substTy, substTheta,
-- Expression stuff
substExpr, substIdInfo
-- Expression stuff
substExpr, substIdInfo
-- the types given; but it's just a thunk so with a bit of luck
-- it'll never be evaluated
mkTyVarSubst :: [TyVar] -> [Type] -> Subst
-- the types given; but it's just a thunk so with a bit of luck
-- it'll never be evaluated
mkTyVarSubst :: [TyVar] -> [Type] -> Subst
-mkTyVarSubst tyvars tys = Subst (mkInScopeSet (tyVarsOfTypes tys)) (zip_ty_env tyvars tys emptySubstEnv)
+mkTyVarSubst tyvars tys = Subst (mkInScopeSet (tyVarsOfTypes tys))
+ (zip_ty_env tyvars tys emptySubstEnv)
-- mkTopTyVarSubst is called when doing top-level substitutions.
-- Here we expect that the free vars of the range of the
-- mkTopTyVarSubst is called when doing top-level substitutions.
-- Here we expect that the free vars of the range of the
substTy works with general Substs, so that it can be called from substExpr too.
\begin{code}
substTy works with general Substs, so that it can be called from substExpr too.
\begin{code}
+substTyWith :: [TyVar] -> [Type] -> Type -> Type
+substTyWith tvs tys = substTy (mkTyVarSubst tvs tys)
+
substTy :: Subst -> Type -> Type
substTy subst ty | isEmptySubst subst = ty
| otherwise = subst_ty subst ty
substTy :: Subst -> Type -> Type
substTy subst ty | isEmptySubst subst = ty
| otherwise = subst_ty subst ty
import NameSet
import VarSet
import TcType ( mkTyVarTy )
import NameSet
import VarSet
import TcType ( mkTyVarTy )
-import Subst ( mkTyVarSubst, substTy )
+import Subst ( substTyWith )
import TysWiredIn ( voidTy )
import Outputable
import Maybe ( isJust )
import TysWiredIn ( voidTy )
import Outputable
import Maybe ( isJust )
mk_bind (tyvars, global, local) n -- locals !! n == local
= -- Need to make fresh locals to bind in the selector, because
-- some of the tyvars will be bound to voidTy
mk_bind (tyvars, global, local) n -- locals !! n == local
= -- Need to make fresh locals to bind in the selector, because
-- some of the tyvars will be bound to voidTy
- newSysLocalsDs (map (substTy env) local_tys) `thenDs` \ locals' ->
- newSysLocalDs (substTy env tup_ty) `thenDs` \ tup_id ->
+ newSysLocalsDs (map substitute local_tys) `thenDs` \ locals' ->
+ newSysLocalDs (substitute tup_ty) `thenDs` \ tup_id ->
returnDs (global, mkLams tyvars $ mkLams dicts $
mkTupleSelector locals' (locals' !! n) tup_id $
mkApps (mkTyApps (Var poly_tup_id) ty_args) dict_args)
where
mk_ty_arg all_tyvar | all_tyvar `elem` tyvars = mkTyVarTy all_tyvar
| otherwise = voidTy
returnDs (global, mkLams tyvars $ mkLams dicts $
mkTupleSelector locals' (locals' !! n) tup_id $
mkApps (mkTyApps (Var poly_tup_id) ty_args) dict_args)
where
mk_ty_arg all_tyvar | all_tyvar `elem` tyvars = mkTyVarTy all_tyvar
| otherwise = voidTy
- ty_args = map mk_ty_arg all_tyvars
- env = mkTyVarSubst all_tyvars ty_args
+ ty_args = map mk_ty_arg all_tyvars
+ substitute = substTyWith all_tyvars ty_args
in
zipWithDs mk_bind exports [0..] `thenDs` \ export_binds ->
-- don't scc (auto-)annotate the tuple itself.
in
zipWithDs mk_bind exports [0..] `thenDs` \ export_binds ->
-- don't scc (auto-)annotate the tuple itself.
import Name ( Name, getName )
import OccName ( NameSpace, tvName )
import Var ( TyVar, tyVarKind )
import Name ( Name, getName )
import OccName ( NameSpace, tvName )
import Var ( TyVar, tyVarKind )
-import Subst ( mkTyVarSubst, substTy )
+import Subst ( substTyWith )
import PprType ( {- instance Outputable Kind -}, pprParendKind )
import BasicTypes ( Boxity(..), Arity, tupleParens )
import PrelNames ( mkTupConRdrName, listTyConKey, usOnceTyConKey, usManyTyConKey, hasKey,
import PprType ( {- instance Outputable Kind -}, pprParendKind )
import BasicTypes ( Boxity(..), Arity, tupleParens )
import PrelNames ( mkTupConRdrName, listTyConKey, usOnceTyConKey, usManyTyConKey, hasKey,
where
syn_matches = ty_from_syn `tcEqType` real_ty
(tyvars,syn_ty) = getSynTyConDefn tycon
where
syn_matches = ty_from_syn `tcEqType` real_ty
(tyvars,syn_ty) = getSynTyConDefn tycon
- ty_from_syn = substTy (mkTyVarSubst tyvars tyargs) syn_ty
+ ty_from_syn = substTyWith tyvars tyargs syn_ty
-- We only use the type synonym in the file if this doesn't cause
-- us to lose important information. This matters for usage
-- We only use the type synonym in the file if this doesn't cause
-- us to lose important information. This matters for usage
import TysWiredIn ( mkTupleTy, tupleCon )
import PrimRep ( PrimRep(..) )
import Name ( nameModule, nameOccName, isGlobalName, isLocalName, NamedThing(getName) )
import TysWiredIn ( mkTupleTy, tupleCon )
import PrimRep ( PrimRep(..) )
import Name ( nameModule, nameOccName, isGlobalName, isLocalName, NamedThing(getName) )
-import Subst ( substTy, mkTyVarSubst )
+import Subst ( substTyWith )
import Module ( Module, PackageName, ModuleName, moduleName,
modulePackage, preludePackage,
import Module ( Module, PackageName, ModuleName, moduleName,
modulePackage, preludePackage,
get_type_args max ((arg@(StgTypeArg v)):rest) env (ForAllTy tv rem_funty)
= if isIlxTyVar tv then
let env2 = extendIlxEnvWithFormalTyVars env [tv] in
get_type_args max ((arg@(StgTypeArg v)):rest) env (ForAllTy tv rem_funty)
= if isIlxTyVar tv then
let env2 = extendIlxEnvWithFormalTyVars env [tv] in
- let rest_ty = deepIlxRepType (substTy (mkTyVarSubst [tv] [v]) rem_funty) in
+ let rest_ty = deepIlxRepType (substTyWith [tv] [v] rem_funty) in
let (now,now_tys,env3,later,later_ty) = get_type_args (max - 1) rest env rest_ty in
let arg_ty = mkTyVarTy tv in
(arg:now,(arg,arg_ty):now_tys,env2, later, later_ty)
let (now,now_tys,env3,later,later_ty) = get_type_args (max - 1) rest env rest_ty in
let arg_ty = mkTyVarTy tv in
(arg:now,(arg,arg_ty):now_tys,env2, later, later_ty)
import NameSet ( NameSet )
import PprType ( pprPred )
import Subst ( emptyInScopeSet, mkSubst,
import NameSet ( NameSet )
import PprType ( pprPred )
import Subst ( emptyInScopeSet, mkSubst,
- substTy, substTheta, mkTyVarSubst, mkTopTyVarSubst
+ substTy, substTyWith, substTheta, mkTyVarSubst, mkTopTyVarSubst
)
import Literal ( inIntRange )
import VarEnv ( TidyEnv, lookupSubstEnv, SubstResult(..) )
)
import Literal ( inIntRange )
import VarEnv ( TidyEnv, lookupSubstEnv, SubstResult(..) )
= -- Get the Id type and instantiate it at the specified types
let
(tyvars, rho) = tcSplitForAllTys (idType id)
= -- Get the Id type and instantiate it at the specified types
let
(tyvars, rho) = tcSplitForAllTys (idType id)
- rho_ty = substTy (mkTyVarSubst tyvars tys) rho
+ rho_ty = substTyWith tyvars tys rho
(pred, tau) = tcSplitMethodTy rho_ty
in
newMethodWithGivenTy orig id tys [pred] tau
(pred, tau) = tcSplitMethodTy rho_ty
in
newMethodWithGivenTy orig id tys [pred] tau