[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.

9 files changed, 28 insertions, 26 deletions

diff --git a/ghc/compiler/basicTypes/DataCon.lhs b/ghc/compiler/basicTypes/DataCon.lhs
index 195c192747..f20fd527fc 100644
--- a/ghc/compiler/basicTypes/DataCon.lhs
+++ b/ghc/compiler/basicTypes/DataCon.lhs
@@ -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,
diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs
index e5744e1b17..03d4945fa4 100644
--- a/ghc/compiler/coreSyn/CoreLint.lhs
+++ b/ghc/compiler/coreSyn/CoreLint.lhs
@@ -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)
 
diff --git a/ghc/compiler/coreSyn/Subst.hi-boot b/ghc/compiler/coreSyn/Subst.hi-boot
index fe12bad7b6..e0627bb59f 100644
--- a/ghc/compiler/coreSyn/Subst.hi-boot
+++ b/ghc/compiler/coreSyn/Subst.hi-boot
@@ -1,7 +1,6 @@
-_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 ;;
 
diff --git a/ghc/compiler/coreSyn/Subst.hi-boot-5 b/ghc/compiler/coreSyn/Subst.hi-boot-5
index e959642b11..7be51e9c8f 100644
--- a/ghc/compiler/coreSyn/Subst.hi-boot-5
+++ b/ghc/compiler/coreSyn/Subst.hi-boot-5
@@ -1,6 +1,5 @@
-__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 ;
 
diff --git a/ghc/compiler/coreSyn/Subst.lhs b/ghc/compiler/coreSyn/Subst.lhs
index 1633362611..59a9ab5a3f 100644
--- a/ghc/compiler/coreSyn/Subst.lhs
+++ b/ghc/compiler/coreSyn/Subst.lhs
@@ -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
diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs
index fce09c1bc4..ddfbd6c187 100644
--- a/ghc/compiler/deSugar/DsBinds.lhs
+++ b/ghc/compiler/deSugar/DsBinds.lhs
@@ -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.
diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs
index af66087bb9..49040bfc0e 100644
--- a/ghc/compiler/hsSyn/HsTypes.lhs
+++ b/ghc/compiler/hsSyn/HsTypes.lhs
@@ -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
diff --git a/ghc/compiler/ilxGen/IlxGen.lhs b/ghc/compiler/ilxGen/IlxGen.lhs
index d59612e346..842d3c674d 100644
--- a/ghc/compiler/ilxGen/IlxGen.lhs
+++ b/ghc/compiler/ilxGen/IlxGen.lhs
@@ -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)
diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs
index ce99069829..2d46001a8d 100644
--- a/ghc/compiler/typecheck/Inst.lhs
+++ b/ghc/compiler/typecheck/Inst.lhs
@@ -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