[project @ 2005-07-25 11:11:36 by simonpj]

[ghc-hetmet.git] / ghc / compiler / main / ErrUtils.lhs

diff --git a/ghc/compiler/main/ErrUtils.lhs b/ghc/compiler/main/ErrUtils.lhs
index 4f86481..50db73c 100644 (file)
--- a/ghc/compiler/main/ErrUtils.lhs
+++ b/ghc/compiler/main/ErrUtils.lhs
@@ -18,7 +18,7 @@ module ErrUtils (
        dumpIfSet, dumpIfSet_core, dumpIfSet_dyn, dumpIfSet_dyn_or, mkDumpDoc,
        showPass,
 
-       -- * Messages during compilation
+       --  * Messages during compilation
        setMsgHandler,
        putMsg,
        compilationProgressMsg,
@@ -34,13 +34,12 @@ import Util         ( sortLe, global )
 import Outputable
 import qualified Pretty
 import SrcLoc          ( srcSpanStart )
-import CmdLineOpts     ( DynFlags(..), DynFlag(..), dopt,
-                         opt_ErrorSpans )
-
-import List             ( replicate, sortBy )
+import DynFlags                ( DynFlags(..), DynFlag(..), dopt )
+import StaticFlags     ( opt_ErrorSpans )
 import System          ( ExitCode(..), exitWith )
 import DATA_IOREF
-import IO              ( hPutStr, stderr, stdout )
+import IO              ( hPutStrLn, stderr )
+import DYNAMIC
 
 
 -- -----------------------------------------------------------------------------
@@ -73,6 +72,17 @@ data ErrMsg = ErrMsg {
        -- NB  Pretty.Doc not SDoc: we deal with the printing style (in ptic 
        -- whether to qualify an External Name) at the error occurrence
 
+-- So we can throw these things as exceptions
+errMsgTc :: TyCon
+errMsgTc = mkTyCon "ErrMsg"
+{-# NOINLINE errMsgTc #-}
+instance Typeable ErrMsg where
+#if __GLASGOW_HASKELL__ < 603
+  typeOf _ = mkAppTy errMsgTc []
+#else
+  typeOf _ = mkTyConApp errMsgTc []
+#endif
+
 type WarnMsg = ErrMsg
 
 -- A short (one-line) error message, with context to tell us whether
@@ -92,18 +102,9 @@ mkLongErrMsg :: SrcSpan -> PrintUnqualified -> Message -> Message -> ErrMsg
 mkLongErrMsg locn print_unqual msg extra 
  = ErrMsg [locn] print_unqual msg extra
 
--- A long (multi-line) error message, with context to tell us whether
--- to qualify names in the message or not.
-mkLongMultiLocErrMsg :: [SrcSpan] -> PrintUnqualified -> Message -> Message -> ErrMsg
-mkLongMultiLocErrMsg locns print_unqual msg extra
-  = ErrMsg locns print_unqual msg extra
-
 mkWarnMsg :: SrcSpan -> PrintUnqualified -> Message -> WarnMsg
 mkWarnMsg = mkErrMsg
 
-mkLongWarnMsg :: SrcSpan -> PrintUnqualified -> Message -> Message -> WarnMsg
-mkLongWarnMsg = mkLongErrMsg
-
 type Messages = (Bag WarnMsg, Bag ErrMsg)
 
 emptyMessages :: Messages
@@ -170,7 +171,7 @@ doIfSet_dyn dflags flag action | dopt flag dflags = action
 
 \begin{code}
 showPass :: DynFlags -> String -> IO ()
-showPass dflags what = compilationPassMsg dflags ("*** "++what++":\n")
+showPass dflags what = compilationPassMsg dflags ("*** "++what++":")
 
 dumpIfSet :: Bool -> String -> SDoc -> IO ()
 dumpIfSet flag hdr doc
@@ -230,11 +231,11 @@ compilationPassMsg :: DynFlags -> String -> IO ()
 compilationPassMsg dflags msg
   = ifVerbose dflags 2 (putMsg msg)
 
-debugTraceMsg :: DynFlags -> String -> IO ()
-debugTraceMsg dflags msg
-  = ifVerbose dflags 2 (putMsg msg)
+debugTraceMsg :: DynFlags -> Int -> String -> IO ()
+debugTraceMsg dflags val msg
+  = ifVerbose dflags val (putMsg msg)
 
-GLOBAL_VAR(msgHandler, hPutStr stderr, (String -> IO ()))
+GLOBAL_VAR(msgHandler, hPutStrLn stderr, (String -> IO ()))
 
 setMsgHandler :: (String -> IO ()) -> IO ()
 setMsgHandler handle_msg = writeIORef msgHandler handle_msg