X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypes%2FType.lhs;h=588c8b4cbfdda776ed95d0323e2c78d9a84675e0;hb=573ef10b2afd99d3c6a36370a9367609716c97d2;hp=bebf0f5c83d57388e799602660a9b4b8832f8db1;hpb=26741ec416bae2c502ef00a2ba0e79050a32cb67;p=ghc-hetmet.git

diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs
index bebf0f5..588c8b4 100644
--- a/ghc/compiler/types/Type.lhs
+++ b/ghc/compiler/types/Type.lhs
@@ -21,7 +21,7 @@ module Type (
 
 	SYN_IE(RhoType), SYN_IE(SigmaType), SYN_IE(ThetaType),
 	mkDictTy,
-	mkRhoTy, splitRhoTy, mkTheta,
+	mkRhoTy, splitRhoTy, mkTheta, isDictTy,
 	mkSigmaTy, splitSigmaTy,
 
 	maybeAppTyCon, getAppTyCon,
@@ -41,9 +41,9 @@ module Type (
     ) where
 
 IMP_Ubiq()
-IMPORT_DELOOPER(IdLoop)	 -- for paranoia checking
-IMPORT_DELOOPER(TyLoop)	 -- for paranoia checking
-IMPORT_DELOOPER(PrelLoop)  -- for paranoia checking
+--IMPORT_DELOOPER(IdLoop)	 -- for paranoia checking
+IMPORT_DELOOPER(TyLoop)
+--IMPORT_DELOOPER(PrelLoop)  -- for paranoia checking
 
 -- friends:
 import Class	( classSig, classOpLocalType, GenClass{-instances-} )
@@ -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,
@@ -72,8 +72,8 @@ import	{-mumble-}
 	Pretty
 import  {-mumble-}
 	PprStyle
-import	{-mumble-}
-	PprType --(pprType )
+--import	{-mumble-}
+--	PprType --(pprType )
 import  {-mumble-}
 	UniqFM (ufmToList )
 import {-mumble-}
@@ -281,8 +281,8 @@ mkTyConTy tycon
 
 applyTyCon :: TyCon -> [GenType t u] -> GenType t u
 applyTyCon tycon tys
-  = --ASSERT (not (isSynTyCon tycon))
-    (if (not (isSynTyCon tycon)) then \x->x else pprTrace "applyTyCon:" (pprTyCon PprDebug tycon)) $
+  = ASSERT (not (isSynTyCon tycon))
+    --(if (not (isSynTyCon tycon)) then \x->x else pprTrace "applyTyCon:" (pprTyCon PprDebug tycon)) $
     foldl AppTy (TyConTy tycon usageOmega) tys
 
 getTyCon_maybe		     :: GenType t u -> Maybe TyCon
@@ -348,7 +348,11 @@ mkTheta dict_tys
   = map cvt dict_tys
   where
     cvt (DictTy clas ty _) = (clas, ty)
-    cvt other		   = pprPanic "mkTheta:" (pprType PprDebug other)
+    cvt other		   = panic "Type.mkTheta" -- pprPanic "mkTheta:" (pprType PprDebug other)
+
+isDictTy (DictTy _ _ _) = True
+isDictTy (SynTy  _ _ t) = isDictTy t
+isDictTy _		= False
 \end{code}
 
 
@@ -612,20 +616,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}
@@ -668,7 +690,7 @@ typePrimRep (AppTy ty _)    = typePrimRep ty
 typePrimRep (TyConTy tc _)  
   | isPrimTyCon tc	    = case (assocMaybe tc_primrep_list (uniqueOf tc)) of
 				   Just xx -> xx
-				   Nothing -> pprPanic "typePrimRep:" (pprTyCon PprDebug tc)
+				   Nothing -> panic "Type.typePrimRep" -- pprPanic "typePrimRep:" (pprTyCon PprDebug tc)
 
   | otherwise		    = case maybeNewTyCon tc of
 				  Just (tyvars, ty) | isPrimType ty -> typePrimRep ty