Allow -ddump-simpl-phases to specify which phases to dump

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

diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs
index d02582e..72d0e93 100644 (file)
--- a/compiler/main/ErrUtils.lhs
+++ b/compiler/main/ErrUtils.lhs
@@ -4,13 +4,6 @@
 \section[ErrsUtils]{Utilities for error reporting}
 
 \begin{code}
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
 module ErrUtils (
        Message, mkLocMessage, printError,
        Severity(..),
@@ -23,7 +16,8 @@ module ErrUtils (
 
        ghcExit,
        doIfSet, doIfSet_dyn, 
-       dumpIfSet, dumpIfSet_core, dumpIfSet_dyn, dumpIfSet_dyn_or, mkDumpDoc, dumpSDoc,
+       dumpIfSet, dumpIf_core, dumpIfSet_core, dumpIfSet_dyn, dumpIfSet_dyn_or,
+        mkDumpDoc, dumpSDoc,
 
        --  * Messages during compilation
        putMsg,
@@ -34,9 +28,10 @@ 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 Module          ( ModLocation(..))
 import Bag             ( Bag, bagToList, isEmptyBag, emptyBag )
 import SrcLoc          ( SrcSpan )
 import Util            ( sortLe )
@@ -145,7 +140,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 ]
@@ -163,7 +158,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 ]
@@ -201,13 +196,18 @@ 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
-  = dumpSDoc dflags flag 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
@@ -223,6 +223,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,