X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FErrUtils.lhs;h=434b7d77d64cd342691c029ccf312a2f8f2d4151;hb=50159f6c4a3560662e37c55e64af1fb0b685011e;hp=358c7ab1c86f83a56d1c54bc4d288de246e9ed70;hpb=29da2cf3011c292bc4261601aff85afb13e24d54;p=ghc-hetmet.git

diff --git a/ghc/compiler/main/ErrUtils.lhs b/ghc/compiler/main/ErrUtils.lhs
index 358c7ab..434b7d7 100644
--- a/ghc/compiler/main/ErrUtils.lhs
+++ b/ghc/compiler/main/ErrUtils.lhs
@@ -16,23 +16,29 @@ module ErrUtils (
 	ghcExit,
 	doIfSet, doIfSet_dyn, 
 	dumpIfSet, dumpIfSet_core, dumpIfSet_dyn, dumpIfSet_dyn_or, mkDumpDoc,
-	showPass
+	showPass,
+
+	-- * Messages during compilation
+	setMsgHandler,
+	putMsg,
+	compilationProgressMsg,
+	debugTraceMsg,
+	errorMsg,
     ) where
 
 #include "HsVersions.h"
 
 import Bag		( Bag, bagToList, isEmptyBag, emptyBag )
 import SrcLoc		( SrcSpan )
-import Util		( sortLt )
+import Util		( sortLe, global )
 import Outputable
 import qualified Pretty
 import SrcLoc		( srcSpanStart )
-import CmdLineOpts	( DynFlags(..), DynFlag(..), dopt,
-			  opt_ErrorSpans )
-
-import List             ( replicate )
+import DynFlags		( DynFlags(..), DynFlag(..), dopt )
+import StaticFlags	( opt_ErrorSpans )
 import System		( ExitCode(..), exitWith )
-import IO		( hPutStr, stderr, stdout )
+import DATA_IOREF
+import IO		( hPutStrLn, stderr )
 
 
 -- -----------------------------------------------------------------------------
@@ -84,18 +90,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
@@ -120,17 +117,23 @@ printErrorsAndWarnings (warns, errs)
 
 pprBagOfErrors :: Bag ErrMsg -> Pretty.Doc
 pprBagOfErrors bag_of_errors
-  = Pretty.vcat [ let style = mkErrStyle unqual in
-		  Pretty.text "" Pretty.$$ d style Pretty.$$ e style
-		| ErrMsg { errMsgShortDoc = d,
+  = Pretty.vcat [ let style = mkErrStyle unqual
+		      doc = mkLocMessage s (d $$ e)
+		  in
+		  Pretty.text "" Pretty.$$ doc style
+		| ErrMsg { errMsgSpans = s:ss,
+			   errMsgShortDoc = d,
 			   errMsgExtraInfo = e,
 			   errMsgContext = unqual } <- sorted_errs ]
     where
       bag_ls	  = bagToList bag_of_errors
-      sorted_errs = sortLt occ'ed_before bag_ls
+      sorted_errs = sortLe occ'ed_before bag_ls
 
       occ'ed_before err1 err2 = 
-         LT == compare (head (errMsgSpans err1)) (head (errMsgSpans err1))
+         case compare (head (errMsgSpans err1)) (head (errMsgSpans err2)) of
+		LT -> True
+		EQ -> True
+		GT -> False
 
 pprBagOfWarnings :: Bag WarnMsg -> Pretty.Doc
 pprBagOfWarnings bag_of_warns = pprBagOfErrors bag_of_warns
@@ -140,7 +143,7 @@ pprBagOfWarnings bag_of_warns = pprBagOfErrors bag_of_warns
 ghcExit :: Int -> IO ()
 ghcExit val
   | val == 0  = exitWith ExitSuccess
-  | otherwise = do hPutStr stderr "\nCompilation had errors\n\n"
+  | otherwise = do errorMsg "\nCompilation had errors\n\n"
 	           exitWith (ExitFailure val)
 \end{code}
 
@@ -156,9 +159,7 @@ doIfSet_dyn dflags flag action | dopt flag dflags = action
 
 \begin{code}
 showPass :: DynFlags -> String -> IO ()
-showPass dflags what
-  | verbosity dflags >= 2 = hPutStr stderr ("*** "++what++":\n")
-  | otherwise		  = return ()
+showPass dflags what = compilationPassMsg dflags ("*** "++what++":")
 
 dumpIfSet :: Bool -> String -> SDoc -> IO ()
 dumpIfSet flag hdr doc
@@ -175,9 +176,7 @@ dumpIfSet_core dflags flag hdr doc
 dumpIfSet_dyn :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
 dumpIfSet_dyn dflags flag hdr doc
   | dopt flag dflags || verbosity dflags >= 4 
-  = if   flag `elem` [Opt_D_dump_stix, Opt_D_dump_asm]
-    then printForC stdout (mkDumpDoc hdr doc)
-    else printDump (mkDumpDoc hdr doc)
+  = printDump (mkDumpDoc hdr doc)
   | otherwise
   = return ()
 
@@ -195,4 +194,40 @@ mkDumpDoc hdr doc
 	   text ""]
      where 
         line = text (replicate 20 '=')
+
+-- -----------------------------------------------------------------------------
+-- Outputting messages from the compiler
+
+-- We want all messages to go through one place, so that we can
+-- redirect them if necessary.  For example, when GHC is used as a
+-- library we might want to catch all messages that GHC tries to
+-- output and do something else with them.
+
+ifVerbose :: DynFlags -> Int -> IO () -> IO ()
+ifVerbose dflags val act
+  | verbosity dflags >= val = act
+  | otherwise               = return ()
+
+errorMsg :: String -> IO ()
+errorMsg = putMsg
+
+compilationProgressMsg :: DynFlags -> String -> IO ()
+compilationProgressMsg dflags msg
+  = ifVerbose dflags 1 (putMsg msg)
+
+compilationPassMsg :: DynFlags -> String -> IO ()
+compilationPassMsg dflags msg
+  = ifVerbose dflags 2 (putMsg msg)
+
+debugTraceMsg :: DynFlags -> String -> IO ()
+debugTraceMsg dflags msg
+  = ifVerbose dflags 2 (putMsg msg)
+
+GLOBAL_VAR(msgHandler, hPutStrLn stderr, (String -> IO ()))
+
+setMsgHandler :: (String -> IO ()) -> IO ()
+setMsgHandler handle_msg = writeIORef msgHandler handle_msg
+
+putMsg :: String -> IO ()
+putMsg msg = do h <- readIORef msgHandler; h msg
 \end{code}