[project @ 2005-10-27 14:35:20 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 6d2c64a..a4032cd 100644 (file)
--- a/ghc/compiler/typecheck/TcRnMonad.lhs
+++ b/ghc/compiler/typecheck/TcRnMonad.lhs
@@ -28,7 +28,7 @@ import InstEnv                ( emptyInstEnv )
 import VarSet          ( emptyVarSet )
 import VarEnv          ( TidyEnv, emptyTidyEnv, emptyVarEnv )
 import ErrUtils                ( Message, Messages, emptyMessages, errorsFound, 
-                         mkWarnMsg, printErrorsAndWarnings, pprBagOfErrors,
+                         mkWarnMsg, printErrorsAndWarnings,
                          mkLocMessage, mkLongErrMsg )
 import Packages                ( mkHomeModules )
 import SrcLoc          ( mkGeneralSrcSpan, isGoodSrcSpan, SrcSpan, Located(..) )
@@ -41,7 +41,7 @@ import UniqSupply     ( UniqSupply, mkSplitUniqSupply, uniqFromSupply, splitUniqSupp
 import Unique          ( Unique )
 import DynFlags                ( DynFlags(..), DynFlag(..), dopt, dopt_set, GhcMode )
 import StaticFlags     ( opt_PprStyle_Debug )
-import Bag             ( snocBag, unionBags, unitBag )
+import Bag             ( snocBag, unionBags )
 import Panic           ( showException )
  
 import IO              ( stderr )
@@ -159,7 +159,7 @@ initTcPrintErrors   -- Used from the interactive loop only
        -> IO (Maybe r)
 initTcPrintErrors env mod todo = do
   (msgs, res) <- initTc env HsSrcFile mod todo
-  printErrorsAndWarnings msgs
+  printErrorsAndWarnings (hsc_dflags env) msgs
   return res
 
 -- mkImpTypeEnv makes the imported symbol table
@@ -448,12 +448,12 @@ addErrAt loc msg = addLongErrAt loc msg empty
 
 addLongErrAt :: SrcSpan -> Message -> Message -> TcRn ()
 addLongErrAt loc msg extra
- = do {  errs_var <- getErrsVar ;
+  = do { traceTc (ptext SLIT("Adding error:") <+> (mkLocMessage loc (msg $$ extra))) ; 
+
+        errs_var <- getErrsVar ;
         rdr_env <- getGlobalRdrEnv ;
         let { err = mkLongErrMsg loc (unQualInScope rdr_env) msg extra } ;
         (warns, errs) <- readMutVar errs_var ;
-        traceTc (ptext SLIT("Adding error:") <+> \ _ -> pprBagOfErrors (unitBag err)) ;        
-               -- Ugh!  traceTc is too specific; unitBag is horrible
         writeMutVar errs_var (warns, errs `snocBag` err) }
 
 addErrs :: [(SrcSpan,Message)] -> TcRn ()
@@ -931,7 +931,7 @@ failIfM :: Message -> IfL a
 -- We use IfL here so that we can get context info out of the local env
 failIfM msg
   = do         { env <- getLclEnv
-       ; let full_msg = if_loc env $$ nest 2 msg
+       ; let full_msg = (if_loc env <> colon) $$ nest 2 msg
        ; ioToIOEnv (printErrs (full_msg defaultErrStyle))
        ; failM }
 
@@ -971,7 +971,8 @@ forkM :: SDoc -> IfL a -> IfL a
 forkM doc thing_inside
  = do  { mb_res <- forkM_maybe doc thing_inside
        ; return (case mb_res of 
-                       Nothing -> pprPanic "forkM" doc
+                       Nothing -> pgmError "Cannot continue after interface file error"
+                                  -- pprPanic "forkM" doc
                        Just r  -> r) }
 \end{code}