X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FErrUtils.lhs;h=fdabacf5712c22ab0b289c1c70a0dda871b31546;hb=0f5e104c36b1dc3d8deeec5fef3d65e7b3a1b5ad;hp=7bdb019b4cf63c14e3771fd705c16a9034845e8c;hpb=eb0f8a5ab0d837b9e41b4be02a3791a3c2f835aa;p=ghc-hetmet.git

diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs
index 7bdb019..fdabacf 100644
--- a/compiler/main/ErrUtils.lhs
+++ b/compiler/main/ErrUtils.lhs
@@ -13,10 +13,12 @@ module ErrUtils (
 	Messages, errorsFound, emptyMessages,
 	mkErrMsg, mkWarnMsg, mkPlainErrMsg, mkLongErrMsg,
 	printErrorsAndWarnings, printBagOfErrors, printBagOfWarnings,
+    handleFlagWarnings,
 
 	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,
@@ -31,16 +33,17 @@ module ErrUtils (
 
 import Bag		( Bag, bagToList, isEmptyBag, emptyBag )
 import SrcLoc		( SrcSpan )
-import Util		( sortLe, global )
+import Util		( sortLe )
 import Outputable
-import qualified Pretty
 import SrcLoc		( srcSpanStart, noSrcSpan )
 import DynFlags		( DynFlags(..), DynFlag(..), dopt )
 import StaticFlags	( opt_ErrorSpans )
-import System		( ExitCode(..), exitWith )
-import IO		( hPutStrLn, stderr )
-import DYNAMIC
 
+import Control.Monad
+import System.Exit	( ExitCode(..), exitWith )
+import Data.Dynamic
+import Data.List
+import System.IO
 
 -- -----------------------------------------------------------------------------
 -- Basic error messages: just render a message with a source location.
@@ -83,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 []
@@ -125,10 +128,13 @@ errorsFound dflags (warns, errs)
 
 printErrorsAndWarnings :: DynFlags -> Messages -> IO ()
 printErrorsAndWarnings dflags (warns, errs)
-  | no_errs && no_warns  = return ()
-  | no_errs		 = printBagOfWarnings dflags warns
-			    -- Don't print any warnings if there are errors
-  | otherwise		 = printBagOfErrors   dflags errs
+  | no_errs && no_warns = return ()
+  | no_errs             = do printBagOfWarnings dflags warns
+                             when (dopt Opt_WarnIsError dflags) $
+                                 errorMsg dflags $
+                                     text "\nFailing due to -Werror.\n"
+                          -- Don't print any warnings if there are errors
+  | otherwise           = printBagOfErrors dflags errs
   where
     no_warns = isEmptyBag warns
     no_errs  = isEmptyBag errs
@@ -137,7 +143,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 ]
@@ -155,7 +161,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 ]
@@ -168,17 +174,29 @@ printBagOfWarnings dflags bag_of_warns
 		LT -> True
 		EQ -> True
 		GT -> False
-\end{code}
 
-\begin{code}
+handleFlagWarnings :: DynFlags -> [String] -> IO ()
+handleFlagWarnings dflags warns
+ = when (dopt Opt_WarnDeprecatedFlags dflags)
+        (handleFlagWarnings' dflags warns)
+
+handleFlagWarnings' :: DynFlags -> [String] -> IO ()
+handleFlagWarnings' _ [] = return ()
+handleFlagWarnings' dflags warns
+ = do -- It would be nicer if warns :: [Message], but that has circular
+      -- import problems.
+      let warns' = map text warns
+      mapM_ (log_action dflags SevWarning noSrcSpan defaultUserStyle) warns'
+      when (dopt Opt_WarnIsError dflags) $
+          do errorMsg dflags $ text "\nFailing due to -Werror.\n"
+             exitWith (ExitFailure 1)
+
 ghcExit :: DynFlags -> Int -> IO ()
 ghcExit dflags val
   | val == 0  = exitWith ExitSuccess
   | otherwise = do errorMsg dflags (text "\nCompilation had errors\n\n")
 	           exitWith (ExitFailure val)
-\end{code}
 
-\begin{code}
 doIfSet :: Bool -> IO () -> IO ()
 doIfSet flag action | flag      = action
 		    | otherwise = return ()
@@ -186,25 +204,32 @@ doIfSet flag action | flag      = action
 doIfSet_dyn :: DynFlags -> DynFlag -> IO () -> IO()
 doIfSet_dyn dflags flag action | dopt flag dflags = action
 		               | otherwise        = return ()
-\end{code}
 
-\begin{code}
+-- -----------------------------------------------------------------------------
+-- Dumping
+
 dumpIfSet :: Bool -> String -> SDoc -> IO ()
 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 	= printDump (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 
-  = printDump (mkDumpDoc hdr doc)
+  = dumpSDoc dflags flag hdr doc
   | otherwise
   = return ()
 
@@ -215,6 +240,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,
@@ -223,6 +249,64 @@ mkDumpDoc hdr doc
      where 
         line = text (replicate 20 '=')
 
+
+-- | Write out a dump.
+--	If --dump-to-file is set then this goes to a file.
+--	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)
+
+
+-- | Choose where to put a dump file based on DynFlags
+--
+chooseDumpFile :: DynFlags -> DynFlag -> Maybe String
+chooseDumpFile dflags dflag
+
+	-- dump file location is being forced
+	--	by the --ddump-file-prefix flag.
+ 	| dumpToFile
+	, Just prefix	<- dumpPrefixForce dflags
+	= Just $ prefix ++ (beautifyDumpName dflag)
+
+	-- dump file location chosen by DriverPipeline.runPipeline
+	| dumpToFile
+	, Just prefix	<- dumpPrefix dflags
+	= Just $ prefix ++ (beautifyDumpName dflag)
+
+	-- we haven't got a place to put a dump file.
+	| otherwise
+	= Nothing
+
+	where	dumpToFile = dopt Opt_DumpToFile dflags
+
+
+-- | Build a nice file name from name of a DynFlag constructor
+beautifyDumpName :: DynFlag -> String
+beautifyDumpName dflag
+ = let	str	= show dflag
+ 	cut	= if isPrefixOf "Opt_D_" str
+			 then drop 6 str
+			 else str
+	dash	= map	(\c -> case c of
+				'_'	-> '-'
+				_	-> c)
+			cut
+   in	dash
+
+
 -- -----------------------------------------------------------------------------
 -- Outputting messages from the compiler
 
@@ -256,4 +340,5 @@ showPass dflags what
 debugTraceMsg :: DynFlags -> Int -> Message -> IO ()
 debugTraceMsg dflags val msg
   = ifVerbose dflags val (log_action dflags SevInfo noSrcSpan defaultDumpStyle msg)
+
 \end{code}