Major bugfixing pass through the type checker

[ghc-hetmet.git] / compiler / typecheck / TcSMonad.lhs

diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs
index 4965a93..f8b357a 100644 (file)
--- 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, getTcSTyBindsBag,
 
 
     newFlattenSkolemTy,                         -- Flatten skolems 
 
+
     instDFunTypes,                              -- Instantiation
     instDFunConstraints,                        
 
@@ -63,7 +64,6 @@ module TcSMonad (
 
 import HscTypes
 import BasicTypes 
-import Type
 
 import Inst
 import InstEnv 
@@ -83,6 +83,8 @@ import DynFlags
 import Coercion
 import Class
 import TyCon
+import TypeRep 
+
 import Name
 import Var
 import Outputable
@@ -431,6 +433,7 @@ runTcS context untouch tcs
        ; 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 
@@ -472,6 +475,10 @@ getTcEvBinds = TcS (return . tcs_ev_binds)
 getTcSTyBinds :: TcS (IORef (Bag (TcTyVar, TcType)))
 getTcSTyBinds = TcS (return . tcs_ty_binds)
 
+getTcSTyBindsBag :: TcS (Bag (TcTyVar, TcType)) 
+getTcSTyBindsBag = getTcSTyBinds >>= wrapTcS . (TcM.readTcRef) 
+
+
 getTcEvBindsBag :: TcS EvBindMap
 getTcEvBindsBag
   = do { EvBindsVar ev_ref _ <- getTcEvBinds 
@@ -570,7 +577,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