[project @ 2005-10-25 12:48:35 by simonmar]

Two changes from Krasimir Angelov, which were required for Visual
Haskell:

  - messaging cleanup throughout the compiler.  DynFlags has a new
    field:

    log_action :: Severity -> SrcSpan -> PprStyle -> Message -> IO ()

    this action is invoked for every message generated by the
    compiler.  This means a client of the GHC API can direct messages to
    any destination, or collect them up in an IORef for later
    perusal.

    This replaces previous hacks to redirect messages in the GHC API
    (hence some changes to function types in GHC.hs).

  - The JustTypecheck mode of GHC now does what it says.  It doesn't
    run any of the compiler passes beyond the typechecker for each module,
    but does generate the ModIface in order that further modules can be
    typechecked.

And one change from me:

  - implement the LANGUAGE pragma, finally

16 files changed, 363 insertions, 222 deletions

diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs
index f94314c053..fc25c9a27e 100644
--- a/ghc/compiler/coreSyn/CoreLint.lhs
+++ b/ghc/compiler/coreSyn/CoreLint.lhs
@@ -67,7 +67,7 @@ endPass dflags pass_name dump_flag binds
 	-- Report result size if required
 	-- This has the side effect of forcing the intermediate to be evaluated
 	debugTraceMsg dflags 2 $
-		"    Result size = " ++ show (coreBindsSize binds)
+		(text "    Result size =" <+> int (coreBindsSize binds))
 
 	-- Report verbosely, if required
 	dumpIfSet_core dflags dump_flag pass_name (pprCoreBindings binds)
@@ -120,7 +120,7 @@ lintCoreBindings dflags whoDunnit binds
   = case (initL (lint_binds binds)) of
       Nothing       -> showPass dflags ("Core Linted result of " ++ whoDunnit)
       Just bad_news -> printDump (display bad_news)	>>
-		       ghcExit 1
+		       ghcExit dflags 1
   where
 	-- Put all the top-level binders in scope at the start
 	-- This is because transformation rules can bring something
diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs
index be5ad1e544..c6e75badc5 100644
--- a/ghc/compiler/deSugar/Desugar.lhs
+++ b/ghc/compiler/deSugar/Desugar.lhs
@@ -12,7 +12,7 @@ import DynFlags		( DynFlag(..), DynFlags(..), dopt, GhcMode(..) )
 import StaticFlags	( opt_SccProfilingOn )
 import DriverPhases	( isHsBoot )
 import HscTypes		( ModGuts(..), HscEnv(..), 
-			  Dependencies(..), TypeEnv, IsBootInterface )
+			  Dependencies(..), ForeignStubs(..), TypeEnv, IsBootInterface )
 import HsSyn		( RuleDecl(..), RuleBndr(..), LHsExpr, LRuleDecl )
 import TcRnTypes	( TcGblEnv(..), ImportAvails(..) )
 import MkIface		( mkUsageInfo )
@@ -35,7 +35,7 @@ import Rules		( roughTopNames )
 import CoreLint		( showPass, endPass )
 import CoreFVs		( ruleRhsFreeVars, exprsFreeNames )
 import Packages	  	( PackageState(thPackageId), PackageIdH(..) )
-import ErrUtils		( doIfSet, dumpIfSet_dyn, pprBagOfWarnings, 
+import ErrUtils		( doIfSet, dumpIfSet_dyn, printBagOfWarnings, 
 			  errorsFound, WarnMsg )
 import ListSetOps	( insertList )
 import Outputable
@@ -79,13 +79,16 @@ deSugar hsc_env
 
 	-- Desugar the program
 	; ((all_prs, ds_rules, ds_fords), warns) 
-		<- initDs hsc_env mod rdr_env type_env $ do
-		{ core_prs <- dsTopLHsBinds auto_scc binds
-		; (ds_fords, foreign_prs) <- dsForeigns fords
-		; let all_prs = foreign_prs ++ core_prs
-		      local_bndrs = mkVarSet (map fst all_prs)
-		; ds_rules <- mappM (dsRule mod local_bndrs) rules
-		; return (all_prs, catMaybes ds_rules, ds_fords) }
+		<- case ghcMode (hsc_dflags hsc_env) of
+	             JustTypecheck -> return (([], [], NoStubs), emptyBag)
+	             _             -> initDs hsc_env mod rdr_env type_env $ do
+		                        { core_prs <- dsTopLHsBinds auto_scc binds
+		                        ; (ds_fords, foreign_prs) <- dsForeigns fords
+		                        ; let all_prs = foreign_prs ++ core_prs
+		                              local_bndrs = mkVarSet (map fst all_prs)
+		                        ; ds_rules <- mappM (dsRule mod local_bndrs) rules
+		                        ; return (all_prs, catMaybes ds_rules, ds_fords)
+		                        }
 
 	-- If warnings are considered errors, leave.
 	; if errorsFound dflags (warns, emptyBag)
@@ -185,7 +188,7 @@ deSugarExpr hsc_env this_mod rdr_env type_env tc_expr
 	-- Display any warnings 
 	-- Note: if -Werror is used, we don't signal an error here.
         ; doIfSet (not (isEmptyBag ds_warns))
-		  (printErrs (pprBagOfWarnings ds_warns))
+		  (printBagOfWarnings dflags ds_warns)
 
 	-- Dump output
 	; dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr core_expr)
diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs
index 67c68d3b16..3469421b18 100644
--- a/ghc/compiler/ghci/InteractiveUI.hs
+++ b/ghc/compiler/ghci/InteractiveUI.hs
@@ -37,7 +37,6 @@ import StaticFlags	( opt_IgnoreDotGhci )
 import Linker		( showLinkerState )
 import Util		( removeSpaces, handle, global, toArgs,
 			  looksLikeModuleName, prefixMatch, sortLe )
-import ErrUtils		( printErrorsAndWarnings )
 
 #ifndef mingw32_HOST_OS
 import System.Posix
@@ -675,7 +674,7 @@ checkModule :: String -> GHCi ()
 checkModule m = do
   let modl = mkModule m
   session <- getSession
-  result <- io (GHC.checkModule session modl printErrorsAndWarnings)
+  result <- io (GHC.checkModule session modl)
   case result of
     Nothing -> io $ putStrLn "Nothing"
     Just r  -> io $ putStrLn (showSDoc (
diff --git a/ghc/compiler/ghci/Linker.lhs b/ghc/compiler/ghci/Linker.lhs
index 81b512feee..162adbf04d 100644
--- a/ghc/compiler/ghci/Linker.lhs
+++ b/ghc/compiler/ghci/Linker.lhs
@@ -623,12 +623,9 @@ unload dflags linkables
 	new_pls <- unload_wkr dflags linkables pls
 	writeIORef v_PersistentLinkerState new_pls
 
-	debugTraceMsg dflags 3 (showSDoc
-		(text "unload: retaining objs" <+> ppr (objs_loaded new_pls)))
-	debugTraceMsg dflags 3 (showSDoc
-		(text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls)))
-
-       	return ()
+	debugTraceMsg dflags 3 (text "unload: retaining objs" <+> ppr (objs_loaded new_pls))
+	debugTraceMsg dflags 3 (text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls))
+	return ()
 
 unload_wkr :: DynFlags
            -> [Linkable]		-- stable linkables
diff --git a/ghc/compiler/main/CodeOutput.lhs b/ghc/compiler/main/CodeOutput.lhs
index 24d67910a4..ce12d0cc0c 100644
--- a/ghc/compiler/main/CodeOutput.lhs
+++ b/ghc/compiler/main/CodeOutput.lhs
@@ -71,7 +71,7 @@ codeOutput dflags this_mod foreign_stubs pkg_deps flat_abstractC
 		; let lints = map cmmLint flat_abstractC
 		; case firstJust lints of
 			Just err -> do { printDump err
-				       ; ghcExit 1
+				       ; ghcExit dflags 1
 				       }
 			Nothing  -> return ()
 		}
diff --git a/ghc/compiler/main/DriverMkDepend.hs b/ghc/compiler/main/DriverMkDepend.hs
index 3e35b758e1..fe2d8f3785 100644
--- a/ghc/compiler/main/DriverMkDepend.hs
+++ b/ghc/compiler/main/DriverMkDepend.hs
@@ -62,15 +62,15 @@ doMkDependHS session srcs
 	; excl_mods <- readIORef v_Dep_exclude_mods
 	; r <- GHC.depanal session excl_mods True {- Allow dup roots -}
 	; case r of
