[project @ 2002-11-28 17:17:41 by simonpj]

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

diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs
index 22eae1b..39c0a1f 100644 (file)
--- a/ghc/compiler/typecheck/TcRnMonad.lhs
+++ b/ghc/compiler/typecheck/TcRnMonad.lhs
@@ -169,15 +169,15 @@ initTc  (HscEnv { hsc_mode   = ghci_mode,
        eps' <- readIORef eps_var ;
        nc'  <- readIORef nc_var ;
        let { pcs' = PCS { pcs_EPS = eps', pcs_nc = nc' } ;
-             final_res | errorsFound msgs = Nothing
-                       | otherwise        = maybe_res } ;
+             final_res | errorsFound dflags msgs = Nothing
+                       | otherwise               = maybe_res } ;
 
        return (pcs', final_res)
     }
   where
     eps = pcs_EPS pcs
 
-    init_imports = emptyImportAvails { imp_unqual = unitModuleEnv mod emptyAvailEnv }
+    init_imports = emptyImportAvails { imp_qual = unitModuleEnv mod emptyAvailEnv }
        -- Initialise tcg_imports with an empty set of bindings for
        -- this module, so that if we see 'module M' in the export
        -- list, and there are no bindings in M, we don't bleat 
@@ -400,11 +400,13 @@ tryTc m
 
        new_errs <- readMutVar errs_var ;
 
+       dflags <- getDOpts ;
+
        return (new_errs, 
                case mb_r of
-                 Left exn                       -> Nothing
-                 Right r | errorsFound new_errs -> Nothing
-                         | otherwise            -> Just r) 
+                 Left exn                              -> Nothing
+                 Right r | errorsFound dflags new_errs -> Nothing
+                         | otherwise                   -> Just r) 
    }
 
 tryTcLIE :: TcM a -> TcM (Messages, Maybe a)
@@ -448,7 +450,8 @@ ifErrsM :: TcRn m r -> TcRn m r -> TcRn m r
 ifErrsM bale_out normal
  = do { errs_var <- getErrsVar ;
        msgs <- readMutVar errs_var ;
-       if errorsFound msgs then
+       dflags <- getDOpts ;
+       if errorsFound dflags msgs then
           bale_out
        else    
           normal }
@@ -579,7 +582,13 @@ updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) ->
 getInstLoc :: InstOrigin -> TcM InstLoc
 getInstLoc origin
   = do { loc <- getSrcLocM ; env <- getLclEnv ;
-        return (origin, loc, (tcl_ctxt env)) }
+        return (InstLoc origin loc (tcl_ctxt env)) }
+
+addInstCtxt :: InstLoc -> TcM a -> TcM a
+-- Add the SrcLoc and context from the first Inst in the list
+--     (they all have similar locations)
+addInstCtxt (InstLoc _ src_loc ctxt) thing_inside
+  = addSrcLoc src_loc (updCtxt (\ old_ctxt -> ctxt) thing_inside)
 \end{code}
 
     The addErrTc functions add an error message, but do not cause failure.
@@ -598,12 +607,6 @@ addErrTcM (tidy_env, err_msg)
   = do { ctxt <- getErrCtxt ;
         loc  <- getSrcLocM ;
         add_err_tcm tidy_env err_msg loc ctxt }
-
-addInstErrTcM :: InstLoc -> (TidyEnv, Message) -> TcM ()
-addInstErrTcM inst_loc@(_, loc, ctxt) (tidy_env, err_msg)
-  = add_err_tcm tidy_env err_msg loc full_ctxt
-  where
-    full_ctxt = (\env -> returnM (env, pprInstLoc inst_loc)) : ctxt
 \end{code}
 
 The failWith functions add an error message and cause failure