Change suffix for dyn. linked executables from _real to .dyn

[ghc-hetmet.git] / compiler / main / ErrUtils.lhs

diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs
index d4e8e8f..d98fddb 100644 (file)
--- a/compiler/main/ErrUtils.lhs
+++ b/compiler/main/ErrUtils.lhs
@@ -9,11 +9,13 @@ module ErrUtils (
        Severity(..),
 
        ErrMsg, WarnMsg, throwErrMsg, handleErrMsg,
+    ErrorMessages, WarningMessages,
        errMsgSpans, errMsgContext, errMsgShortDoc, errMsgExtraInfo,
        Messages, errorsFound, emptyMessages,
-       mkErrMsg, mkWarnMsg, mkPlainErrMsg, mkLongErrMsg,
+       mkErrMsg, mkPlainErrMsg, mkLongErrMsg, mkWarnMsg, mkPlainWarnMsg,
        printErrorsAndWarnings, printBagOfErrors, printBagOfWarnings,
     handleFlagWarnings,
+       warnIsErrorMsg,
 
        ghcExit,
        doIfSet, doIfSet_dyn, 
@@ -32,10 +34,9 @@ module ErrUtils (
 #include "HsVersions.h"
 
 import Bag             ( Bag, bagToList, isEmptyBag, emptyBag )
-import SrcLoc          ( SrcSpan )
 import Util            ( sortLe )
 import Outputable
-import SrcLoc          ( srcSpanStart, noSrcSpan )
+import SrcLoc
 import DynFlags                ( DynFlags(..), DynFlag(..), dopt )
 import StaticFlags     ( opt_ErrorSpans )
 
@@ -82,26 +83,16 @@ data ErrMsg = ErrMsg {
        -- NB  Pretty.Doc not SDoc: we deal with the printing style (in ptic 
        -- whether to qualify an External Name) at the error occurrence
 
-#if __GLASGOW_HASKELL__ >= 609
 instance Exception ErrMsg
-#endif
 
 instance Show ErrMsg where
     show em = showSDoc (errMsgShortDoc em)
 
 throwErrMsg :: ErrMsg -> a
-#if __GLASGOW_HASKELL__ < 609
-throwErrMsg = throwDyn
-#else
 throwErrMsg = throw
-#endif
 
-handleErrMsg :: (ErrMsg -> IO a) -> IO a -> IO a
-#if __GLASGOW_HASKELL__ < 609
-handleErrMsg = flip catchDyn
-#else
-handleErrMsg = handle
-#endif
+handleErrMsg :: ExceptionMonad m => (ErrMsg -> m a) -> m a -> m a
+handleErrMsg = ghandle
 
 -- So we can throw these things as exceptions
 errMsgTc :: TyCon
@@ -132,14 +123,24 @@ mkLongErrMsg locn print_unqual msg extra
 mkWarnMsg :: SrcSpan -> PrintUnqualified -> Message -> WarnMsg
 mkWarnMsg = mkErrMsg
 
+-- Variant that doesn't care about qualified/unqualified names
+mkPlainWarnMsg :: SrcSpan -> Message -> ErrMsg
+mkPlainWarnMsg locn msg = mkWarnMsg locn alwaysQualify msg
+
 type Messages = (Bag WarnMsg, Bag ErrMsg)
 
+type WarningMessages = Bag WarnMsg
+type ErrorMessages   = Bag ErrMsg
+
 emptyMessages :: Messages
 emptyMessages = (emptyBag, emptyBag)
 
+warnIsErrorMsg :: ErrMsg
+warnIsErrorMsg = mkPlainErrMsg noSrcSpan (text "\nFailing due to -Werror.\n")
+
 errorsFound :: DynFlags -> Messages -> Bool
 -- The dyn-flags are used to see if the user has specified
--- -Werorr, which says that warnings should be fatal
+-- -Werror, which says that warnings should be fatal
 errorsFound dflags (warns, errs) 
   | dopt Opt_WarnIsError dflags = not (isEmptyBag errs) || not (isEmptyBag warns)
   | otherwise                          = not (isEmptyBag errs)
@@ -193,22 +194,25 @@ printBagOfWarnings dflags bag_of_warns
                EQ -> True
                GT -> False
 
-handleFlagWarnings :: DynFlags -> [String] -> IO ()
+handleFlagWarnings :: DynFlags -> [Located String] -> IO ()
 handleFlagWarnings dflags warns
  = when (dopt Opt_WarnDeprecatedFlags dflags)
         (handleFlagWarnings' dflags warns)
 
-handleFlagWarnings' :: DynFlags -> [String] -> IO ()
+handleFlagWarnings' :: DynFlags -> [Located String] -> IO ()
 handleFlagWarnings' _ [] = return ()
 handleFlagWarnings' dflags warns
- = do -- It would be nicer if warns :: [Message], but that has circular
+ = do -- It would be nicer if warns :: [Located Message], but that has circular
       -- import problems.
-      let warns' = map text warns
-      mapM_ (log_action dflags SevWarning noSrcSpan defaultUserStyle) warns'
+      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