Commit 9d4c0380 authored by partain's avatar partain
Browse files

[project @ 1996-06-30 15:56:44 by partain]

partain 1.3 changes through 960629
parent da3d8948
......@@ -18,7 +18,7 @@ import TcMonad hiding ( rnMtoTcM )
import Type ( GenType(..), typeKind, mkFunTy, getFunTy_maybe )
import TyCon ( TyCon, mkFunTyCon )
import TyVar ( GenTyVar(..), SYN_IE(TyVar), tyVarKind )
import TcType ( TcType(..), TcMaybe(..), TcTauType(..), TcTyVar(..),
import TcType ( SYN_IE(TcType), TcMaybe(..), SYN_IE(TcTauType), SYN_IE(TcTyVar),
newTyVarTy, tcReadTyVar, tcWriteTyVar, zonkTcType
)
-- others:
......
......@@ -14,7 +14,7 @@ module TyVar (
-- TyVars and "sets" containing TyVars:
SYN_IE(TyVarEnv),
nullTyVarEnv, mkTyVarEnv, addOneToTyVarEnv,
growTyVarEnvList, isNullTyVarEnv, lookupTyVarEnv,
growTyVarEnvList, isNullTyVarEnv, lookupTyVarEnv, delFromTyVarEnv,
SYN_IE(GenTyVarSet), SYN_IE(TyVarSet),
emptyTyVarSet, unitTyVarSet, unionTyVarSets,
......@@ -33,7 +33,7 @@ import Kind ( Kind, mkBoxedTypeKind, mkTypeKind )
-- others
import UniqSet -- nearly all of it
import UniqFM ( emptyUFM, listToUFM, addToUFM, lookupUFM,
plusUFM, sizeUFM, UniqFM
plusUFM, sizeUFM, delFromUFM, UniqFM
)
import Name ( mkLocalName, changeUnique, Name, RdrName(..) )
import Pretty ( SYN_IE(Pretty), PrettyRep, ppBeside, ppPStr )
......@@ -107,11 +107,13 @@ addOneToTyVarEnv :: TyVarEnv a -> GenTyVar flexi -> a -> TyVarEnv a
growTyVarEnvList :: TyVarEnv a -> [(GenTyVar flexi, a)] -> TyVarEnv a
isNullTyVarEnv :: TyVarEnv a -> Bool
lookupTyVarEnv :: TyVarEnv a -> GenTyVar flexi -> Maybe a
delFromTyVarEnv :: TyVarEnv a -> GenTyVar flexi -> TyVarEnv a
nullTyVarEnv = emptyUFM
mkTyVarEnv = listToUFM
addOneToTyVarEnv = addToUFM
lookupTyVarEnv = lookupUFM
delFromTyVarEnv = delFromUFM
growTyVarEnvList env pairs = plusUFM env (listToUFM pairs)
isNullTyVarEnv env = sizeUFM env == 0
......
......@@ -53,7 +53,7 @@ import TyCon ( mkFunTyCon, mkTupleTyCon, isFunTyCon,
tyConKind, tyConDataCons, getSynTyConDefn, TyCon )
import TyVar ( tyVarKind, GenTyVar{-instances-}, SYN_IE(GenTyVarSet),
emptyTyVarSet, unionTyVarSets, minusTyVarSet,
unitTyVarSet, nullTyVarEnv, lookupTyVarEnv,
unitTyVarSet, nullTyVarEnv, lookupTyVarEnv, delFromTyVarEnv,
addOneToTyVarEnv, SYN_IE(TyVarEnv), SYN_IE(TyVar) )
import Usage ( usageOmega, GenUsage, SYN_IE(Usage), SYN_IE(UVar), SYN_IE(UVarEnv),
nullUVarEnv, addOneToUVarEnv, lookupUVarEnv, eqUVar,
......@@ -612,20 +612,38 @@ instantiateTauTy tenv ty
bound_forall_tv_BAD = panic "instantiateTauTy:bound_forall_tv"
deflt_forall_tv tv = panic "instantiateTauTy:deflt_forall_tv"
-- applyTypeEnv applies a type environment to a type.
-- It can handle shadowing; for example:
-- f = /\ t1 t2 -> \ d ->
-- letrec f' = /\ t1 -> \x -> ...(f' t1 x')...
-- in f' t1
-- Here, when we clone t1 to t1', say, we'll come across shadowing
-- when applying the clone environment to the type of f'.
--
-- As a sanity check, we should also check that name capture
-- doesn't occur, but that means keeping track of the free variables of the
-- range of the TyVarEnv, which I don't do just yet.
--
-- We don't use instant_help because we need to carry in the environment
applyTypeEnvToTy tenv ty
= instant_help ty lookup_tv deflt_tv choose_tycon
if_usage if_forall bound_forall_tv_BAD deflt_forall_tv
= go tenv ty
where
lookup_tv = lookupTyVarEnv tenv
deflt_tv tv = TyVarTy tv
choose_tycon ty _ _ = ty
if_usage ty = ty
if_forall ty = ty
bound_forall_tv_BAD = False -- ToDo: probably should be True (i.e., no shadowing)
deflt_forall_tv tv = case (lookup_tv tv) of
Nothing -> tv
Just (TyVarTy tv2) -> tv2
_ -> pprPanic "applyTypeEnvToTy:" (ppAbove (ppr PprShowAll tv) (ppr PprShowAll ty))
go tenv ty@(TyVarTy tv) = case (lookupTyVarEnv tenv tv) of
Nothing -> ty
Just ty -> ty
go tenv ty@(TyConTy tycon usage) = ty
go tenv (SynTy tycon tys ty) = SynTy tycon (map (go tenv) tys) (go tenv ty)
go tenv (FunTy arg res usage) = FunTy (go tenv arg) (go tenv res) usage
go tenv (AppTy fun arg) = AppTy (go tenv fun) (go tenv arg)
go tenv (DictTy clas ty usage) = DictTy clas (go tenv ty) usage
go tenv (ForAllUsageTy uvar bds ty) = ForAllUsageTy uvar bds (go tenv ty)
go tenv (ForAllTy tv ty) = ForAllTy tv (go tenv' ty)
where
tenv' = case lookupTyVarEnv tenv tv of
Nothing -> tenv
Just _ -> delFromTyVarEnv tenv tv
\end{code}
\begin{code}
......
......@@ -2,10 +2,8 @@
interface Ubiq_1_3 1
__exports__
GHCbase trace (..)
GHCbase PrimIO -- this is here because of the bug preventing it getting into PreludeGlaST
GHCps tailPS (..)
GHCps nilPS (..)
-- GHCps substrPS (..)
-- GHCps tailPS (..)
GHCps appendPS (..)
GHCps concatPS (..)
GHCps consPS (..)
......@@ -21,6 +19,7 @@ BinderInfo BinderInfo
CLabel CLabel
Class Class
ClosureInfo ClosureInfo
CmdLineOpts SwitchResult
CoreSyn GenCoreExpr
CoreUnfold UnfoldingDetails
CoreUnfold UnfoldingGuidance
......@@ -50,6 +49,7 @@ Name OrigName (..)
Name RdrName (..)
Outputable Outputable (..)
PprStyle PprStyle
PragmaInfo PragmaInfo
PrimOp PrimOp
PrimRep PrimRep
SrcLoc SrcLoc
......
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