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

diff --git a/ghc/compiler/basicTypes/DataCon.lhs b/ghc/compiler/basicTypes/DataCon.lhs
index 195c192..f20fd52 100644 (file)
--- 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 e5744e1..03d4945 100644 (file)
--- 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 fe12bad..e0627bb 100644 (file)
--- 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 e959642..7be51e9 100644 (file)
--- 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 1633362..59a9ab5 100644 (file)
--- 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 fce09c1..ddfbd6c 100644 (file)
--- 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 af66087..49040bf 100644 (file)
--- 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 d59612e..842d3c6 100644 (file)
--- 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 ce99069..2d46001 100644 (file)
--- 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