X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSimplify.lhs;h=853e2c491ef16c4e072da8d667218cfbfba2f72d;hb=5db0076d34263fae4f431b51b871ef55a6ebb2a7;hp=acc5b3cd9a2bcc5a8618fd03fd2187fedbc0a66d;hpb=debb7b80e707c343a3a7d8993ffab19b83e5c52b;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index acc5b3c..853e2c4 100644
--- a/compiler/typecheck/TcSimplify.lhs
+++ b/compiler/typecheck/TcSimplify.lhs
@@ -18,6 +18,8 @@ import TcInteract
 import Inst
 import Var
 import VarSet
+import VarEnv ( varEnvElts ) 
+
 import Name
 import NameEnv	( emptyNameEnv )
 import Bag
@@ -208,8 +210,12 @@ simplifyInfer apply_mr tau_tvs wanted
                           zonked_tau_tvs `minusVarSet` gbl_tvs
              (perhaps_bound, surely_free) 
                   = partitionBag (quantifyMeWC proto_qtvs) zonked_wanted
+      
        ; emitConstraints surely_free
-       ; traceTc "sinf" (ppr proto_qtvs $$ ppr perhaps_bound $$ ppr surely_free)
+       ; traceTc "sinf"  $ vcat
+             [ ptext (sLit "perhaps_bound =") <+> ppr perhaps_bound
+             , ptext (sLit "surely_free   =") <+> ppr surely_free
+             ]
 
        	      -- Now simplify the possibly-bound constraints
        ; (simplified_perhaps_bound, tc_binds) 
@@ -337,20 +343,28 @@ growWantedEVs gbl_tvs ws tvs
   | isEmptyBag ws = tvs
   | otherwise     = fixVarSet (\tvs -> foldrBag (growWantedEV gbl_tvs) tvs ws) tvs
 
+growEvVar    :: TyVarSet -> EvVar            -> TyVarSet -> TyVarSet
 growWantedEV :: TyVarSet -> WantedEvVar      -> TyVarSet -> TyVarSet
 growWanted   :: TyVarSet -> WantedConstraint -> TyVarSet -> TyVarSet
 -- (growX gbls wanted tvs) grows a seed 'tvs' against the 
 -- X-constraint 'wanted', nuking the 'gbls' at each stage
-growWantedEV gbl_tvs wev tvs
+
+growEvVar gbl_tvs ev tvs
   = tvs `unionVarSet` (ev_tvs `minusVarSet` gbl_tvs)
   where
-    ev_tvs = growPredTyVars (wantedEvVarPred wev) tvs
+    ev_tvs = growPredTyVars (evVarPred ev) tvs
+
+growWantedEV gbl_tvs wev tvs = growEvVar gbl_tvs (wantedEvVarToVar wev) tvs
 
 growWanted gbl_tvs (WcEvVar wev) tvs
   = growWantedEV gbl_tvs wev tvs
 growWanted gbl_tvs (WcImplic implic) tvs
-  = foldrBag (growWanted (gbl_tvs `unionVarSet` ic_skols implic)) 
-             tvs (ic_wanted implic)
+  = foldrBag (growWanted inner_gbl_tvs) 
+             (foldr (growEvVar inner_gbl_tvs) tvs (ic_given implic))
+	     	    -- Must grow over inner givens too
+             (ic_wanted implic)
+  where
+    inner_gbl_tvs = gbl_tvs `unionVarSet` ic_skols implic
 
 --------------------
 quantifyMe :: TyVarSet      -- Quantifying over these
@@ -363,8 +377,13 @@ quantifyMe qtvs wev
     pred = wantedEvVarPred wev
 
 quantifyMeWC :: TyVarSet -> WantedConstraint -> Bool
+-- False => we can *definitely* float the WantedConstraint out
 quantifyMeWC qtvs (WcImplic implic)
-  = anyBag (quantifyMeWC (qtvs `minusVarSet` ic_skols implic)) (ic_wanted implic)
+  =  (tyVarsOfEvVars (ic_given implic) `intersectsVarSet` inner_qtvs)
+  || anyBag (quantifyMeWC inner_qtvs) (ic_wanted implic)
+  where
+    inner_qtvs = qtvs `minusVarSet` ic_skols implic
+
 quantifyMeWC qtvs (WcEvVar wev)
   = quantifyMe qtvs wev
 \end{code}
@@ -629,10 +648,13 @@ solveWanteds inert wanteds
                       , text "inert =" <+> ppr inert ]
        ; (unsolved_flats, unsolved_implics) 
                <- simpl_loop 1 can_flats implic_wanteds
+       ; bb <- getTcEvBindsBag 
        ; traceTcS "solveWanteds }" $
                  vcat [ text "wanteds =" <+> ppr wanteds
                       , text "unsolved_flats =" <+> ppr unsolved_flats
-                      , text "unsolved_implics =" <+> ppr unsolved_implics ]
+                      , text "unsolved_implics =" <+> ppr unsolved_implics 
+                      , text "current evbinds =" <+> vcat (map ppr (varEnvElts bb))
+                      ] 
        ; return (unsolved_flats, unsolved_implics)  }
   where
     simpl_loop :: Int 
@@ -697,6 +719,10 @@ solveImplication inert
                  , ic_wanted = wanteds
                  , ic_loc    = loc })
   = nestImplicTcS ev_binds untch $
+    recoverTcS (return (emptyBag, emptyBag)) $
+       -- Recover from nested failures.  Even the top level is
+       -- just a bunch of implications, so failing at the first
+       -- one is bad
     do { traceTcS "solveImplication {" (ppr imp) 
 
          -- Solve flat givens
@@ -803,7 +829,7 @@ applyDefaultingRules inert wanteds
   | otherwise
   = do { untch <- getUntouchables
        ; tv_cts <- mapM (defaultTyVar untch) $
-                   varSetElems (tyVarsOfCanonicals wanteds)
+                   varSetElems (tyVarsOfCDicts wanteds) 
 
        ; info@(_, default_tys, _) <- getDefaultInfo
        ; let groups = findDefaultableGroups info untch wanteds
@@ -831,10 +857,9 @@ defaultTyVar :: Untouchables -> TcTyVar -> TcS CanonicalCts
 -- whatever, because the type-class defaulting rules have yet to run.
 
 defaultTyVar untch the_tv 
-  | isMetaTyVar the_tv
-  , inTouchableRange untch the_tv
+  | isTouchableMetaTyVar_InRange untch the_tv
   , not (k `eqKind` default_k)
-  = do { (ev, better_ty) <- TcSMonad.newKindConstraint (mkTyVarTy the_tv) default_k
+  = do { (ev, better_ty) <- TcSMonad.newKindConstraint the_tv default_k
        ; let loc = CtLoc DefaultOrigin (getSrcSpan the_tv) [] -- Yuk
        	     	   -- 'DefaultOrigin' is strictly the declaration, but it's convenient
              wanted_eq  = CTyEqCan { cc_id     = ev
@@ -882,7 +907,7 @@ findDefaultableGroups (ctxt, default_tys, (ovl_strings, extended_defaults))
     is_defaultable_group ds@((_,tv):_)
         = isTyConableTyVar tv	-- Note [Avoiding spurious errors]
         && not (tv `elemVarSet` bad_tvs)
-        && inTouchableRange untch tv
+        && isTouchableMetaTyVar_InRange untch tv 
         && defaultable_classes [cc_class cc | (cc,_) <- ds]
     is_defaultable_group [] = panic "defaultable_group"