X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FErrUtils.lhs;h=72d0e930bcb347de0c015a0b0cc2988beb892a69;hb=7350aaa60aaf63074202f24208497e2d64ddffb2;hp=d93fb1bdefcdeb9d5510cbeb0450f67bfc19bb65;hpb=a8dc65d6582cc8dda6a1de2862e2d6da80a78d0c;p=ghc-hetmet.git

diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs
index d93fb1b..72d0e93 100644
--- a/compiler/main/ErrUtils.lhs
+++ b/compiler/main/ErrUtils.lhs
@@ -16,7 +16,8 @@ module ErrUtils (
 
 	ghcExit,
 	doIfSet, doIfSet_dyn, 
-	dumpIfSet, dumpIfSet_core, dumpIfSet_dyn, dumpIfSet_dyn_or, mkDumpDoc,	
+	dumpIfSet, dumpIf_core, dumpIfSet_core, dumpIfSet_dyn, dumpIfSet_dyn_or,
+        mkDumpDoc, dumpSDoc,
 
 	--  * Messages during compilation
 	putMsg,
@@ -27,9 +28,10 @@ module ErrUtils (
 	debugTraceMsg,	
     ) where
 
+-- XXX This define is a bit of a hack, and should be done more nicely
+#define FAST_STRING_NOT_NEEDED 1
 #include "HsVersions.h"
 
-import Module		( ModLocation(..))
 import Bag		( Bag, bagToList, isEmptyBag, emptyBag )
 import SrcLoc		( SrcSpan )
 import Util		( sortLe )
@@ -84,7 +86,7 @@ errMsgTc :: TyCon
 errMsgTc = mkTyCon "ErrMsg"
 {-# NOINLINE errMsgTc #-}
 instance Typeable ErrMsg where
-#if __GLASGOW_HASKELL__ < 603
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 603
   typeOf _ = mkAppTy errMsgTc []
 #else
   typeOf _ = mkTyConApp errMsgTc []
@@ -138,7 +140,7 @@ 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,
+		| ErrMsg { errMsgSpans = s:_,
 			   errMsgShortDoc = d,
 			   errMsgExtraInfo = e,
 			   errMsgContext = unqual } <- sorted_errs ]
@@ -156,7 +158,7 @@ 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,
+		| ErrMsg { errMsgSpans = s:_,
 			   errMsgShortDoc = d,
 			   errMsgExtraInfo = e,
 			   errMsgContext = unqual } <- sorted_errs ]
@@ -194,18 +196,23 @@ dumpIfSet flag hdr doc
   | not flag   = return ()
   | otherwise  = printDump (mkDumpDoc hdr doc)
 
+dumpIf_core :: Bool -> DynFlags -> DynFlag -> String -> SDoc -> IO ()
+dumpIf_core cond dflags dflag hdr doc
+  | cond
+    || verbosity dflags >= 4
+    || dopt Opt_D_verbose_core2core dflags
+  = dumpSDoc dflags dflag hdr doc
+
+  | otherwise = return ()
+
 dumpIfSet_core :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
 dumpIfSet_core dflags flag hdr doc
-  | dopt flag dflags
-	|| verbosity dflags >= 4
-	|| dopt Opt_D_verbose_core2core dflags
-  = writeDump dflags flag (mkDumpDoc hdr doc)
-  | otherwise                                   = return ()
+  = dumpIf_core (dopt flag dflags) dflags flag hdr doc
 
 dumpIfSet_dyn :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
 dumpIfSet_dyn dflags flag hdr doc
   | dopt flag dflags || verbosity dflags >= 4 
-  = writeDump dflags flag (mkDumpDoc hdr doc)
+  = dumpSDoc dflags flag hdr doc
   | otherwise
   = return ()
 
@@ -216,6 +223,7 @@ dumpIfSet_dyn_or dflags flags hdr doc
   = printDump (mkDumpDoc hdr doc)
   | otherwise = return ()
 
+mkDumpDoc :: String -> SDoc -> SDoc
 mkDumpDoc hdr doc 
    = vcat [text "", 
 	   line <+> text hdr <+> line,
@@ -228,11 +236,13 @@ mkDumpDoc hdr doc
 -- | Write out a dump.
 --	If --dump-to-file is set then this goes to a file.
 --	otherwise emit to stdout.
-writeDump :: DynFlags -> DynFlag -> SDoc -> IO ()
-writeDump dflags dflag doc
+dumpSDoc :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
+dumpSDoc dflags dflag hdr doc
  = do	let mFile	= chooseDumpFile dflags dflag
  	case mFile of
 		-- write the dump to a file
+		--	don't add the header in this case, we can see what kind
+		--	of dump it is from the filename.
 		Just fileName
 		 -> do	handle	<- openFile fileName AppendMode
 		 	hPrintDump handle doc
@@ -240,7 +250,7 @@ writeDump dflags dflag doc
 
 		-- write the dump to stdout
 		Nothing
-		 -> do	printDump doc
+		 -> do	printDump (mkDumpDoc hdr doc)
 
 
 -- | Choose where to put a dump file based on DynFlags