[project @ 2002-05-23 15:51: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 80ccae7..7b06460 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,
@@ -51,7 +51,7 @@ import Bag            ( Bag, emptyBag, isEmptyBag,
                          foldBag, unitBag, unionBags, snocBag )
 import Class           ( Class )
 import Name            ( Name )
-import Var             ( Id, TyVar, newMutTyVar, readMutTyVar, writeMutTyVar )
+import Var             ( TyVar, newMutTyVar, readMutTyVar, writeMutTyVar )
 import VarEnv          ( TidyEnv, emptyTidyEnv )
 import UniqSupply      ( UniqSupply, uniqFromSupply, uniqsFromSupply,
                          splitUniqSupply, mkSplitUniqSupply,
@@ -408,6 +408,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.
@@ -643,7 +656,7 @@ functions that deal with it.
 type InstLoc = (InstOrigin, SrcLoc, ErrCtxt)
 
 data InstOrigin
-  = OccurrenceOf Id            -- Occurrence of an overloaded identifier
+  = OccurrenceOf Name          -- Occurrence of an overloaded identifier
 
   | IPOcc (IPName Name)                -- Occurrence of an implicit parameter
   | IPBind (IPName Name)       -- Binding site of an implicit parameter
@@ -698,12 +711,12 @@ pprInstLoc :: InstLoc -> SDoc
 pprInstLoc (orig, locn, ctxt)
   = hsep [text "arising from", pp_orig orig, text "at", ppr locn]
   where
-    pp_orig (OccurrenceOf id)
-       = hsep [ptext SLIT("use of"), quotes (ppr id)]
+    pp_orig (OccurrenceOf name)
+       = hsep [ptext SLIT("use of"), quotes (ppr name)]
     pp_orig (IPOcc name)
-       = hsep [ptext SLIT("use of implicit parameter"), quotes (char '?' <> ppr name)]
+       = hsep [ptext SLIT("use of implicit parameter"), quotes (ppr name)]
     pp_orig (IPBind name)
-       = hsep [ptext SLIT("binding for implicit parameter"), quotes (char '?' <> ppr name)]
+       = hsep [ptext SLIT("binding for implicit parameter"), quotes (ppr name)]
     pp_orig RecordUpdOrigin
        = ptext SLIT("a record update")
     pp_orig DataDeclOrigin