Continue refactoring the core-to-core pipeline

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

diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs
index 455b3bf..f1328e0 100644 (file)
--- a/compiler/main/ErrUtils.lhs
+++ b/compiler/main/ErrUtils.lhs
@@ -5,18 +5,20 @@
 
 \begin{code}
 module ErrUtils (
-       Message, mkLocMessage, printError,
+       Message, mkLocMessage, printError, pprMessageBag,
        Severity(..),
 
        ErrMsg, WarnMsg,
-       errMsgSpans, errMsgContext, errMsgShortDoc, errMsgExtraInfo,
+        ErrorMessages, WarningMessages,
+        errMsgSpans, errMsgContext, errMsgShortDoc, errMsgExtraInfo,
        Messages, errorsFound, emptyMessages,
-       mkErrMsg, mkWarnMsg, mkPlainErrMsg, mkLongErrMsg,
+       mkErrMsg, mkPlainErrMsg, mkLongErrMsg, mkWarnMsg, mkPlainWarnMsg,
        printErrorsAndWarnings, printBagOfErrors, printBagOfWarnings,
+       warnIsErrorMsg, mkLongWarnMsg,
 
        ghcExit,
        doIfSet, doIfSet_dyn, 
-       dumpIfSet, dumpIf_core, dumpIfSet_core, dumpIfSet_dyn, dumpIfSet_dyn_or,
+       dumpIfSet, dumpIfSet_dyn, dumpIfSet_dyn_or,
         mkDumpDoc, dumpSDoc,
 
        --  * Messages during compilation
@@ -28,21 +30,17 @@ 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 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 )
 
 import Control.Monad
 import System.Exit     ( ExitCode(..), exitWith )
-import Data.Dynamic
 import Data.List
 import System.IO
 
@@ -51,6 +49,9 @@ import System.IO
 
 type Message = SDoc
 
+pprMessageBag :: Bag Message -> SDoc
+pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs))
+
 data Severity
   = SevInfo
   | SevWarning
@@ -79,19 +80,9 @@ 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
-
--- So we can throw these things as exceptions
-errMsgTc :: TyCon
-errMsgTc = mkTyCon "ErrMsg"
-{-# NOINLINE errMsgTc #-}
-instance Typeable ErrMsg where
-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 603
-  typeOf _ = mkAppTy errMsgTc []
-#else
-  typeOf _ = mkTyConApp errMsgTc []
-#endif
+
+instance Show ErrMsg where
+    show em = showSDoc (errMsgShortDoc em)
 
 type WarnMsg = ErrMsg
 
@@ -99,30 +90,46 @@ 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
+
 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)
@@ -176,8 +183,6 @@ printBagOfWarnings dflags bag_of_warns
                EQ -> True
                GT -> False
 
-
-
 ghcExit :: DynFlags -> Int -> IO ()
 ghcExit dflags val
   | val == 0  = exitWith ExitSuccess
@@ -200,19 +205,6 @@ 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
-  = 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 
@@ -229,10 +221,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 '=')