X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSMonad.lhs;h=a71548c912216c468b6c4b4ef11d1dc438705aa0;hb=cd2f5397bc1345fc37706168c268a8bd37af7f2f;hp=4965a931467b089ab304871cc8565197c6606efe;hpb=5db036090509ab6acfd327a8ecb51a4abeed105a;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs
index 4965a93..a71548c 100644
--- a/compiler/typecheck/TcSMonad.lhs
+++ b/compiler/typecheck/TcSMonad.lhs
@@ -31,11 +31,12 @@ module TcSMonad (
  
     getInstEnvs, getFamInstEnvs,                -- Getting the environments 
     getTopEnv, getGblEnv, getTcEvBinds, getUntouchablesTcS,
-    getTcEvBindsBag, getTcSContext, getTcSTyBinds,
+    getTcEvBindsBag, getTcSContext, getTcSTyBinds, getTcSTyBindsMap,
 
 
     newFlattenSkolemTy,                         -- Flatten skolems 
 
+
     instDFunTypes,                              -- Instantiation
     instDFunConstraints,                        
 
@@ -63,7 +64,6 @@ module TcSMonad (
 
 import HscTypes
 import BasicTypes 
-import Type
 
 import Inst
 import InstEnv 
@@ -83,8 +83,11 @@ import DynFlags
 import Coercion
 import Class
 import TyCon
+import TypeRep 
+
 import Name
 import Var
+import VarEnv
 import Outputable
 import Bag
 import MonadUtils
@@ -334,7 +337,7 @@ data TcSEnv
       tcs_ev_binds :: EvBindsVar,
           -- Evidence bindings
 
-      tcs_ty_binds :: IORef (Bag (TcTyVar, TcType)),
+      tcs_ty_binds :: IORef (TyVarEnv (TcTyVar, TcType)),
           -- Global type bindings
 
       tcs_context :: SimplContext
@@ -413,7 +416,7 @@ runTcS :: SimplContext
        -> TcS a		       -- What to run
        -> TcM (a, Bag EvBind)
 runTcS context untouch tcs 
-  = do { ty_binds_var <- TcM.newTcRef emptyBag
+  = do { ty_binds_var <- TcM.newTcRef emptyVarEnv
        ; ev_binds_var@(EvBindsVar evb_ref _) <- TcM.newTcEvBinds
        ; let env = TcSEnv { tcs_ev_binds = ev_binds_var
                           , tcs_ty_binds = ty_binds_var
@@ -424,13 +427,14 @@ runTcS context untouch tcs
 
 	     -- Perform the type unifications required
        ; ty_binds <- TcM.readTcRef ty_binds_var
-       ; mapBagM_ do_unification ty_binds
+       ; mapM_ do_unification (varEnvElts ty_binds)
 
              -- And return
        ; ev_binds <- TcM.readTcRef evb_ref
        ; return (res, evBindMapBinds ev_binds) }
   where
     do_unification (tv,ty) = TcM.writeMetaTyVar tv ty
+
        
 nestImplicTcS :: EvBindsVar -> TcTyVarSet -> TcS a -> TcS a 
 nestImplicTcS ref untouch tcs 
@@ -451,7 +455,7 @@ tryTcS :: TcTyVarSet -> TcS a -> TcS a
 -- Like runTcS, but from within the TcS monad 
 -- Ignore all the evidence generated, and do not affect caller's evidence!
 tryTcS untch tcs 
-  = TcS (\env -> do { ty_binds_var <- TcM.newTcRef emptyBag
+  = TcS (\env -> do { ty_binds_var <- TcM.newTcRef emptyVarEnv
                     ; ev_binds_var <- TcM.newTcEvBinds
                     ; let env1 = env { tcs_ev_binds = ev_binds_var
                                      , tcs_ty_binds = ty_binds_var }
@@ -469,9 +473,13 @@ getTcSContext = TcS (return . tcs_context)
 getTcEvBinds :: TcS EvBindsVar
 getTcEvBinds = TcS (return . tcs_ev_binds) 
 
-getTcSTyBinds :: TcS (IORef (Bag (TcTyVar, TcType)))
+getTcSTyBinds :: TcS (IORef (TyVarEnv (TcTyVar, TcType)))
 getTcSTyBinds = TcS (return . tcs_ty_binds)
 
+getTcSTyBindsMap :: TcS (TyVarEnv (TcTyVar, TcType)) 
+getTcSTyBindsMap = getTcSTyBinds >>= wrapTcS . (TcM.readTcRef) 
+
+
 getTcEvBindsBag :: TcS EvBindMap
 getTcEvBindsBag
   = do { EvBindsVar ev_ref _ <- getTcEvBinds 
@@ -492,7 +500,7 @@ setWantedTyBind tv ty
   = do { ref <- getTcSTyBinds
        ; wrapTcS $ 
          do { ty_binds <- TcM.readTcRef ref
-            ; TcM.writeTcRef ref (ty_binds `snocBag` (tv,ty)) } }
+            ; TcM.writeTcRef ref (extendVarEnv ty_binds tv (tv,ty)) } }
 
 setIPBind :: EvVar -> EvTerm -> TcS () 
 setIPBind = setEvBind 
@@ -570,7 +578,8 @@ newFlattenSkolemTy ty = mkTyVarTy <$> newFlattenSkolemTyVar ty
         newFlattenSkolemTyVar ty
             = wrapTcS $ do { uniq <- TcM.newUnique
                            ; let name = mkSysTvName uniq (fsLit "f")
-                           ; return $ mkTcTyVar name (typeKind ty) (FlatSkol ty)
+                           ; return $ 
+                             mkTcTyVar name (typeKind ty) (FlatSkol ty) 
                            }
 
 -- Instantiations