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 73a7229..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,
+    getTcEvBindsBag, getTcSContext, getTcSTyBinds, getTcSTyBindsBag,
 
 
     newFlattenSkolemTy,                         -- Flatten skolems 
 
+
     instDFunTypes,                              -- Instantiation
     instDFunConstraints,                        
 
@@ -63,8 +64,6 @@ module TcSMonad (
 
 import HscTypes
 import BasicTypes 
-import Type
-import TcRnTypes
 
 import Inst
 import InstEnv 
@@ -84,6 +83,8 @@ import DynFlags
 import Coercion
 import Class
 import TyCon
+import TypeRep 
+
 import Name
 import Var
 import Outputable
@@ -96,6 +97,8 @@ import HsBinds               -- for TcEvBinds stuff
 import Id 
 import FunDeps
 
+import TcRnTypes
+
 import Control.Monad
 import Data.IORef
 \end{code}
@@ -282,7 +285,8 @@ isGiven (Given {}) = True
 isGiven _          = False 
 
 isDerived :: CtFlavor -> Bool 
-isDerived ctid =  not $ isGiven ctid || isWanted ctid 
+isDerived (Derived {}) = True
+isDerived _            = False
 
 canRewrite :: CtFlavor -> CtFlavor -> Bool 
 -- canRewrite ctid1 ctid2 
@@ -429,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 
@@ -470,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 
@@ -568,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