Beautiful new approach to the skolem-escape check and untouchable

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

diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index b1d963e..ba694b6 100644 (file)
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/compiler/typecheck/TcRnMonad.lhs
@@ -69,6 +69,7 @@ initTc :: HscEnv
 
 initTc hsc_env hsc_src keep_rn_syntax mod do_this
  = do { errs_var     <- newIORef (emptyBag, emptyBag) ;
+        meta_var     <- newIORef initTyVarUnique ;
        tvs_var      <- newIORef emptyVarSet ;
        dfuns_var    <- newIORef emptyNameSet ;
        keep_var     <- newIORef emptyNameSet ;
@@ -107,20 +108,21 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
                 tcg_rn_exports = maybe_rn_syntax [],
                tcg_rn_decls   = maybe_rn_syntax emptyRnGroup,
 
-               tcg_binds    = emptyLHsBinds,
-               tcg_sigs     = emptyNameSet,
-               tcg_ev_binds = emptyBag,
-               tcg_warns    = NoWarnings,
-               tcg_anns     = [],
-               tcg_insts    = [],
-               tcg_fam_insts= [],
-               tcg_rules    = [],
-               tcg_fords    = [],
-               tcg_dfun_n   = dfun_n_var,
-               tcg_keep     = keep_var,
-               tcg_doc_hdr  = Nothing,
-                tcg_hpc      = False,
-                tcg_main     = Nothing
+               tcg_binds     = emptyLHsBinds,
+               tcg_imp_specs = [],
+               tcg_sigs      = emptyNameSet,
+               tcg_ev_binds  = emptyBag,
+               tcg_warns     = NoWarnings,
+               tcg_anns      = [],
+               tcg_insts     = [],
+               tcg_fam_insts = [],
+               tcg_rules     = [],
+               tcg_fords     = [],
+               tcg_dfun_n    = dfun_n_var,
+               tcg_keep      = keep_var,
+               tcg_doc_hdr   = Nothing,
+                tcg_hpc       = False,
+                tcg_main      = Nothing
             } ;
             lcl_env = TcLclEnv {
                tcl_errs       = errs_var,
@@ -132,7 +134,8 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
                tcl_env        = emptyNameEnv,
                tcl_tyvars     = tvs_var,
                tcl_lie        = lie_var,
-               tcl_untch      = emptyVarSet
+                tcl_meta       = meta_var,
+               tcl_untch      = initTyVarUnique
             } ;
        } ;
    
@@ -314,6 +317,16 @@ getEpsAndHpt = do { env <- getTopEnv; eps <- readMutVar (hsc_EPS env)
 %************************************************************************
 
 \begin{code}
+newMetaUnique :: TcM Unique
+-- The uniques for TcMetaTyVars are allocated specially
+-- in guaranteed linear order, starting at zero for each module
+newMetaUnique 
+ = do { env <- getLclEnv
+      ; let meta_var = tcl_meta env
+      ; uniq <- readMutVar meta_var
+      ; writeMutVar meta_var (incrUnique uniq)
+      ; return uniq }
+
 newUnique :: TcRnIf gbl lcl Unique
 newUnique
  = do { env <- getEnv ;
@@ -677,7 +690,7 @@ tryTcLIE :: TcM a -> TcM (Messages, Maybe a)
 -- for the thing is propagated only if there are no errors
 -- Hence it's restricted to the type-check monad
 tryTcLIE thing_inside
-  = do  { ((msgs, mb_res), lie) <- getConstraints (tryTcErrs thing_inside) ;
+  = do  { ((msgs, mb_res), lie) <- captureConstraints (tryTcErrs thing_inside) ;
        ; case mb_res of
            Nothing  -> return (msgs, Nothing)
            Just val -> do { emitConstraints lie; return (msgs, Just val) }
@@ -950,25 +963,27 @@ emitConstraint ct
   = do { lie_var <- getConstraintVar ;
         updTcRef lie_var (`extendWanteds` ct) }
 
-getConstraints :: TcM a -> TcM (a, WantedConstraints)
--- (getConstraints m) runs m, and returns the type constraints it generates
-getConstraints thing_inside
+captureConstraints :: TcM a -> TcM (a, WantedConstraints)
+-- (captureConstraints m) runs m, and returns the type constraints it generates
+captureConstraints thing_inside
   = do { lie_var <- newTcRef emptyWanteds ;
         res <- updLclEnv (\ env -> env { tcl_lie = lie_var }) 
                          thing_inside ;
         lie <- readTcRef lie_var ;
         return (res, lie) }
 
-setUntouchables :: TcTyVarSet -> TcM a -> TcM a
-setUntouchables untch_tvs thing_inside
-  = updLclEnv (\ env -> env { tcl_untch = untch_tvs }) thing_inside 
-
-getUntouchables :: TcM TcTyVarSet 
-getUntouchables
-   = do { env <- getLclEnv; return (tcl_untch env) } 
+captureUntouchables :: TcM a -> TcM (a, Untouchables)
+captureUntouchables thing_inside
+  = do { env <- getLclEnv
+       ; low_meta <- readTcRef (tcl_meta env)
+       ; res <- setLclEnv (env { tcl_untch = low_meta }) 
+                thing_inside 
+       ; high_meta <- readTcRef (tcl_meta env)
+       ; return (res, TouchableRange low_meta high_meta) }
 
 isUntouchable :: TcTyVar -> TcM Bool
-isUntouchable tv = do { env <- getLclEnv; return (tv `elemVarSet` tcl_untch env) }
+isUntouchable tv = do { env <- getLclEnv
+                      ; return (varUnique tv < tcl_untch env) }
 
 getLclTypeEnv :: TcM (NameEnv TcTyThing)
 getLclTypeEnv = do { env <- getLclEnv; return (tcl_env env) }