X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSMonad.lhs;h=93c795d33cbc05595c2c8e55fdddb9fdf0d174a0;hb=201145f80c2c797badceabd0287cc7f5e98302aa;hp=f8b357a8d5a69753f9947dc497f266851dd42bbc;hpb=67ed735fab12c12a1d48878d7bda33588c67fb78;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs
index f8b357a..93c795d 100644
--- a/compiler/typecheck/TcSMonad.lhs
+++ b/compiler/typecheck/TcSMonad.lhs
@@ -10,7 +10,7 @@ module TcSMonad (
     makeGivens, makeSolved,
 
     CtFlavor (..), isWanted, isGiven, isDerived, canRewrite, 
-    joinFlavors, mkGivenFlavor,
+    combineCtLoc, mkGivenFlavor,
 
     TcS, runTcS, failTcS, panicTcS, traceTcS, traceTcS0,  -- Basic functionality 
     tryTcS, nestImplicTcS, wrapErrTcS, wrapWarnTcS,
@@ -30,8 +30,8 @@ module TcSMonad (
     newTcEvBindsTcS,
  
     getInstEnvs, getFamInstEnvs,                -- Getting the environments 
-    getTopEnv, getGblEnv, getTcEvBinds, getUntouchablesTcS,
-    getTcEvBindsBag, getTcSContext, getTcSTyBinds, getTcSTyBindsBag,
+    getTopEnv, getGblEnv, getTcEvBinds, getUntouchables,
+    getTcEvBindsBag, getTcSContext, getTcSTyBinds, getTcSTyBindsMap,
 
 
     newFlattenSkolemTy,                         -- Flatten skolems 
@@ -87,6 +87,7 @@ import TypeRep
 
 import Name
 import Var
+import VarEnv
 import Outputable
 import Bag
 import MonadUtils
@@ -99,7 +100,6 @@ import FunDeps
 
 import TcRnTypes
 
-import Control.Monad
 import Data.IORef
 \end{code}
 
@@ -297,12 +297,13 @@ canRewrite (Derived {}) (Derived {}) = True
 canRewrite (Wanted {})  (Wanted {})  = True
 canRewrite _ _ = False
 
-joinFlavors :: CtFlavor -> CtFlavor -> CtFlavor 
-joinFlavors (Wanted loc) _  = Wanted loc 
-joinFlavors _ (Wanted loc)  = Wanted loc 
-joinFlavors (Derived loc) _ = Derived loc 
-joinFlavors _ (Derived loc) = Derived loc 
-joinFlavors (Given loc) _   = Given loc
+combineCtLoc :: CtFlavor -> CtFlavor -> WantedLoc
+-- Precondition: At least one of them should be wanted 
+combineCtLoc (Wanted loc) _ = loc 
+combineCtLoc _ (Wanted loc) = loc 
+combineCtLoc (Derived loc) _ = loc 
+combineCtLoc _ (Derived loc) = loc 
+combineCtLoc _ _ = panic "combineCtLoc: both given"
 
 mkGivenFlavor :: CtFlavor -> SkolemInfo -> CtFlavor
 mkGivenFlavor (Wanted  loc) sk = Given (setCtLocOrigin loc sk)
@@ -336,10 +337,12 @@ 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
+      tcs_context :: SimplContext,
+
+      tcs_untch :: Untouchables
     }
 
 data SimplContext
@@ -411,22 +414,23 @@ traceTcS0 :: String -> SDoc -> TcS ()
 traceTcS0 herald doc = TcS $ \_env -> TcM.traceTcN 0 herald doc
 
 runTcS :: SimplContext
-       -> TcTyVarSet 	       -- Untouchables
+       -> Untouchables 	       -- Untouchables
        -> 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
-                          , tcs_context = context }
+                          , tcs_context = context
+                          , tcs_untch   = untouch }
 
 	     -- Run the computation
-       ; res <- TcM.setUntouchables untouch (unTcS tcs env)
+       ; res <- unTcS tcs env
 
 	     -- 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
