X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FErrUtils.lhs;h=1c7a389f3548e3ca5387d058e6f779df1010ffc7;hb=f705fdb20935feee6a9ee86f5c9ffac2ab262a34;hp=15b142b15d6d9b344a855558636186264c68142f;hpb=94bf0d3604ff0d2ecab246924af712bdd1c29a40;p=ghc-hetmet.git

diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs
index 15b142b..1c7a389 100644
--- a/compiler/main/ErrUtils.lhs
+++ b/compiler/main/ErrUtils.lhs
@@ -22,7 +22,7 @@ module ErrUtils (
         mkDumpDoc, dumpSDoc,
 
 	--  * Messages during compilation
-	putMsg,
+        putMsg, putMsgWith,
 	errorMsg,
 	fatalErrorMsg,
 	compilationProgressMsg,
@@ -41,6 +41,9 @@ import StaticFlags	( opt_ErrorSpans )
 
 import System.Exit	( ExitCode(..), exitWith )
 import Data.List
+import qualified Data.Set as Set
+import Data.IORef
+import Control.Monad
 import System.IO
 
 -- -----------------------------------------------------------------------------
@@ -67,7 +70,8 @@ mkLocMessage locn msg
   -- would look strange.  Better to say explicitly "<no location info>".
 
 printError :: SrcSpan -> Message -> IO ()
-printError span msg = printErrs (mkLocMessage span msg $ defaultErrStyle)
+printError span msg =
+  printErrs (mkLocMessage span msg) defaultErrStyle
 
 
 -- -----------------------------------------------------------------------------
@@ -207,19 +211,26 @@ mkDumpDoc hdr doc
 --	otherwise emit to stdout.
 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
-		 	hClose handle
-
-		-- write the dump to stdout
-		Nothing
-		 -> do	printDump (mkDumpDoc 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
+                        let gdref = generatedDumps dflags
+                        gd <- readIORef gdref
+                        let append = Set.member fileName gd
+                            mode = if append then AppendMode else WriteMode
+                        when (not append) $
+                            writeIORef gdref (Set.insert fileName gd)
+                        handle <- openFile fileName mode
+                        hPrintDump handle doc
+                        hClose handle
+
+            -- write the dump to stdout
+            Nothing
+                 -> printDump (mkDumpDoc hdr doc)
 
 
 -- | Choose where to put a dump file based on DynFlags
@@ -275,6 +286,12 @@ ifVerbose dflags val act
 putMsg :: DynFlags -> Message -> IO ()
 putMsg dflags msg = log_action dflags SevInfo noSrcSpan defaultUserStyle msg
 
+putMsgWith :: DynFlags -> PrintUnqualified -> Message -> IO ()
+putMsgWith dflags print_unqual msg
+  = log_action dflags SevInfo noSrcSpan sty msg
+  where
+    sty = mkUserStyle print_unqual AllTheWay
+
 errorMsg :: DynFlags -> Message -> IO ()
 errorMsg dflags msg = log_action dflags SevError noSrcSpan defaultErrStyle msg