Commit 5d095cc1 authored by simonpj's avatar simonpj

[project @ 2001-07-20 16:48:20 by simonpj]

This commit adds the very convenient function

  Subst.substTyWith :: [TyVar] -> [Type] -> Type -> Type

and uses it in various places.
parent e3defabc
......@@ -22,7 +22,7 @@ module DataCon (
#include "HsVersions.h"
import {-# SOURCE #-} Subst( substTy, mkTyVarSubst )
import {-# SOURCE #-} Subst( substTyWith )
import CmdLineOpts ( opt_DictsStrict )
import Type ( Type, TauType, ThetaType,
......@@ -324,7 +324,7 @@ dataConArgTys :: DataCon
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
......@@ -334,7 +334,7 @@ dataConTheta dc = dcTheta dc
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,
......
......@@ -24,7 +24,7 @@ import Literal ( literalType )
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,
......@@ -375,7 +375,7 @@ lintTyApp ty arg_ty
-- 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)
......
_interface_ Subst 1
_exports_ Subst Subst mkTyVarSubst substTy ;
_interface_ Subst 2
_exports_ Subst Subst substTyWith ;
_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 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 ;
......@@ -28,7 +28,7 @@ module Subst (
-- Type stuff
mkTyVarSubst, mkTopTyVarSubst,
substTy, substTheta,
substTyWith, substTy, substTheta,
-- Expression stuff
substExpr, substIdInfo
......@@ -373,7 +373,8 @@ type TyVarSubst = Subst -- TyVarSubst are expected to have range elements
-- 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
......@@ -392,6 +393,9 @@ zip_ty_env (tv:tvs) (ty:tys) env
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
......
......@@ -30,7 +30,7 @@ import Id ( idType, idName, isExportedId, isSpecPragmaId, Id )
import NameSet
import VarSet
import TcType ( mkTyVarTy )
import Subst ( mkTyVarSubst, substTy )
import Subst ( substTyWith )
import TysWiredIn ( voidTy )
import Outputable
import Maybe ( isJust )
......@@ -132,16 +132,16 @@ dsMonoBinds auto_scc (AbsBinds all_tyvars dicts exports inlines binds) rest
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
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.
......
......@@ -39,7 +39,7 @@ import RdrName ( RdrName, mkUnqual )
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,
......@@ -313,7 +313,7 @@ toHsType (NoteTy (SynNote ty@(TyConApp tycon tyargs)) real_ty)
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
......
......@@ -28,7 +28,7 @@ import ForeignCall ( CCallConv(..), ForeignCall(..), CCallSpec(..), CCallTarget(
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,
......@@ -812,7 +812,7 @@ ilxFunAppArgs env num_sofar funty args tail_call known_clo
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)
......
......@@ -64,7 +64,7 @@ import Name ( Name, mkMethodOcc, getOccName )
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(..) )
......@@ -391,7 +391,7 @@ newMethod orig id tys
= -- 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
......
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