@@ -435,30 +439,31 @@ runTcS context untouch tcs
     do_unification (tv,ty) = TcM.writeMetaTyVar tv ty
 
        
-nestImplicTcS :: EvBindsVar -> TcTyVarSet -> TcS a -> TcS a 
-nestImplicTcS ref untouch tcs 
+nestImplicTcS :: EvBindsVar -> Untouchables -> TcS a -> TcS a 
+nestImplicTcS ref untch (TcS thing_inside)
   = TcS $ \ TcSEnv { tcs_ty_binds = ty_binds, tcs_context = ctxt } -> 
     let 
        nest_env = TcSEnv { tcs_ev_binds = ref
                          , tcs_ty_binds = ty_binds
-                         , tcs_context = ctxtUnderImplic ctxt }
+                         , tcs_untch    = untch
+                         , tcs_context  = ctxtUnderImplic ctxt }
     in 
-    TcM.setUntouchables untouch (unTcS tcs nest_env) 
+    thing_inside nest_env
 
 ctxtUnderImplic :: SimplContext -> SimplContext
 -- See Note [Simplifying RULE lhs constraints] in TcSimplify
 ctxtUnderImplic SimplRuleLhs = SimplCheck
 ctxtUnderImplic ctxt         = ctxt
 
-tryTcS :: TcTyVarSet -> TcS a -> TcS a 
+tryTcS :: 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
+tryTcS tcs 
+  = 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 }
-                    ; TcM.setUntouchables untch (unTcS tcs env1) })
+                    ; unTcS tcs env1 })
 
 -- Update TcEvBinds 
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -472,11 +477,14 @@ getTcSContext = TcS (return . tcs_context)
 getTcEvBinds :: TcS EvBindsVar
 getTcEvBinds = TcS (return . tcs_ev_binds) 
 
-getTcSTyBinds :: TcS (IORef (Bag (TcTyVar, TcType)))
+getUntouchables :: TcS Untouchables 
+getUntouchables = TcS (return . tcs_untch)
+
+getTcSTyBinds :: TcS (IORef (TyVarEnv (TcTyVar, TcType)))
 getTcSTyBinds = TcS (return . tcs_ty_binds)
 
-getTcSTyBindsBag :: TcS (Bag (TcTyVar, TcType)) 
-getTcSTyBindsBag = getTcSTyBinds >>= wrapTcS . (TcM.readTcRef) 
+getTcSTyBindsMap :: TcS (TyVarEnv (TcTyVar, TcType)) 
+getTcSTyBindsMap = getTcSTyBinds >>= wrapTcS . (TcM.readTcRef) 
 
 
 getTcEvBindsBag :: TcS EvBindMap
@@ -499,7 +507,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 
@@ -542,9 +550,6 @@ getTopEnv = wrapTcS $ TcM.getTopEnv
 getGblEnv :: TcS TcGblEnv 
 getGblEnv = wrapTcS $ TcM.getGblEnv 
 
-getUntouchablesTcS :: TcS TcTyVarSet 
-getUntouchablesTcS = wrapTcS $ TcM.getUntouchables
-
 -- Various smaller utilities [TODO, maybe will be absorbed in the instance matcher]
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
@@ -562,10 +567,10 @@ pprEq ty1 ty2 = pprPred $ mkEqPred (ty1,ty2)
 
 isTouchableMetaTyVar :: TcTyVar -> TcS Bool
 -- is touchable variable!
-isTouchableMetaTyVar v 
-  | isMetaTyVar v = wrapTcS $ do { untch <- TcM.isUntouchable v; 
-                                 ; return (not untch) }
-  | otherwise     = return False
+isTouchableMetaTyVar tv 
+  | isMetaTyVar tv = do { untch <- getUntouchables
+                        ; return (inTouchableRange untch tv) }
+  | otherwise      = return False
 
 
 -- Flatten skolems