[project @ 2002-09-09 12:50:26 by simonpj]

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

diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs
index de83f05..a7c15f8 100644 (file)
--- a/ghc/compiler/typecheck/TcMonad.lhs
+++ b/ghc/compiler/typecheck/TcMonad.lhs
@@ -17,7 +17,7 @@ module TcMonad(
 
        checkTc, checkTcM, checkMaybeTc, checkMaybeTcM, 
        failTc, failWithTc, addErrTc, addErrsTc, warnTc, 
-       recoverTc, checkNoErrsTc, recoverNF_Tc, discardErrsTc,
+       recoverTc, checkNoErrsTc, ifErrsTc, recoverNF_Tc, discardErrsTc,
        addErrTcM, addInstErrTcM, failWithTcM,
 
        tcGetEnv, tcSetEnv,
@@ -63,10 +63,9 @@ import Unique                ( Unique )
 import CmdLineOpts
 import Outputable
 
-import IOExts          ( IORef, newIORef, readIORef, writeIORef,
-                         unsafeInterleaveIO, fixIO
-                       )
-
+import DATA_IOREF      ( IORef, newIORef, readIORef, writeIORef )
+import UNSAFE_IO       ( unsafeInterleaveIO )
+import FIX_IO          ( fixIO )
 
 infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc`, `thenNF_Tc_` 
 \end{code}
@@ -408,6 +407,19 @@ checkNoErrsTc main
          errs_var = getTcErrs down
 
 
+ifErrsTc :: TcM r -> TcM r -> TcM r
+--     ifErrsTc bale_out main
+-- does 'bale_out' if there are errors in errors collection
+-- and does 'main' otherwise
+-- Useful to avoid error cascades
+
+ifErrsTc bale_out main
+  = getErrsTc  `thenNF_Tc` \ (warns, errs) -> 
+    if isEmptyBag errs then
+          main
+    else       
+          bale_out
+
 -- (tryTc_ r m) tries m; if it succeeds it returns it,
 -- otherwise it returns r.  Any error messages added by m are discarded,
 -- whether or not m succeeds.