- 	    Left e -> do printErrorsAndWarnings e; exitWith (ExitFailure 1)
-	    Right mod_summaries -> do {
+ 	    Nothing -> exitWith (ExitFailure 1)
+	    Just mod_summaries -> do {
 
 		-- Sort into dependency order
 		-- There should be no cycles
 	  let sorted = GHC.topSortModuleGraph False mod_summaries Nothing
 
 		-- Print out the dependencies if wanted
-	; debugTraceMsg dflags 2 (showSDoc (text "Module dependencies" $$ ppr sorted))
+	; debugTraceMsg dflags 2 (text "Module dependencies" $$ ppr sorted)
 
 		-- Prcess them one by one, dumping results into makefile
 		-- and complaining about cycles
diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs
index 025a09bff2..698cb42c95 100644
--- a/ghc/compiler/main/DriverPipeline.hs
+++ b/ghc/compiler/main/DriverPipeline.hs
@@ -55,6 +55,8 @@ import FastString	( mkFastString )
 import Bag		( listToBag, emptyBag )
 import SrcLoc		( Located(..) )
 
+import Distribution.Compiler ( extensionsToGHCFlag )
+
 import EXCEPTION
 import DATA_IOREF	( readIORef, writeIORef, IORef )
 import GLAEXTS		( Int(..) )
@@ -93,7 +95,6 @@ preprocess dflags (filename, mb_phase) =
 -- NB.  No old interface can also mean that the source has changed.
 
 compile :: HscEnv
-	-> (Messages -> IO ())	-- error message callback
 	-> ModSummary
 	-> Maybe Linkable	-- Just linkable <=> source unchanged
         -> Maybe ModIface       -- Old interface, if available
@@ -108,7 +109,7 @@ data CompResult
    | CompErrs 
 
 
-compile hsc_env msg_act mod_summary maybe_old_linkable old_iface mod_index nmods = do 
+compile hsc_env mod_summary maybe_old_linkable old_iface mod_index nmods = do 
 
    let dflags0     = hsc_dflags hsc_env
        this_mod    = ms_mod mod_summary
@@ -124,16 +125,16 @@ compile hsc_env msg_act mod_summary maybe_old_linkable old_iface mod_index nmods
    let input_fn   = expectJust "compile:hs" (ml_hs_file location) 
    let input_fnpp = expectJust "compile:hspp" (ms_hspp_file mod_summary)
 
-   debugTraceMsg dflags0 2 ("compile: input file " ++ input_fnpp)
+   debugTraceMsg dflags0 2 (text "compile: input file" <+> text input_fnpp)
 
    -- Add in the OPTIONS from the source file
    -- This is nasty: we've done this once already, in the compilation manager
    -- It might be better to cache the flags in the ml_hspp_file field,say
    let hspp_buf = expectJust "compile:hspp_buf" (ms_hspp_buf mod_summary)
-       opts = getOptionsFromStringBuffer hspp_buf
+       opts = getOptionsFromStringBuffer hspp_buf input_fn
    (dflags1,unhandled_flags) <- parseDynamicFlags dflags0 (map snd opts)
    if (not (null unhandled_flags))
-	then do msg_act (optionsErrorMsgs unhandled_flags opts input_fn)
+	then do printErrorsAndWarnings dflags1 (optionsErrorMsgs unhandled_flags opts input_fn)
 		return CompErrs
 	else do
 
@@ -167,7 +168,7 @@ compile hsc_env msg_act mod_summary maybe_old_linkable old_iface mod_index nmods
        object_filename = ml_obj_file location
 
    -- run the compiler
-   hsc_result <- hscMain hsc_env' msg_act mod_summary
+   hsc_result <- hscMain hsc_env' mod_summary
 			 source_unchanged have_object old_iface
                          (Just (mod_index, nmods))
 
@@ -298,15 +299,16 @@ link BatchCompile dflags batch_attempt_linking hpt
 	    -- the linkables to link
 	    linkables = map (fromJust.hm_linkable) home_mod_infos
 
-        debugTraceMsg dflags 3 "link: linkables are ..."
-        debugTraceMsg dflags 3 (showSDoc (vcat (map ppr linkables)))
+        debugTraceMsg dflags 3 (text "link: linkables are ..." $$ vcat (map ppr linkables))
 
 	-- check for the -no-link flag
 	if isNoLink (ghcLink dflags)
-	  then do debugTraceMsg dflags 3 "link(batch): linking omitted (-c flag given)."
+	  then do debugTraceMsg dflags 3 (text "link(batch): linking omitted (-c flag given).")
 	          return Succeeded
 	  else do
 
+	debugTraceMsg dflags 1 (text "Linking ...")
+
 	let getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)
 	    obj_files = concatMap getOfiles linkables
 
@@ -322,23 +324,23 @@ link BatchCompile dflags batch_attempt_linking hpt
 			any (t <) (map linkableTime linkables)
 
 	if dopt Opt_RecompChecking dflags && not linking_needed
-	   then do debugTraceMsg dflags 1 (exe_file ++ " is up to date, linking not required.")
+	   then do debugTraceMsg dflags 1 (text exe_file <+> ptext SLIT("is up to date, linking not required."))
 		   return Succeeded
 	   else do
 
-	debugTraceMsg dflags 1 "Linking ..."
+	debugTraceMsg dflags 1 (ptext SLIT("Linking ..."))
 
 	-- Don't showPass in Batch mode; doLink will do that for us.
         staticLink dflags obj_files pkg_deps
 
-        debugTraceMsg dflags 3 "link: done"
+        debugTraceMsg dflags 3 (text "link: done")
 
 	-- staticLink only returns if it succeeds
         return Succeeded
 
    | otherwise
-   = do debugTraceMsg dflags 3 "link(batch): upsweep (partially) failed OR"
-        debugTraceMsg dflags 3 "   Main.main not exported; not linking."
+   = do debugTraceMsg dflags 3 (text "link(batch): upsweep (partially) failed OR" $$
+                                text "   Main.main not exported; not linking.")
         return Succeeded
       
 
@@ -751,7 +753,7 @@ runPhase (Hsc src_flavour) stop dflags0 basename suff input_fn get_output_fn _ma
 	addHomeModuleToFinder hsc_env mod_name location4
 
   -- run the compiler!
-	result <- hscMain hsc_env printErrorsAndWarnings
+	result <- hscMain hsc_env
 			  mod_summary source_unchanged 
 			  False		-- No object file
 			  Nothing	-- No iface
@@ -1341,14 +1343,19 @@ hsSourceCppOpts =
 -----------------------------------------------------------------------------
 -- Reading OPTIONS pragmas
 
+-- This is really very ugly and should be rewritten.
+--   - some error messages are thrown as exceptions (should return)
+--   - we ignore LINE pragmas
+--   - parsing is horrible, combination of prefixMatch and 'read'.
+
 getOptionsFromSource 
 	:: String		-- input file
 	-> IO [String]		-- options, if any
 getOptionsFromSource file
   = do h <- openFile file ReadMode
-       look h `finally` hClose h
+       look h 1 `finally` hClose h
   where
-	look h = do
+	look h i = do
 	    r <- tryJust ioErrors (hGetLine h)
 	    case r of
 	      Left e | isEOFError e -> return []
@@ -1356,16 +1363,16 @@ getOptionsFromSource file
 	      Right l' -> do
 	    	let l = removeSpaces l'
 	    	case () of
-		    () | null l -> look h
-		       | prefixMatch "#" l -> look h
-		       | prefixMatch "{-# LINE" l -> look h   -- -}
-		       | Just opts <- matchOptions l
-		       	-> do rest <- look h
+		    () | null l -> look h (i+1)
+		       | prefixMatch "#" l -> look h (i+1)
+		       | prefixMatch "{-# LINE" l -> look h (i+1)  -- -} wrong!
+		       | Just opts <- matchOptions i file l
+		       	-> do rest <- look h (i+1)
                               return (opts ++ rest)
 		       | otherwise -> return []
 
