From: simonpj@microsoft.com <unknown>
Date: Tue, 19 Oct 2010 09:02:02 +0000 (+0000)
Subject: Recover after an error in an implication constraint
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=51462af9d4af9e16b29da1530929e802c0d846e2

Recover after an error in an implication constraint
---

diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs
index 5f555c5..5c41ff1 100644
--- a/compiler/typecheck/TcSMonad.lhs
+++ b/compiler/typecheck/TcSMonad.lhs
@@ -15,7 +15,7 @@ module TcSMonad (
     combineCtLoc, mkGivenFlavor,
 
     TcS, runTcS, failTcS, panicTcS, traceTcS, traceTcS0,  -- Basic functionality 
-    tryTcS, nestImplicTcS, wrapErrTcS, wrapWarnTcS,
+    tryTcS, nestImplicTcS, recoverTcS, wrapErrTcS, wrapWarnTcS,
     SimplContext(..), isInteractive, simplEqsOnly, performDefaulting,
        
        -- Creation of evidence variables
@@ -235,6 +235,8 @@ variable, is not canonical.  Why?
 
 Hence the invariant.
 
+The invariant is 
+
 Note [Canonical implicit parameter constraints]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 The type in a canonical implicit parameter constraint doesn't need to
@@ -491,6 +493,11 @@ nestImplicTcS ref untch (TcS thing_inside)
     in 
     thing_inside nest_env
 
+recoverTcS :: TcS a -> TcS a -> TcS a
+recoverTcS (TcS recovery_code) (TcS thing_inside)
+  = TcS $ \ env ->
+    TcM.recoverM (recovery_code env) (thing_inside env)
+
 ctxtUnderImplic :: SimplContext -> SimplContext
 -- See Note [Simplifying RULE lhs constraints] in TcSimplify
 ctxtUnderImplic SimplRuleLhs = SimplCheck
diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index f0963f7..bb76c1d 100644
--- a/compiler/typecheck/TcSimplify.lhs
+++ b/compiler/typecheck/TcSimplify.lhs
@@ -706,6 +706,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