X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FErrUtils.lhs;h=66ade906fb0c4398a9c9a0f685c772b3280d6d5b;hp=d37dba9ecfd9ec4128fd4c8ff5baa55a092f07e6;hb=f96194794bf099020706c3816d1a5678b40addbb;hpb=613c5f6d88a3dd7df56af1d0f3780b885a0d17cd

diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs
index d37dba9..66ade90 100644
--- a/compiler/main/ErrUtils.lhs
+++ b/compiler/main/ErrUtils.lhs
@@ -9,13 +9,11 @@ module ErrUtils (
 	Severity(..),
 
 	ErrMsg, WarnMsg,
-    ErrorMessages, WarningMessages,
-	errMsgSpans, errMsgContext, errMsgShortDoc, errMsgExtraInfo,
+        ErrorMessages, WarningMessages,
 	Messages, errorsFound, emptyMessages,
 	mkErrMsg, mkPlainErrMsg, mkLongErrMsg, mkWarnMsg, mkPlainWarnMsg,
 	printErrorsAndWarnings, printBagOfErrors, printBagOfWarnings,
-    handleFlagWarnings,
-	warnIsErrorMsg,
+	warnIsErrorMsg, mkLongWarnMsg,
 
 	ghcExit,
 	doIfSet, doIfSet_dyn, 
@@ -78,8 +76,6 @@ data ErrMsg = ErrMsg {
 	errMsgExtraInfo :: Message
 	}
 	-- The SrcSpan is used for sorting errors into line-number order
-	-- NB  Pretty.Doc not SDoc: we deal with the printing style (in ptic 
-	-- whether to qualify an External Name) at the error occurrence
 
 instance Show ErrMsg where
     show em = showSDoc (errMsgShortDoc em)
@@ -90,22 +86,28 @@ type WarnMsg = ErrMsg
 -- to qualify names in the message or not.
 mkErrMsg :: SrcSpan -> PrintUnqualified -> Message -> ErrMsg
 mkErrMsg locn print_unqual msg
-  = ErrMsg [locn] print_unqual msg empty
+  = ErrMsg { errMsgSpans = [locn], errMsgContext = print_unqual
+           , errMsgShortDoc = msg, errMsgExtraInfo = empty }
 
 -- Variant that doesn't care about qualified/unqualified names
 mkPlainErrMsg :: SrcSpan -> Message -> ErrMsg
 mkPlainErrMsg locn msg
-  = ErrMsg [locn] alwaysQualify msg empty
+  = ErrMsg { errMsgSpans = [locn], errMsgContext = alwaysQualify
+           , errMsgShortDoc = msg, errMsgExtraInfo = empty }
 
 -- A long (multi-line) error message, with context to tell us whether
 -- to qualify names in the message or not.
 mkLongErrMsg :: SrcSpan -> PrintUnqualified -> Message -> Message -> ErrMsg
 mkLongErrMsg locn print_unqual msg extra 
- = ErrMsg [locn] print_unqual msg extra
+ = ErrMsg { errMsgSpans = [locn], errMsgContext = print_unqual
+          , errMsgShortDoc = msg, errMsgExtraInfo = extra }
 
 mkWarnMsg :: SrcSpan -> PrintUnqualified -> Message -> WarnMsg
 mkWarnMsg = mkErrMsg
 
+mkLongWarnMsg :: SrcSpan -> PrintUnqualified -> Message -> Message -> ErrMsg
+mkLongWarnMsg = mkLongErrMsg
+
 -- Variant that doesn't care about qualified/unqualified names
 mkPlainWarnMsg :: SrcSpan -> Message -> ErrMsg
 mkPlainWarnMsg locn msg = mkWarnMsg locn alwaysQualify msg
@@ -177,25 +179,6 @@ printBagOfWarnings dflags bag_of_warns
 		EQ -> True
 		GT -> False
 
-handleFlagWarnings :: DynFlags -> [Located String] -> IO ()
-handleFlagWarnings dflags warns
- = when (dopt Opt_WarnDeprecatedFlags dflags)
-        (handleFlagWarnings' dflags warns)
-
-handleFlagWarnings' :: DynFlags -> [Located String] -> IO ()
-handleFlagWarnings' _ [] = return ()
-handleFlagWarnings' dflags warns
- = do -- It would be nicer if warns :: [Located Message], but that has circular
-      -- import problems.
-      mapM_ (handleFlagWarning dflags) warns
-      when (dopt Opt_WarnIsError dflags) $
-          do errorMsg dflags $ text "\nFailing due to -Werror.\n"
-             exitWith (ExitFailure 1)
-
-handleFlagWarning :: DynFlags -> Located String -> IO ()
-handleFlagWarning dflags (L loc warn)
- = log_action dflags SevWarning loc defaultUserStyle (text warn)
-
 ghcExit :: DynFlags -> Int -> IO ()
 ghcExit dflags val
   | val == 0  = exitWith ExitSuccess
@@ -247,10 +230,10 @@ dumpIfSet_dyn_or dflags flags hdr doc
 
 mkDumpDoc :: String -> SDoc -> SDoc
 mkDumpDoc hdr doc 
-   = vcat [text "", 
+   = vcat [blankLine,
 	   line <+> text hdr <+> line,
 	   doc,
-	   text ""]
+	   blankLine]
      where 
         line = text (replicate 20 '=')