-getOptionsFromStringBuffer :: StringBuffer -> [(Int,String)]
-getOptionsFromStringBuffer buffer@(StringBuffer _ len# _) = 
+getOptionsFromStringBuffer :: StringBuffer -> FilePath -> [(Int,String)]
+getOptionsFromStringBuffer buffer@(StringBuffer _ len# _) fn = 
   let 
 	ls = lines (lexemeToString buffer (I# len#))  -- lazy, so it's ok
   in
@@ -1377,37 +1384,57 @@ getOptionsFromStringBuffer buffer@(StringBuffer _ len# _) =
 	    case () of
 		() | null l -> look (i+1) ls
 		   | prefixMatch "#" l -> look (i+1) ls
-		   | prefixMatch "{-# LINE" l -> look (i+1) ls   -- -}
-		   | Just opts <- matchOptions l
+		   | prefixMatch "{-# LINE" l -> look (i+1) ls   -- -} wrong!
+		   | Just opts <- matchOptions i fn l
 			-> zip (repeat i) opts ++ look (i+1) ls
 		   | otherwise -> []
 
 -- detect {-# OPTIONS_GHC ... #-}.  For the time being, we accept OPTIONS
 -- instead of OPTIONS_GHC, but that is deprecated.
-matchOptions s
+matchOptions i fn s
   | Just s1 <- maybePrefixMatch "{-#" s -- -} 
-  = matchOptions1 (removeSpaces s1)
+  = matchOptions1 i fn (removeSpaces s1)
   | otherwise
   = Nothing
  where
-  matchOptions1 s
+  matchOptions1 i fn s
     | Just s2 <- maybePrefixMatch "OPTIONS" s
     = case () of
 	_ | Just s3 <- maybePrefixMatch "_GHC" s2, not (is_ident (head s3))
-	  -> matchOptions2 s3
+	  -> matchOptions2 i fn s3
 	  | not (is_ident (head s2))
-	  -> matchOptions2 s2
+	  -> matchOptions2 i fn s2
 	  | otherwise
 	  -> Just []  -- OPTIONS_anything is ignored, not treated as start of source
     | Just s2 <- maybePrefixMatch "INCLUDE" s, not (is_ident (head s2)),
       Just s3 <- maybePrefixMatch "}-#" (reverse s2)
     = Just ["-#include", removeSpaces (reverse s3)]
+
+    | Just s2 <- maybePrefixMatch "LANGUAGE" s, not (is_ident (head s2)),
+      Just s3 <- maybePrefixMatch "}-#" (reverse s2)
+    = case [ exts | (exts,"") <- reads ('[' : reverse (']':s3))] of
+	[] -> languagePragParseError i fn
+	exts:_ -> case extensionsToGHCFlag exts of
+			([], opts) -> Just opts
+			(unsup,_) -> unsupportedExtnError i fn unsup
     | otherwise = Nothing
-  matchOptions2 s
+  matchOptions2 i fn s
     | Just s3 <- maybePrefixMatch "}-#" (reverse s) = Just (words (reverse s3))
     | otherwise = Nothing
 
 
+languagePragParseError i fn = 
+  pgmError (showSDoc (mkLocMessage loc (
+		text "cannot parse LANGUAGE pragma")))
+  where loc = srcLocSpan (mkSrcLoc (mkFastString fn) i 0)
+
+unsupportedExtnError i fn unsup = 
+  pgmError (showSDoc (mkLocMessage loc (
+		text "unsupported extensions: " <>
+		hcat (punctuate comma (map (text.show) unsup)))))
+  where loc = srcLocSpan (mkSrcLoc (mkFastString fn) i 0)
+
+
 optionsErrorMsgs :: [String] -> [(Int,String)] -> FilePath -> Messages
 optionsErrorMsgs unhandled_flags flags_lines filename
   = (emptyBag, listToBag (map mkMsg unhandled_flags_lines))
diff --git a/ghc/compiler/main/DynFlags.hs b/ghc/compiler/main/DynFlags.hs
index c5156eef94..52e5542509 100644
--- a/ghc/compiler/main/DynFlags.hs
+++ b/ghc/compiler/main/DynFlags.hs
@@ -56,6 +56,7 @@ import Config
 import CmdLineParser
 import Panic		( panic, GhcException(..) )
 import Util		( notNull, splitLongestPrefix, split, normalisePath )
+import SrcLoc           ( SrcSpan )
 
 import DATA_IOREF	( readIORef )
 import EXCEPTION	( throwDyn )
@@ -66,6 +67,9 @@ import Data.List	( isPrefixOf )
 import Maybe		( fromJust )
 import Char		( isDigit, isUpper )
 import Outputable
+import System.IO        ( hPutStrLn, stderr )
+import {-# SOURCE #-} ErrUtils ( Severity(..), Message, mkLocMessage )
+
 -- -----------------------------------------------------------------------------
 -- DynFlags
 
@@ -180,7 +184,7 @@ data DynFlag
    | Opt_KeepTmpFiles
 
    deriving (Eq)
-
+ 
 data DynFlags = DynFlags {
   ghcMode		:: GhcMode,
   ghcLink		:: GhcLink,
@@ -254,7 +258,10 @@ data DynFlags = DynFlags {
   pkgState		:: PackageState,
 
   -- hsc dynamic flags
-  flags      		:: [DynFlag]
+  flags      		:: [DynFlag],
+  
+  -- message output
+  log_action            :: Severity -> SrcSpan -> PprStyle -> Message -> IO ()
  }
 
 data HscTarget
@@ -395,7 +402,13 @@ defaultDynFlags =
     	    Opt_IgnoreInterfacePragmas,
     	    Opt_OmitInterfacePragmas
     
-               ] ++ standardWarnings
+               ] ++ standardWarnings,
+               
+        log_action = \severity srcSpan style msg -> 
+                        case severity of
+                          SevInfo  -> hPutStrLn stderr (show (msg style))
+                          SevFatal -> hPutStrLn stderr (show (msg style))
+                          _        -> hPutStrLn stderr ('\n':show ((mkLocMessage srcSpan msg) style))
       }
 
 {- 
@@ -602,7 +615,6 @@ getCoreToDo dflags
 	    MaxSimplifierIterations max_iter
 	]
       ]
-
      else {- opt_level >= 1 -} [ 
 
 	-- initial simplify: mk specialiser happy: minimum effort please
diff --git a/ghc/compiler/main/ErrUtils.lhs b/ghc/compiler/main/ErrUtils.lhs
index 50db73c3b4..90e5dc87b6 100644
--- a/ghc/compiler/main/ErrUtils.lhs
+++ b/ghc/compiler/main/ErrUtils.lhs
@@ -6,24 +6,25 @@
 \begin{code}
 module ErrUtils (
 	Message, mkLocMessage, printError,
+	Severity(..),
 
 	ErrMsg, WarnMsg,
 	errMsgSpans, errMsgContext, errMsgShortDoc, errMsgExtraInfo,
 	Messages, errorsFound, emptyMessages,
 	mkErrMsg, mkWarnMsg, mkPlainErrMsg, mkLongErrMsg,
-	printErrorsAndWarnings, pprBagOfErrors, pprBagOfWarnings,
+	printErrorsAndWarnings, printBagOfErrors, printBagOfWarnings,
 
 	ghcExit,
 	doIfSet, doIfSet_dyn, 
-	dumpIfSet, dumpIfSet_core, dumpIfSet_dyn, dumpIfSet_dyn_or, mkDumpDoc,
-	showPass,
+	dumpIfSet, dumpIfSet_core, dumpIfSet_dyn, dumpIfSet_dyn_or, mkDumpDoc,	
 
 	--  * Messages during compilation
-	setMsgHandler,
 	putMsg,
-	compilationProgressMsg,
-	debugTraceMsg,
 	errorMsg,
+	fatalErrorMsg,
+	compilationProgressMsg,
+	showPass,
+	debugTraceMsg,	
     ) where
 
 #include "HsVersions.h"
@@ -33,7 +34,7 @@ import SrcLoc		( SrcSpan )
 import Util		( sortLe, global )
 import Outputable
 import qualified Pretty
-import SrcLoc		( srcSpanStart )
+import SrcLoc		( srcSpanStart, noSrcSpan )
 import DynFlags		( DynFlags(..), DynFlag(..), dopt )
 import StaticFlags	( opt_ErrorSpans )
 import System		( ExitCode(..), exitWith )
@@ -47,6 +48,12 @@ import DYNAMIC
 
 type Message = SDoc
 
+data Severity
+  = SevInfo
+  | SevWarning
+  | SevError
+  | SevFatal
+
 mkLocMessage :: SrcSpan -> Message -> Message
 mkLocMessage locn msg
   | opt_ErrorSpans = hang (ppr locn <> colon) 4 msg
@@ -117,22 +124,20 @@ errorsFound dflags (warns, errs)
   | dopt Opt_WarnIsError dflags = not (isEmptyBag errs) || not (isEmptyBag warns)
   | otherwise  		        = not (isEmptyBag errs)
 
-printErrorsAndWarnings :: Messages -> IO ()
-printErrorsAndWarnings (warns, errs)
+printErrorsAndWarnings :: DynFlags -> Messages -> IO ()
+printErrorsAndWarnings dflags (warns, errs)
   | no_errs && no_warns  = return ()
-  | no_errs		 = printErrs (pprBagOfWarnings warns)
+  | no_errs		 = printBagOfWarnings dflags warns
 			    -- Don't print any warnings if there are errors
-  | otherwise		 = printErrs (pprBagOfErrors   errs)
+  | otherwise		 = printBagOfErrors   dflags errs
   where
     no_warns = isEmptyBag warns
     no_errs  = isEmptyBag errs
 
-pprBagOfErrors :: Bag ErrMsg -> Pretty.Doc
-pprBagOfErrors bag_of_errors
-  = Pretty.vcat [ let style = mkErrStyle unqual
-		      doc = mkLocMessage s (d $$ e)
-		  in
-		  Pretty.text "" Pretty.$$ doc style
+printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO ()
+printBagOfErrors dflags bag_of_errors
+  = sequence_   [ let style = mkErrStyle unqual
+		  in log_action dflags SevError s style (d $$ e)
 		| ErrMsg { errMsgSpans = s:ss,
 			   errMsgShortDoc = d,
 			   errMsgExtraInfo = e,
@@ -147,15 +152,30 @@ pprBagOfErrors bag_of_errors
 		EQ -> True
 		GT -> False
 
-pprBagOfWarnings :: Bag WarnMsg -> Pretty.Doc
-pprBagOfWarnings bag_of_warns = pprBagOfErrors bag_of_warns
+printBagOfWarnings :: DynFlags -> Bag ErrMsg -> IO ()
+printBagOfWarnings dflags bag_of_warns
+  = sequence_   [ let style = mkErrStyle unqual
+		  in log_action dflags SevWarning s style (d $$ e)
+		| ErrMsg { errMsgSpans = s:ss,
+			   errMsgShortDoc = d,
+			   errMsgExtraInfo = e,
+			   errMsgContext = unqual } <- sorted_errs ]
+    where
+      bag_ls	  = bagToList bag_of_warns
+      sorted_errs = sortLe occ'ed_before bag_ls
+
+      occ'ed_before err1 err2 = 
+         case compare (head (errMsgSpans err1)) (head (errMsgSpans err2)) of
+		LT -> True
+		EQ -> True
+		GT -> False
 \end{code}
 
 \begin{code}
-ghcExit :: Int -> IO ()
-ghcExit val
+ghcExit :: DynFlags -> Int -> IO ()
+ghcExit dflags val
   | val == 0  = exitWith ExitSuccess
-  | otherwise = do errorMsg "\nCompilation had errors\n\n"
+  | otherwise = do errorMsg dflags (text "\nCompilation had errors\n\n")
 	           exitWith (ExitFailure val)
 \end{code}
 
@@ -170,9 +190,6 @@ doIfSet_dyn dflags flag action | dopt flag dflags = action
 \end{code}
 
 \begin{code}
-showPass :: DynFlags -> String -> IO ()
-showPass dflags what = compilationPassMsg dflags ("*** "++what++":")
-
 dumpIfSet :: Bool -> String -> SDoc -> IO ()
 dumpIfSet flag hdr doc
   | not flag   = return ()
@@ -220,26 +237,24 @@ ifVerbose dflags val act
   | verbosity dflags >= val = act
   | otherwise               = return ()
 
-errorMsg :: String -> IO ()
-errorMsg = putMsg
+putMsg :: DynFlags -> Message -> IO ()
+putMsg dflags msg = log_action dflags SevInfo noSrcSpan defaultUserStyle msg
+
+errorMsg :: DynFlags -> Message -> IO ()
+errorMsg dflags msg = log_action dflags SevError noSrcSpan defaultErrStyle msg
+
+fatalErrorMsg :: DynFlags -> Message -> IO ()
+fatalErrorMsg dflags msg = log_action dflags SevFatal noSrcSpan defaultErrStyle msg
 
 compilationProgressMsg :: DynFlags -> String -> IO ()
 compilationProgressMsg dflags msg
-  = ifVerbose dflags 1 (putMsg msg)
+  = ifVerbose dflags 1 (log_action dflags SevInfo noSrcSpan defaultUserStyle (text msg))
 
-compilationPassMsg :: DynFlags -> String -> IO ()
-compilationPassMsg dflags msg
-  = ifVerbose dflags 2 (putMsg msg)
+showPass :: DynFlags -> String -> IO ()
+showPass dflags what 
+  = ifVerbose dflags 2 (log_action dflags SevInfo noSrcSpan defaultUserStyle (text "***" <+> text what <> colon))
 
-debugTraceMsg :: DynFlags -> Int -> String -> IO ()
+debugTraceMsg :: DynFlags -> Int -> Message -> IO ()
 debugTraceMsg dflags val msg
-  = ifVerbose dflags val (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
+  = ifVerbose dflags val (log_action dflags SevInfo noSrcSpan defaultDumpStyle msg)
 \end{code}
diff --git a/ghc/compiler/main/GHC.hs b/ghc/compiler/main/GHC.hs
index 938757bb55..e222579a06 100644
--- a/ghc/compiler/main/GHC.hs
+++ b/ghc/compiler/main/GHC.hs
@@ -15,12 +15,11 @@ module GHC (
 	newSession,
 
 	-- * Flags and settings
-	DynFlags(..), DynFlag(..), GhcMode(..), HscTarget(..), dopt,
+	DynFlags(..), DynFlag(..), Severity(..), GhcMode(..), HscTarget(..), dopt,
 	parseDynamicFlags,
 	initPackages,
 	getSessionDynFlags,
 	setSessionDynFlags,
-	setMsgHandler,
 
 	-- * Targets
 	Target(..), TargetId(..), Phase,
@@ -33,7 +32,6 @@ module GHC (
 	-- * Loading\/compiling the program
 	depanal,
 	load, LoadHowMuch(..), SuccessFlag(..),	-- also does depanal
-	loadMsgs,
 	workingDirectoryChanged,
 	checkModule, CheckedModule(..),
 	TypecheckedSource, ParsedSource, RenamedSource,
@@ -220,9 +218,9 @@ import Module
 import FiniteMap
 import Panic
 import Digraph
-import Bag		( unitBag, emptyBag )
-import ErrUtils		( showPass, Messages, putMsg, debugTraceMsg,
-			  mkPlainErrMsg, pprBagOfErrors )
+import Bag		( unitBag )
+import ErrUtils		( Severity(..), showPass, Messages, fatalErrorMsg, debugTraceMsg,
+			  mkPlainErrMsg, printBagOfErrors, printErrorsAndWarnings )
 import qualified ErrUtils
 import Util
 import StringBuffer	( StringBuffer, hGetStringBuffer )
@@ -252,23 +250,25 @@ import Prelude hiding (init)
 -- Unless you want to handle exceptions yourself, you should wrap this around
 -- the top level of your program.  The default handlers output the error
 -- message(s) to stderr and exit cleanly.
-defaultErrorHandler :: IO a -> IO a
-defaultErrorHandler inner = 
+defaultErrorHandler :: DynFlags -> IO a -> IO a
+defaultErrorHandler dflags inner = 
   -- top-level exception handler: any unrecognised exception is a compiler bug.
   handle (\exception -> do
   	   hFlush stdout
 	   case exception of
 		-- an IO exception probably isn't our fault, so don't panic
-		IOException _ ->  putMsg (show exception)
+		IOException _ ->
+		  fatalErrorMsg dflags (text (show exception))
 		AsyncException StackOverflow ->
-			putMsg "stack overflow: use +RTS -K<size> to increase it"
-		_other ->  putMsg (show (Panic (show exception)))
+		  fatalErrorMsg dflags (text "stack overflow: use +RTS -K<size> to increase it")
+		_other ->
+		  fatalErrorMsg dflags (text (show (Panic (show exception))))
 	   exitWith (ExitFailure 1)
          ) $
 
   -- program errors: messages with locations attached.  Sometimes it is
   -- convenient to just throw these as exceptions.
-  handleDyn (\dyn -> do printErrs (pprBagOfErrors (unitBag dyn))
+  handleDyn (\dyn -> do printBagOfErrors dflags (unitBag dyn)
 			exitWith (ExitFailure 1)) $
 
   -- error messages propagated as exceptions
@@ -277,7 +277,7 @@ defaultErrorHandler inner =
   		case dyn of
 		     PhaseFailed _ code -> exitWith code
 		     Interrupted -> exitWith (ExitFailure 1)
-		     _ -> do putMsg (show (dyn :: GhcException))
+		     _ -> do fatalErrorMsg dflags (text (show (dyn :: GhcException)))
 			     exitWith (ExitFailure 1)
 	    ) $
   inner
@@ -353,12 +353,6 @@ getSessionDynFlags s = withSession s (return . hsc_dflags)
 setSessionDynFlags :: Session -> DynFlags -> IO ()
 setSessionDynFlags s dflags = modifySession s (\h -> h{ hsc_dflags = dflags })
 
--- | Messages during compilation (eg. warnings and progress messages)
--- are reported using this callback.  By default, these messages are
--- printed to stderr.
-setMsgHandler :: (String -> IO ()) -> IO ()
-setMsgHandler = ErrUtils.setMsgHandler
-
 -- -----------------------------------------------------------------------------
 -- Targets
 
@@ -422,7 +416,7 @@ guessTarget file Nothing
 
 -- Perform a dependency analysis starting from the current targets
 -- and update the session with the new module graph.
-depanal :: Session -> [Module] -> Bool -> IO (Either Messages ModuleGraph)
+depanal :: Session -> [Module] -> Bool -> IO (Maybe ModuleGraph)
 depanal (Session ref) excluded_mods allow_dup_roots = do
   hsc_env <- readIORef ref
   let
@@ -433,13 +427,13 @@ depanal (Session ref) excluded_mods allow_dup_roots = do
 	
   showPass dflags "Chasing dependencies"
   when (gmode == BatchCompile) $
-	debugTraceMsg dflags 1 (showSDoc (hcat [
+	debugTraceMsg dflags 1 (hcat [
 		     text "Chasing modules from: ",
-	     		hcat (punctuate comma (map pprTarget targets))]))
+	     		hcat (punctuate comma (map pprTarget targets))])
 
   r <- downsweep hsc_env old_graph excluded_mods allow_dup_roots
   case r of
-    Right mod_graph -> writeIORef ref hsc_env{ hsc_mod_graph = mod_graph }
+    Just mod_graph -> writeIORef ref hsc_env{ hsc_mod_graph = mod_graph }
     _ -> return ()
   return r
 
@@ -468,24 +462,18 @@ data LoadHowMuch
 -- attempt to load up to this target.  If no Module is supplied,
 -- then try to load all targets.
 load :: Session -> LoadHowMuch -> IO SuccessFlag
-load session how_much = 
-   loadMsgs session how_much ErrUtils.printErrorsAndWarnings
-
--- | Version of 'load' that takes a callback function to be invoked
--- on compiler errors and warnings as they occur during compilation.
-loadMsgs :: Session -> LoadHowMuch -> (Messages-> IO ()) -> IO SuccessFlag
-loadMsgs s@(Session ref) how_much msg_act
+load s@(Session ref) how_much
    = do 
 	-- Dependency analysis first.  Note that this fixes the module graph:
 	-- even if we don't get a fully successful upsweep, the full module
 	-- graph is still retained in the Session.  We can tell which modules
 	-- were successfully loaded by inspecting the Session's HPT.
 	mb_graph <- depanal s [] False
-	case mb_graph of
-	   Left msgs       -> do msg_act msgs; return Failed
-	   Right mod_graph -> loadMsgs2 s how_much msg_act mod_graph 
+	case mb_graph of	   
+	   Just mod_graph -> load2 s how_much mod_graph 
+	   Nothing        -> return Failed
 
-loadMsgs2 s@(Session ref) how_much msg_act mod_graph = do
+load2 s@(Session ref) how_much mod_graph = do
 	hsc_env <- readIORef ref
 
         let hpt1      = hsc_HPT hsc_env
@@ -524,8 +512,8 @@ loadMsgs2 s@(Session ref) how_much msg_act mod_graph = do
 
 	evaluate pruned_hpt
 
-	debugTraceMsg dflags 2 (showSDoc (text "Stable obj:" <+> ppr stable_obj $$
-				text "Stable BCO:" <+> ppr stable_bco))
+	debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$
+				text "Stable BCO:" <+> ppr stable_bco)
 
 	-- Unload any modules which are going to be re-linked this time around.
 	let stable_linkables = [ linkable
@@ -587,7 +575,7 @@ loadMsgs2 s@(Session ref) how_much msg_act mod_graph = do
 
         (upsweep_ok, hsc_env1, modsUpswept)
            <- upsweep (hsc_env { hsc_HPT = emptyHomePackageTable })
-			   pruned_hpt stable_mods cleanup msg_act mg
+			   pruned_hpt stable_mods cleanup mg
 
 	-- Make modsDone be the summaries for each home module now
 	-- available; this should equal the domain of hpt3.
@@ -602,7 +590,7 @@ loadMsgs2 s@(Session ref) how_much msg_act mod_graph = do
 
          then 
            -- Easy; just relink it all.
-           do debugTraceMsg dflags 2 "Upsweep completely successful."
+           do debugTraceMsg dflags 2 (text "Upsweep completely successful.")
 
 	      -- Clean up after ourselves
 	      cleanTempFilesExcept dflags (ppFilesFromSummaries modsDone)
@@ -624,9 +612,9 @@ loadMsgs2 s@(Session ref) how_much msg_act mod_graph = do
 		do_linking = a_root_is_Main || no_hs_main
 
 	      when (ghci_mode == BatchCompile && isJust ofile && not do_linking) $
-	        debugTraceMsg dflags 1 ("Warning: output was redirected with -o, " ++
-				   "but no output will be generated\n" ++
-				   "because there is no " ++ main_mod ++ " module.")
+	        debugTraceMsg dflags 1 (text ("Warning: output was redirected with -o, " ++
+				              "but no output will be generated\n" ++
+				              "because there is no " ++ main_mod ++ " module."))
 
 	      -- link everything together
               linkresult <- link ghci_mode dflags do_linking (hsc_HPT hsc_env1)
@@ -637,7 +625,7 @@ loadMsgs2 s@(Session ref) how_much msg_act mod_graph = do
            -- Tricky.  We need to back out the effects of compiling any
            -- half-done cycles, both so as to clean up the top level envs
            -- and to avoid telling the interactive linker to link them.
-           do debugTraceMsg dflags 2 "Upsweep partially successful."
+           do debugTraceMsg dflags 2 (text "Upsweep partially successful.")
 
               let modsDone_names
                      = map ms_mod modsDone
@@ -730,11 +718,10 @@ type TypecheckedSource = LHsBinds Id
 -- for a module.  'checkModule' loads all the dependencies of the specified
 -- module in the Session, and then attempts to typecheck the module.  If
 -- successful, it returns the abstract syntax for the module.
-checkModule :: Session -> Module -> (Messages -> IO ()) 
-	-> IO (Maybe CheckedModule)
-checkModule session@(Session ref) mod msg_act = do
+checkModule :: Session -> Module -> IO (Maybe CheckedModule)
+checkModule session@(Session ref) mod = do
 	-- load up the dependencies first
-   r <- loadMsgs session (LoadDependenciesOf mod) msg_act
+   r <- load session (LoadDependenciesOf mod)
    if (failed r) then return Nothing else do
 
 	-- now parse & typecheck the module
@@ -749,15 +736,15 @@ checkModule session@(Session ref) mod msg_act = do
 	   -- ml_hspp_file field, say
 	   let dflags0 = hsc_dflags hsc_env
 	       hspp_buf = expectJust "GHC.checkModule" (ms_hspp_buf ms)
-	       opts = getOptionsFromStringBuffer hspp_buf
+	       filename = fromJust (ml_hs_file (ms_location ms))
+	       opts = getOptionsFromStringBuffer hspp_buf filename
 	   (dflags1,leftovers) <- parseDynamicFlags dflags0 (map snd opts)
 	   if (not (null leftovers))
-		then do let filename = fromJust (ml_hs_file (ms_location ms))
-			msg_act (optionsErrorMsgs leftovers opts filename)
+		then do printErrorsAndWarnings dflags1 (optionsErrorMsgs leftovers opts filename)
 		        return Nothing
 		else do
 
-	   r <- hscFileCheck hsc_env{hsc_dflags=dflags1} msg_act ms
+	   r <- hscFileCheck hsc_env{hsc_dflags=dflags1} ms
 	   case r of
 		HscFail -> 
 		   return Nothing
@@ -981,31 +968,30 @@ upsweep
     -> HomePackageTable		-- HPT from last time round (pruned)
     -> ([Module],[Module])	-- stable modules (see checkStability)
     -> IO ()			-- How to clean up unwanted tmp files
-    -> (Messages -> IO ())	-- Compiler error message callback
     -> [SCC ModSummary]		-- Mods to do (the worklist)
     -> IO (SuccessFlag,
            HscEnv,		-- With an updated HPT
            [ModSummary])	-- Mods which succeeded
 
-upsweep hsc_env old_hpt stable_mods cleanup msg_act mods
-   = upsweep' hsc_env old_hpt stable_mods cleanup msg_act mods 1 (length mods)
+upsweep hsc_env old_hpt stable_mods cleanup mods
+   = upsweep' hsc_env old_hpt stable_mods cleanup mods 1 (length mods)
 
-upsweep' hsc_env old_hpt stable_mods cleanup msg_act
+upsweep' hsc_env old_hpt stable_mods cleanup
      [] _ _
    = return (Succeeded, hsc_env, [])
 
-upsweep' hsc_env old_hpt stable_mods cleanup msg_act
+upsweep' hsc_env old_hpt stable_mods cleanup
      (CyclicSCC ms:_) _ _
-   = do putMsg (showSDoc (cyclicModuleErr ms))
+   = do fatalErrorMsg (hsc_dflags hsc_env) (cyclicModuleErr ms)
         return (Failed, hsc_env, [])
 
-upsweep' hsc_env old_hpt stable_mods cleanup msg_act
+upsweep' hsc_env old_hpt stable_mods cleanup
      (AcyclicSCC mod:mods) mod_index nmods
    = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++ 
 	--	     show (map (moduleUserString.moduleName.mi_module.hm_iface) 
 	--		       (moduleEnvElts (hsc_HPT hsc_env)))
 
-        mb_mod_info <- upsweep_mod hsc_env old_hpt stable_mods msg_act mod 
+        mb_mod_info <- upsweep_mod hsc_env old_hpt stable_mods mod 
                        mod_index nmods
 
 	cleanup		-- Remove unwanted tmp files between compilations
@@ -1031,7 +1017,7 @@ upsweep' hsc_env old_hpt stable_mods cleanup msg_act
 
 		; (restOK, hsc_env2, modOKs) 
 			<- upsweep' hsc_env1 old_hpt1 stable_mods cleanup 
-				msg_act mods (mod_index+1) nmods
+				mods (mod_index+1) nmods
 		; return (restOK, hsc_env2, mod:modOKs)
 		}
 
@@ -1041,13 +1027,12 @@ upsweep' hsc_env old_hpt stable_mods cleanup msg_act
 upsweep_mod :: HscEnv
             -> HomePackageTable
 	    -> ([Module],[Module])
-	    -> (Messages -> IO ())
             -> ModSummary
             -> Int  -- index of module
             -> Int  -- total number of modules
             -> IO (Maybe HomeModInfo)	-- Nothing => Failed
 
-upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) msg_act summary mod_index nmods
+upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods
    = do 
         let 
 	    this_mod    = ms_mod summary
@@ -1057,7 +1042,7 @@ upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) msg_act summary mod_index n
 
 	    compile_it :: Maybe Linkable -> IO (Maybe HomeModInfo)
 	    compile_it  = upsweep_compile hsc_env old_hpt this_mod 
-				msg_act summary mod_index nmods
+				summary mod_index nmods
 
 	case ghcMode (hsc_dflags hsc_env) of
 	    BatchCompile ->
@@ -1110,7 +1095,7 @@ upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) msg_act summary mod_index n
 		    old_hmi = lookupModuleEnv old_hpt this_mod
 
 -- Run hsc to compile a module
-upsweep_compile hsc_env old_hpt this_mod msg_act summary
+upsweep_compile hsc_env old_hpt this_mod summary
                 mod_index nmods
                 mb_old_linkable = do
   let
@@ -1132,7 +1117,7 @@ upsweep_compile hsc_env old_hpt this_mod msg_act summary
 				   where 
 				     iface = hm_iface hm_info
 
-  compresult <- compile hsc_env msg_act summary mb_old_linkable mb_old_iface
+  compresult <- compile hsc_env summary mb_old_linkable mb_old_iface
                         mod_index nmods
 
   case compresult of
@@ -1259,18 +1244,18 @@ downsweep :: HscEnv
 	  -> Bool		-- True <=> allow multiple targets to have 
 				-- 	    the same module name; this is 
 				--	    very useful for ghc -M
-	  -> IO (Either Messages [ModSummary])
+	  -> IO (Maybe [ModSummary])
 		-- The elts of [ModSummary] all have distinct
 		-- (Modules, IsBoot) identifiers, unless the Bool is true
 		-- in which case there can be repeats
 downsweep hsc_env old_summaries excl_mods allow_dup_roots
    = -- catch error messages and return them
-     handleDyn (\err_msg -> return (Left (emptyBag, unitBag err_msg))) $ do
+     handleDyn (\err_msg -> printBagOfErrors (hsc_dflags hsc_env) (unitBag err_msg) >> return Nothing) $ do
        rootSummaries <- mapM getRootSummary roots
        let root_map = mkRootMap rootSummaries
        checkDuplicates root_map
        summs <- loop (concatMap msDeps rootSummaries) root_map
-       return (Right summs)
+       return (Just summs)
      where
 	roots = hsc_targets hsc_env
 
@@ -1555,7 +1540,7 @@ preprocessFile dflags src_fn mb_phase (Just (buf, time))
   = do
 	-- case we bypass the preprocessing stage?
 	let 
-	    local_opts = getOptionsFromStringBuffer buf
+	    local_opts = getOptionsFromStringBuffer buf src_fn
 	--
 	(dflags', errs) <- parseDynamicFlags dflags (map snd local_opts)
 
diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs
index 187f6442f3..2586340eda 100644
--- a/ghc/compiler/main/HscMain.lhs
+++ b/ghc/compiler/main/HscMain.lhs
@@ -157,7 +157,6 @@ type MessageAction = Messages -> IO ()
 
 hscMain
   :: HscEnv
-  -> MessageAction	-- What to do with errors/warnings
   -> ModSummary
   -> Bool		-- True <=> source unchanged
   -> Bool		-- True <=> have an object file (for msgs only)
@@ -165,7 +164,7 @@ hscMain
   -> Maybe (Int, Int)   -- Just (i,n) <=> module i of n (for msgs)
   -> IO HscResult
 
-hscMain hsc_env msg_act mod_summary
+hscMain hsc_env mod_summary
 	source_unchanged have_object maybe_old_iface
         mb_mod_index
  = do {
@@ -178,14 +177,14 @@ hscMain hsc_env msg_act mod_summary
           what_next | recomp_reqd || no_old_iface = hscRecomp 
                     | otherwise                   = hscNoRecomp
 
-      ; what_next hsc_env msg_act mod_summary have_object 
+      ; what_next hsc_env mod_summary have_object 
 		  maybe_checked_iface
                   mb_mod_index
       }
 
 
 ------------------------------
-hscNoRecomp hsc_env msg_act mod_summary 
+hscNoRecomp hsc_env mod_summary 
 	    have_object (Just old_iface)
             mb_mod_index
  | isOneShot (ghcMode (hsc_dflags hsc_env))
@@ -210,36 +209,38 @@ hscNoRecomp hsc_env msg_act mod_summary
 	; return (HscNoRecomp new_details old_iface)
     }
 
-hscNoRecomp hsc_env msg_act mod_summary 
+hscNoRecomp hsc_env mod_summary 
 	    have_object Nothing
 	    mb_mod_index
   = panic "hscNoRecomp"	-- hscNoRecomp definitely expects to 
 			-- have the old interface available
 
 ------------------------------
-hscRecomp hsc_env msg_act mod_summary
+hscRecomp hsc_env mod_summary
 	  have_object maybe_old_iface
           mb_mod_index
  = case ms_hsc_src mod_summary of
-     HsSrcFile -> do 
-	front_res <- hscFileFrontEnd hsc_env msg_act mod_summary mb_mod_index
-	hscBackEnd hsc_env mod_summary maybe_old_iface front_res
+     HsSrcFile -> do
+	front_res <- hscFileFrontEnd hsc_env mod_summary mb_mod_index
+	case ghcMode (hsc_dflags hsc_env) of
+	  JustTypecheck -> hscBootBackEnd hsc_env mod_summary maybe_old_iface front_res
+	  _             -> hscBackEnd     hsc_env mod_summary maybe_old_iface front_res
 
      HsBootFile -> do
-	front_res <- hscFileFrontEnd hsc_env msg_act mod_summary mb_mod_index
+	front_res <- hscFileFrontEnd hsc_env mod_summary mb_mod_index
 	hscBootBackEnd hsc_env mod_summary maybe_old_iface front_res
 
      ExtCoreFile -> do
-	front_res <- hscCoreFrontEnd hsc_env msg_act mod_summary
+	front_res <- hscCoreFrontEnd hsc_env mod_summary
 	hscBackEnd hsc_env mod_summary maybe_old_iface front_res
 
-hscCoreFrontEnd hsc_env msg_act mod_summary = do {
+hscCoreFrontEnd hsc_env mod_summary = do {
  	    -------------------
  	    -- PARSE
  	    -------------------
 	; inp <- readFile (expectJust "hscCoreFrontEnd" (ms_hspp_file mod_summary))
 	; case parseCore inp 1 of
-	    FailP s        -> putMsg s{-ToDo: wrong-} >> return Nothing
+	    FailP s        -> errorMsg (hsc_dflags hsc_env) (text s{-ToDo: wrong-}) >> return Nothing
 	    OkP rdr_module -> do {
     
  	    -------------------
@@ -247,20 +248,20 @@ hscCoreFrontEnd hsc_env msg_act mod_summary = do {
  	    -------------------
 	; (tc_msgs, maybe_tc_result) <- {-# SCC "TypeCheck" #-}
 			      tcRnExtCore hsc_env rdr_module
-	; msg_act tc_msgs
+	; printErrorsAndWarnings (hsc_dflags hsc_env) tc_msgs
 	; case maybe_tc_result of
       	     Nothing       -> return Nothing
       	     Just mod_guts -> return (Just mod_guts)	-- No desugaring to do!
 	}}
 	 
 
-hscFileFrontEnd hsc_env msg_act mod_summary mb_mod_index = do {
+hscFileFrontEnd hsc_env mod_summary mb_mod_index = do {
  	    -------------------
  	    -- DISPLAY PROGRESS MESSAGE
  	    -------------------
-	  let one_shot  = isOneShot (ghcMode (hsc_dflags hsc_env))
-      	; let dflags    = hsc_dflags hsc_env
-	; let toInterp  = hscTarget dflags == HscInterpreted
+	; let dflags    = hsc_dflags hsc_env
+	      one_shot  = isOneShot (ghcMode dflags)
+	      toInterp  = hscTarget dflags == HscInterpreted
       	; when (not one_shot) $
 		 compilationProgressMsg dflags $
 		 (showModuleIndex mb_mod_index ++
@@ -272,10 +273,10 @@ hscFileFrontEnd hsc_env msg_act mod_summary mb_mod_index = do {
 	; let hspp_file = expectJust "hscFileFrontEnd" (ms_hspp_file mod_summary)
 	      hspp_buf  = ms_hspp_buf  mod_summary
 
-	; maybe_parsed <- myParseModule (hsc_dflags hsc_env) hspp_file hspp_buf
+	; maybe_parsed <- myParseModule dflags hspp_file hspp_buf
 
 	; case maybe_parsed of {
-      	     Left err -> do { msg_act (unitBag err, emptyBag)
+      	     Left err -> do { printBagOfErrors dflags (unitBag err)
 			    ; return Nothing } ;
       	     Right rdr_module -> do {
 
@@ -286,7 +287,7 @@ hscFileFrontEnd hsc_env msg_act mod_summary mb_mod_index = do {
 		<- {-# SCC "Typecheck-Rename" #-}
 		   tcRnModule hsc_env (ms_hsc_src mod_summary) False rdr_module
 
-	; msg_act tc_msgs
+	; printErrorsAndWarnings dflags tc_msgs
 	; case maybe_tc_result of {
       	     Nothing -> return Nothing ;
       	     Just tc_result -> do {
@@ -296,24 +297,25 @@ hscFileFrontEnd hsc_env msg_act mod_summary mb_mod_index = do {
  	    -------------------
 	; (warns, maybe_ds_result) <- {-# SCC "DeSugar" #-}
 		 	     deSugar hsc_env tc_result
-	; msg_act (warns, emptyBag)
+	; printBagOfWarnings dflags warns
 	; return maybe_ds_result
 	}}}}}
 
 ------------------------------
 
-hscFileCheck :: HscEnv -> MessageAction -> ModSummary -> IO HscResult
-hscFileCheck hsc_env msg_act mod_summary = do {
+hscFileCheck :: HscEnv -> ModSummary -> IO HscResult
+hscFileCheck hsc_env mod_summary = do {
  	    -------------------
  	    -- PARSE
  	    -------------------
-	; let hspp_file = expectJust "hscFileFrontEnd" (ms_hspp_file mod_summary)
+	; let dflags    = hsc_dflags hsc_env
+	      hspp_file = expectJust "hscFileFrontEnd" (ms_hspp_file mod_summary)
 	      hspp_buf  = ms_hspp_buf  mod_summary
 
-	; maybe_parsed <- myParseModule (hsc_dflags hsc_env) hspp_file hspp_buf
+	; maybe_parsed <- myParseModule dflags hspp_file hspp_buf
 
 	; case maybe_parsed of {
-      	     Left err -> do { msg_act (unitBag err, emptyBag)
+      	     Left err -> do { printBagOfErrors dflags (unitBag err)
 			    ; return HscFail } ;
       	     Right rdr_module -> do {
 
@@ -326,7 +328,7 @@ hscFileCheck hsc_env msg_act mod_summary = do {
 			True{-save renamed syntax-}
 			rdr_module
 
-	; msg_act tc_msgs
+	; printErrorsAndWarnings dflags tc_msgs
 	; case maybe_tc_result of {
       	     Nothing -> return (HscChecked rdr_module Nothing Nothing);
       	     Just tc_result -> do
@@ -655,7 +657,7 @@ hscTcExpr hsc_env expr
 	     Nothing      -> return Nothing ;	-- Parse error
 	     Just (Just (L _ (ExprStmt expr _ _)))
 			-> tcRnExpr hsc_env icontext expr ;
-	     Just other -> do { errorMsg ("not an expression: `" ++ expr ++ "'") ;
+	     Just other -> do { errorMsg (hsc_dflags hsc_env) (text "not an expression:" <+> quotes (text expr)) ;
 			        return Nothing } ;
       	     } }
 
@@ -669,7 +671,7 @@ hscKcType hsc_env str
 	; let icontext = hsc_IC hsc_env
 	; case maybe_type of {
 	     Just ty	-> tcRnType hsc_env icontext ty ;
-	     Just other -> do { errorMsg ("not an type: `" ++ str ++ "'") ;
+	     Just other -> do { errorMsg (hsc_dflags hsc_env) (text "not an type:" <+> quotes (text str)) ;
 			        return Nothing } ;
       	     Nothing    -> return Nothing } }
 #endif
diff --git a/ghc/compiler/main/Main.hs b/ghc/compiler/main/Main.hs
index f38bcc48de..a9c4122fe4 100644
--- a/ghc/compiler/main/Main.hs
+++ b/ghc/compiler/main/Main.hs
@@ -32,6 +32,7 @@ import Packages		( dumpPackages, initPackages )
 import DriverPhases	( Phase(..), isSourceFilename, anyHsc,
 			  startPhase, isHaskellSrcFilename )
 import StaticFlags	( staticFlags, v_Ld_inputs )
+import DynFlags         ( defaultDynFlags )
 import BasicTypes	( failed )
 import Util
 import Panic
@@ -58,7 +59,7 @@ import Maybe
 -- GHC's command-line interface
 
 main =
-  GHC.defaultErrorHandler $ do
+  GHC.defaultErrorHandler defaultDynFlags $ do
   
   argv0 <- getArgs
   argv1 <- GHC.init argv0
diff --git a/ghc/compiler/main/Packages.lhs b/ghc/compiler/main/Packages.lhs
index 85cf4ac55b..5f32acca34 100644
--- a/ghc/compiler/main/Packages.lhs
+++ b/ghc/compiler/main/Packages.lhs
@@ -13,7 +13,8 @@ module Packages (
 
 	-- * Reading the package config, and processing cmdline args
 	PackageIdH(..), isHomePackage,
-	PackageState(..), 
+	PackageState(..),
+	mkPackageState,
 	initPackages,
 	getPackageDetails,
 	checkForPackageConflicts,
@@ -238,7 +239,7 @@ readPackageConfigs dflags = do
 readPackageConfig
    :: DynFlags -> PackageConfigMap -> FilePath -> IO PackageConfigMap
 readPackageConfig dflags pkg_map conf_file = do
-  debugTraceMsg dflags 2 ("Using package config file: " ++ conf_file)
+  debugTraceMsg dflags 2 (text "Using package config file:" <+> text conf_file)
   proto_pkg_configs <- loadPackageConfig conf_file
   top_dir 	    <- getTopDir
   let pkg_configs1 = mungePackagePaths top_dir proto_pkg_configs
@@ -342,9 +343,9 @@ mkPackageState dflags orig_pkg_db = do
 	   | not (exposed p) = return p
 	   | (p' : _) <- later_versions = do
 		debugTraceMsg dflags 2 $
-		   ("hiding package " ++ showPackageId (package p) ++
-		    " to avoid conflict with later version " ++
-		    showPackageId (package p'))
+		   (ptext SLIT("hiding package") <+> text (showPackageId (package p)) <+>
+		    ptext SLIT("to avoid conflict with later version") <+>
+		    text (showPackageId (package p')))
 		return (p {exposed=False})
 	   | otherwise = return p
 	  where myname = pkgName (package p)
@@ -370,7 +371,7 @@ mkPackageState dflags orig_pkg_db = do
 		 elimDanglingDeps (map fst qs)
 
 	reportElim (p, deps) = 
-		debugTraceMsg dflags 2 $ showSDoc $
+		debugTraceMsg dflags 2 $
 		   (ptext SLIT("package") <+> pprPkg p <+> 
 			ptext SLIT("will be ignored due to missing dependencies:") $$ 
 		    nest 2 (hsep (map (text.showPackageId) deps)))
@@ -710,6 +711,6 @@ dumpPackages :: DynFlags -> IO ()
 -- Show package info on console, if verbosity is >= 3
 dumpPackages dflags
   = do  let pkg_map = pkgIdMap (pkgState dflags)
-	putMsg $ showSDoc $
+	putMsg dflags $
 	      vcat (map (text.showInstalledPackageInfo) (eltsUFM pkg_map))
 \end{code}
diff --git a/ghc/compiler/main/SysTools.lhs b/ghc/compiler/main/SysTools.lhs
index c08ebe4129..d6ed73743e 100644
--- a/ghc/compiler/main/SysTools.lhs
+++ b/ghc/compiler/main/SysTools.lhs
@@ -47,7 +47,7 @@ module SysTools (
 import DriverPhases     ( isHaskellUserSrcFilename )
 import Config
 import Outputable
-import ErrUtils		( putMsg, debugTraceMsg )
+import ErrUtils		( putMsg, debugTraceMsg, showPass, Severity(..), Messages )
 import Panic		( GhcException(..) )
 import Util		( Suffix, global, notNull, consIORef, joinFileName,
 			  normalisePath, pgmPath, platformPath, joinFileExt )
@@ -91,7 +91,13 @@ import Compat.RawSystem	( rawSystem )
 import GHC.IOBase       ( IOErrorType(..) ) 
 import System.IO.Error  ( ioeGetErrorType )
 #else
-import System.Cmd	( rawSystem )
+import System.Process	( runInteractiveProcess, getProcessExitCode )
+import System.IO        ( hSetBuffering, hGetLine, BufferMode(..) )
+import Control.Concurrent( forkIO, newChan, readChan, writeChan )
+import Text.Regex
+import Data.Char        ( isSpace )
+import FastString       ( mkFastString )
+import SrcLoc           ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan )
 #endif
 \end{code}
 
@@ -492,7 +498,7 @@ touch dflags purpose arg =  do
 
 copy :: DynFlags -> String -> String -> String -> IO ()
 copy dflags purpose from to = do
-  debugTraceMsg dflags 2 ("*** " ++ purpose)
+  showPass dflags purpose
 
   h <- openFile to WriteMode
   ls <- readFile from -- inefficient, but it'll do for now.
@@ -573,14 +579,14 @@ removeTmpFiles dflags fs
     warnNon act
      | null non_deletees = act
      | otherwise         = do
-        putMsg ("WARNING - NOT deleting source files: " ++ unwords non_deletees)
+        putMsg dflags (text "WARNING - NOT deleting source files:" <+> hsep (map text non_deletees))
 	act
 
     (non_deletees, deletees) = partition isHaskellUserSrcFilename fs
 
     rm f = removeFile f `IO.catch` 
 		(\_ignored -> 
-		    debugTraceMsg dflags 2 ("Warning: deleting non-existent " ++ f)
+		    debugTraceMsg dflags 2 (ptext SLIT("Warning: deleting non-existent") <+> text f)
 		)
 
 
@@ -600,7 +606,7 @@ runSomething dflags phase_name pgm args = do
   traceCmd dflags phase_name (unwords (pgm:real_args)) $ do
   (exit_code, doesn'tExist) <- 
      IO.catch (do
-         rc <- rawSystem pgm real_args
+         rc <- builderMainLoop dflags pgm real_args
 	 case rc of
 	   ExitSuccess{} -> return (rc, False)
 	   ExitFailure n 
@@ -629,6 +635,97 @@ runSomething dflags phase_name pgm args = do
      (_, ExitSuccess) -> return ()
      _                -> throwDyn (PhaseFailed phase_name exit_code)
 
+
+
+#if __GLASGOW_HASKELL__ < 603
+builderMainLoop dflags pgm real_args = do
+  rawSystem pgm real_args
+#else
+builderMainLoop dflags pgm real_args = do
+  chan <- newChan
+  (hStdIn, hStdOut, hStdErr, hProcess) <- runInteractiveProcess pgm real_args Nothing Nothing
+
+  -- and run a loop piping the output from the compiler to the log_action in DynFlags
+  hSetBuffering hStdOut LineBuffering
+  hSetBuffering hStdErr LineBuffering
+  forkIO (readerProc chan hStdOut)
+  forkIO (readerProc chan hStdErr)
+  rc <- loop chan hProcess 2 1 ExitSuccess
+  hClose hStdIn
+  hClose hStdOut
+  hClose hStdErr
+  return rc
+  where
+    -- status starts at zero, and increments each time either
+    -- a reader process gets EOF, or the build proc exits.  We wait
+    -- for all of these to happen (status==3).
+    -- ToDo: we should really have a contingency plan in case any of
+    -- the threads dies, such as a timeout.
+    loop chan hProcess 0 0 exitcode = return exitcode
+    loop chan hProcess t p exitcode = do
+      mb_code <- if p > 0
+                   then getProcessExitCode hProcess
+                   else return Nothing
+      case mb_code of
+        Just code -> loop chan hProcess t (p-1) code
+	Nothing 
+	  | t > 0 -> do 
+	      msg <- readChan chan
+              case msg of
+                BuildMsg msg -> do
+                  log_action dflags SevInfo noSrcSpan defaultUserStyle msg
+                  loop chan hProcess t p exitcode
+                BuildError loc msg -> do
+                  log_action dflags SevError (mkSrcSpan loc loc) defaultUserStyle msg
+                  loop chan hProcess t p exitcode
+                EOF ->
+                  loop chan hProcess (t-1) p exitcode
+          | otherwise -> loop chan hProcess t p exitcode
+
+readerProc chan hdl = loop Nothing `catch` \e -> writeChan chan EOF
+	-- ToDo: check errors more carefully
+    where
+         loop in_err = do
+	        l <- hGetLine hdl `catch` \e -> do
+			case in_err of
+			  Just err -> writeChan chan err
+			  Nothing  -> return ()
+			ioError e
+		case in_err of
+		  Just err@(BuildError srcLoc msg)
+		    | leading_whitespace l -> do
+			loop (Just (BuildError srcLoc (msg $$ text l)))
+		    | otherwise -> do
+			writeChan chan err
+			checkError l
+		  Nothing -> do
+			checkError l
+
+	 checkError l
+	   = case matchRegex errRegex l of
+		Nothing -> do
+		    writeChan chan (BuildMsg (text l))
+		    loop Nothing
+		Just (file':lineno':colno':msg:_) -> do
+		    let file   = mkFastString file'
+		        lineno = read lineno'::Int
+		        colno  = case colno' of
+		                   "" -> 0
+		                   _  -> read (init colno') :: Int
+		        srcLoc = mkSrcLoc file lineno colno
+		    loop (Just (BuildError srcLoc (text msg)))
+
+	 leading_whitespace []    = False
+	 leading_whitespace (x:_) = isSpace x
+
+errRegex = mkRegex "^([^:]*):([0-9]+):([0-9]+:)?(.*)"
+
+data BuildMessage
+  = BuildMsg   !SDoc
+  | BuildError !SrcLoc !SDoc
+  | EOF
+#endif
+
 showOpt (FileOption pre f) = pre ++ platformPath f
 showOpt (Option "") = ""
 showOpt (Option s)  = s
@@ -638,8 +735,8 @@ traceCmd :: DynFlags -> String -> String -> IO () -> IO ()
 -- b) don't do it at all if dry-run is set
 traceCmd dflags phase_name cmd_line action
  = do	{ let verb = verbosity dflags
-	; debugTraceMsg dflags 2 ("*** " ++ phase_name)
-	; debugTraceMsg dflags 3 cmd_line
+	; showPass dflags phase_name
+	; debugTraceMsg dflags 3 (text cmd_line)
 	; hFlush stderr
 	
 	   -- Test for -n flag
@@ -649,8 +746,8 @@ traceCmd dflags phase_name cmd_line action
 	; action `IO.catch` handle_exn verb
 	}}
   where
-    handle_exn verb exn = do { debugTraceMsg dflags 2 "\n"
-			     ; debugTraceMsg dflags 2 ("Failed: " ++ cmd_line ++ (show exn))
+    handle_exn verb exn = do { debugTraceMsg dflags 2 (char '\n')
+			     ; debugTraceMsg dflags 2 (ptext SLIT("Failed:") <+> text cmd_line <+> text (show exn))
 	          	     ; throwDyn (PhaseFailed phase_name (ExitFailure 1)) }
 \end{code}
 
diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs
index d8032b2f19..d1d8528795 100644
--- 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(..) )
@@ -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
@@ -452,8 +452,10 @@ addLongErrAt loc msg extra
 	 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
+	 
+	 let style = mkErrStyle (unQualInScope rdr_env)
+	     doc   = mkLocMessage loc (msg $$ extra)
+	 in traceTc (ptext SLIT("Adding error:") <+> doc) ;	
   	 writeMutVar errs_var (warns, errs `snocBag` err) }
 
 addErrs :: [(SrcSpan,Message)] -> TcRn ()
diff --git a/ghc/compiler/utils/Outputable.lhs b/ghc/compiler/utils/Outputable.lhs
index a88451d273..cf99e12bcf 100644
--- a/ghc/compiler/utils/Outputable.lhs
+++ b/ghc/compiler/utils/Outputable.lhs
@@ -17,7 +17,7 @@ module Outputable (
 	getPprStyle, withPprStyle, withPprStyleDoc, pprDeeper, pprSetDepth,
 	codeStyle, userStyle, debugStyle, dumpStyle, asmStyle,
 	ifPprDebug, unqualStyle, 
-	mkErrStyle, defaultErrStyle,
+	mkErrStyle, defaultErrStyle, defaultDumpStyle, defaultUserStyle,
 
 	SDoc, 		-- Abstract
 	docToSDoc,