[project @ 1996-07-15 11:32:34 by partain]

[ghc-hetmet.git] / ghc / compiler / types / Type.lhs

diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs
index bebf0f5..588c8b4 100644 (file)
--- 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