Merge branch 'master' of http://darcs.haskell.org/ghc

8 files changed, 103 insertions, 99 deletions

diff --git a/compiler/main/CmdLineParser.hs b/compiler/main/CmdLineParser.hs
index c0301dc29b..148e11f65b 100644
--- a/compiler/main/CmdLineParser.hs
+++ b/compiler/main/CmdLineParser.hs
@@ -80,8 +80,7 @@ addErr :: Monad m => String -> EwM m ()
 addErr e = EwM (\(L loc _) es ws -> return (es `snocBag` L loc e, ws, ()))
 
 addWarn :: Monad m => String -> EwM m ()
-addWarn msg = EwM (\(L loc _) es ws -> return (es, ws `snocBag` L loc w, ()))
-  where w = "Warning: " ++ msg
+addWarn msg = EwM (\(L loc _) es ws -> return (es, ws `snocBag` L loc msg, ()))
 
 deprecate :: Monad m => String -> EwM m ()
 deprecate s = do
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 1bd4fcef8a..48830e1b99 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -113,7 +113,7 @@ import Outputable
 #ifdef GHCI
 import Foreign.C        ( CInt(..) )
 #endif
-import {-# SOURCE #-} ErrUtils ( Severity(..), Message, mkLocMessage )
+import {-# SOURCE #-} ErrUtils ( Severity(..), MsgDoc, mkLocMessage )
 
 #ifdef GHCI
 import System.IO.Unsafe ( unsafePerformIO )
@@ -288,6 +288,7 @@ data DynFlag
    | Opt_GhciSandbox
    | Opt_GhciHistory
    | Opt_HelpfulErrors
+   | Opt_DeferTypeErrors
 
    -- temporary flags
    | Opt_RunCPS
@@ -578,7 +579,7 @@ data DynFlags = DynFlags {
   --     flattenExtensionFlags language extensions
   extensionFlags        :: IntSet,
 
-  -- | Message output action: use "ErrUtils" instead of this if you can
+  -- | MsgDoc output action: use "ErrUtils" instead of this if you can
   log_action            :: LogAction,
 
   haddockOptions        :: Maybe String,
@@ -921,7 +922,7 @@ defaultDynFlags mySettings =
         profAuto = NoProfAuto
       }
 
-type LogAction = Severity -> SrcSpan -> PprStyle -> Message -> IO ()
+type LogAction = Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO ()
 
 defaultLogAction :: LogAction
 defaultLogAction severity srcSpan style msg
@@ -930,7 +931,7 @@ defaultLogAction severity srcSpan style msg
    SevInfo   -> printErrs msg style
    SevFatal  -> printErrs msg style
    _         -> do hPutChar stderr '\n'
-                   printErrs (mkLocMessage srcSpan msg) style
+                   printErrs (mkLocMessage severity srcSpan msg) style
                    -- careful (#2302): printErrs prints in UTF-8, whereas
                    -- converting to string first and using hPutStr would
                    -- just emit the low 8 bits of each unicode char.
@@ -1326,7 +1327,7 @@ safeFlagCheck cmdl dflags =
         False | not cmdl && safeInferOn dflags && packageTrustOn dflags
               -> (dopt_unset dflags' Opt_PackageTrust,
                   [L (pkgTrustOnLoc dflags') $
-                      "Warning: -fpackage-trust ignored;" ++
+                      "-fpackage-trust ignored;" ++
                       " must be specified with a Safe Haskell flag"]
                   )
 
@@ -1349,8 +1350,8 @@ safeFlagCheck cmdl dflags =
 
         apFix f = if safeInferOn dflags then id else f
 
-        safeFailure loc str = [L loc $ "Warning: " ++ str ++ " is not allowed in"
-                                      ++ " Safe Haskell; ignoring " ++ str]
+        safeFailure loc str 
+           = [L loc $ str ++ " is not allowed in Safe Haskell; ignoring " ++ str]
 
         bad_flags = [("-XGeneralizedNewtypeDeriving", newDerivOnLoc dflags,
                          xopt Opt_GeneralizedNewtypeDeriving,
@@ -1829,6 +1830,7 @@ fFlags = [
   ( "ghci-sandbox",                     Opt_GhciSandbox, nop ),
   ( "ghci-history",                     Opt_GhciHistory, nop ),
   ( "helpful-errors",                   Opt_HelpfulErrors, nop ),
+  ( "defer-type-errors",                Opt_DeferTypeErrors, nop ),
   ( "building-cabal-package",           Opt_BuildingCabalPackage, nop ),
   ( "implicit-import-qualified",        Opt_ImplicitImportQualified, nop ),
   ( "prof-count-entries",               Opt_ProfCountEntries, nop ),
diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs
index 1cce4ec633..6ba9df436c 100644
--- a/compiler/main/ErrUtils.lhs
+++ b/compiler/main/ErrUtils.lhs
@@ -6,15 +6,15 @@
 \begin{code}
 
 module ErrUtils (
-        Message, mkLocMessage, printError, pprMessageBag, pprErrMsgBag,
-        Severity(..),
-
-        ErrMsg, WarnMsg,
-        ErrorMessages, WarningMessages,
+        ErrMsg, WarnMsg, Severity(..),
+        Messages, ErrorMessages, WarningMessages,
         errMsgSpans, errMsgContext, errMsgShortDoc, errMsgExtraInfo,
-        Messages, errorsFound, emptyMessages,
+        MsgDoc, mkLocMessage, printError, pprMessageBag, pprErrMsgBag, 
+        pprLocErrMsg, makeIntoWarning,
+        
+        errorsFound, emptyMessages,
         mkErrMsg, mkPlainErrMsg, mkLongErrMsg, mkWarnMsg, mkPlainWarnMsg,
-        printBagOfErrors, printBagOfWarnings,
+        printBagOfErrors, 
         warnIsErrorMsg, mkLongWarnMsg,
 
         ghcExit,
@@ -36,6 +36,7 @@ module ErrUtils (
 import Bag              ( Bag, bagToList, isEmptyBag, emptyBag )
 import Util
 import Outputable
+import FastString
 import SrcLoc
 import DynFlags
 import StaticFlags      ( opt_ErrorSpans )
@@ -51,10 +52,21 @@ import System.IO
 -- -----------------------------------------------------------------------------
 -- Basic error messages: just render a message with a source location.
 
-type Message = SDoc
+type Messages        = (WarningMessages, ErrorMessages)
+type WarningMessages = Bag WarnMsg
+type ErrorMessages   = Bag ErrMsg
 
-pprMessageBag :: Bag Message -> SDoc
-pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs))
+data ErrMsg = ErrMsg {
+        errMsgSpans     :: [SrcSpan],
+        errMsgContext   :: PrintUnqualified,
+        errMsgShortDoc  :: MsgDoc,
+        errMsgExtraInfo :: MsgDoc,
+        errMsgSeverity  :: Severity
+        }
+        -- The SrcSpan is used for sorting errors into line-number order
+
+type WarnMsg = ErrMsg
+type MsgDoc = SDoc
 
 data Severity
   = SevOutput
@@ -63,70 +75,56 @@ data Severity
   | SevError
   | SevFatal
 
-mkLocMessage :: SrcSpan -> Message -> Message
-mkLocMessage locn msg
-  | opt_ErrorSpans = hang (ppr locn <> colon) 4 msg
-  | otherwise      = hang (ppr (srcSpanStart locn) <> colon) 4 msg
-  -- always print the location, even if it is unhelpful.  Error messages
+instance Show ErrMsg where
+    show em = showSDoc (errMsgShortDoc em)
+
+pprMessageBag :: Bag MsgDoc -> SDoc
+pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs))
+
+mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc
+  -- Always print the location, even if it is unhelpful.  Error messages
   -- are supposed to be in a standard format, and one without a location
   -- would look strange.  Better to say explicitly "<no location info>".
+mkLocMessage severity locn msg
+  | opt_ErrorSpans = hang (ppr locn <> colon <+> sev_info) 4 msg
+  | otherwise      = hang (ppr (srcSpanStart locn) <> colon <+> sev_info) 4 msg
+  where
+    sev_info = case severity of
+                 SevWarning -> ptext (sLit "Warning:")
+                 _other     -> empty                 
+      -- For warnings, print    Foo.hs:34: Warning:
+      --                           <the warning message>
 
-printError :: SrcSpan -> Message -> IO ()
-printError span msg =
-  printErrs (mkLocMessage span msg) defaultErrStyle
+printError :: SrcSpan -> MsgDoc -> IO ()
+printError span msg = printErrs (mkLocMessage SevError span msg) defaultErrStyle
 
+makeIntoWarning :: ErrMsg -> ErrMsg
+makeIntoWarning err = err { errMsgSeverity = SevWarning }
 
 -- -----------------------------------------------------------------------------
 -- Collecting up messages for later ordering and printing.
 
-data ErrMsg = ErrMsg {
-        errMsgSpans     :: [SrcSpan],
-        errMsgContext   :: PrintUnqualified,
-        errMsgShortDoc  :: Message,
-        errMsgExtraInfo :: Message
-        }
-        -- The SrcSpan is used for sorting errors into line-number order
-
-instance Show ErrMsg where
-    show em = showSDoc (errMsgShortDoc em)
-
-type WarnMsg = ErrMsg
-
--- A short (one-line) error message, with context to tell us whether
--- to qualify names in the message or not.
-mkErrMsg :: SrcSpan -> PrintUnqualified -> Message -> ErrMsg
-mkErrMsg locn print_unqual msg
-  = 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 { 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
+mk_err_msg :: Severity -> SrcSpan -> PrintUnqualified -> MsgDoc -> SDoc -> ErrMsg
+mk_err_msg sev 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
-
+          , errMsgShortDoc = msg, errMsgExtraInfo = extra
+          , errMsgSeverity = sev }
+
+mkLongErrMsg, mkLongWarnMsg   :: SrcSpan -> PrintUnqualified -> MsgDoc -> MsgDoc -> ErrMsg
+-- A long (multi-line) error message
+mkErrMsg, mkWarnMsg           :: SrcSpan -> PrintUnqualified -> MsgDoc            -> ErrMsg
+-- A short (one-line) error message
+mkPlainErrMsg, mkPlainWarnMsg :: SrcSpan ->                     MsgDoc            -> ErrMsg
 -- 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
+mkLongErrMsg   locn unqual msg extra = mk_err_msg SevError   locn unqual        msg extra
+mkErrMsg       locn unqual msg       = mk_err_msg SevError   locn unqual        msg empty
+mkPlainErrMsg  locn        msg       = mk_err_msg SevError   locn alwaysQualify msg empty
+mkLongWarnMsg  locn unqual msg extra = mk_err_msg SevWarning locn unqual        msg extra
+mkWarnMsg      locn unqual msg       = mk_err_msg SevWarning locn unqual        msg empty
+mkPlainWarnMsg locn        msg       = mk_err_msg SevWarning locn alwaysQualify msg empty
 
+----------------
 emptyMessages :: Messages
 emptyMessages = (emptyBag, emptyBag)
 
@@ -137,12 +135,8 @@ errorsFound :: DynFlags -> Messages -> Bool
 errorsFound _dflags (_warns, errs) = not (isEmptyBag errs)
 
 printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO ()
-printBagOfErrors dflags bag_of_errors =
-  printMsgBag dflags bag_of_errors SevError
-
-printBagOfWarnings :: DynFlags -> Bag WarnMsg -> IO ()
-printBagOfWarnings dflags bag_of_warns =
-  printMsgBag dflags bag_of_warns SevWarning
+printBagOfErrors dflags bag_of_errors
+  = printMsgBag dflags bag_of_errors
 
 pprErrMsgBag :: Bag ErrMsg -> [SDoc]
 pprErrMsgBag bag
@@ -152,12 +146,23 @@ pprErrMsgBag bag
                errMsgExtraInfo = e,
                errMsgContext   = unqual } <- sortMsgBag bag ]
 
-printMsgBag :: DynFlags -> Bag ErrMsg -> Severity -> IO ()
-printMsgBag dflags bag sev
+pprLocErrMsg :: ErrMsg -> SDoc
+pprLocErrMsg (ErrMsg { errMsgSpans     = spans
+                     , errMsgShortDoc  = d
+                     , errMsgExtraInfo = e
+                     , errMsgSeverity  = sev
+                     , errMsgContext   = unqual })
+  = withPprStyle (mkErrStyle unqual) (mkLocMessage sev s (d $$ e))
+  where
+    (s : _) = spans   -- Should be non-empty
+
+printMsgBag :: DynFlags -> Bag ErrMsg -> IO ()
+printMsgBag dflags bag
   = sequence_ [ let style = mkErrStyle unqual
                 in log_action dflags sev s style (d $$ e)
               | ErrMsg { errMsgSpans     = s:_,
                          errMsgShortDoc  = d,
+                         errMsgSeverity  = sev,
                          errMsgExtraInfo = e,
                          errMsgContext   = unqual } <- sortMsgBag bag ]
 
@@ -293,22 +298,22 @@ ifVerbose dflags val act
   | verbosity dflags >= val = act
   | otherwise               = return ()
 
-putMsg :: DynFlags -> Message -> IO ()
+putMsg :: DynFlags -> MsgDoc -> IO ()
 putMsg dflags msg = log_action dflags SevInfo noSrcSpan defaultUserStyle msg
 
-putMsgWith :: DynFlags -> PrintUnqualified -> Message -> IO ()
+putMsgWith :: DynFlags -> PrintUnqualified -> MsgDoc -> IO ()
 putMsgWith dflags print_unqual msg
   = log_action dflags SevInfo noSrcSpan sty msg
   where
     sty = mkUserStyle print_unqual AllTheWay
 
-errorMsg :: DynFlags -> Message -> IO ()
+errorMsg :: DynFlags -> MsgDoc -> IO ()
 errorMsg dflags msg = log_action dflags SevError noSrcSpan defaultErrStyle msg
 
-fatalErrorMsg :: DynFlags -> Message -> IO ()
+fatalErrorMsg :: DynFlags -> MsgDoc -> IO ()
 fatalErrorMsg dflags msg = fatalErrorMsg' (log_action dflags) msg
 
-fatalErrorMsg' :: LogAction -> Message -> IO ()
+fatalErrorMsg' :: LogAction -> MsgDoc -> IO ()
 fatalErrorMsg' la msg = la SevFatal noSrcSpan defaultErrStyle msg
 
 compilationProgressMsg :: DynFlags -> String -> IO ()
@@ -319,7 +324,7 @@ showPass :: DynFlags -> String -> IO ()
 showPass dflags what
   = ifVerbose dflags 2 (log_action dflags SevInfo noSrcSpan defaultUserStyle (text "***" <+> text what <> colon))
 
-debugTraceMsg :: DynFlags -> Int -> Message -> IO ()
+debugTraceMsg :: DynFlags -> Int -> MsgDoc -> IO ()
 debugTraceMsg dflags val msg
   = ifVerbose dflags val (log_action dflags SevInfo noSrcSpan defaultDumpStyle msg)
 \end{code}
diff --git a/compiler/main/ErrUtils.lhs-boot b/compiler/main/ErrUtils.lhs-boot
index 08115a4b48..7718cbe2a6 100644
--- a/compiler/main/ErrUtils.lhs-boot
+++ b/compiler/main/ErrUtils.lhs-boot
@@ -11,8 +11,8 @@ data Severity
   | SevError
   | SevFatal
 
-type Message = SDoc
+type MsgDoc = SDoc
 
-mkLocMessage :: SrcSpan -> Message -> Message
+mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc
 \end{code}
 
diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs
index 9fad73a9f8..6322024c9e 100644
--- a/compiler/main/HeaderInfo.hs
+++ b/compiler/main/HeaderInfo.hs
@@ -123,7 +123,7 @@ mkPrelImports this_mod loc implicit_prelude import_decls
       		    	       ideclAs        = Nothing,
       		    	       ideclHiding    = Nothing  }
 
-parseError :: SrcSpan -> Message -> IO a
+parseError :: SrcSpan -> MsgDoc -> IO a
 parseError span err = throwOneError $ mkPlainErrMsg span err
 
 --------------------------------------------------------------
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index 8c9e9a8f00..fc53d9d544 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -266,7 +266,7 @@ throwErrors = liftIO . throwIO . mkSrcErr
 --     failed, it must have been due to the warnings (i.e., @-Werror@).
 ioMsgMaybe :: IO (Messages, Maybe a) -> Hsc a
 ioMsgMaybe ioA = do
-    ((warns,errs), mb_r) <- liftIO $ ioA
+    ((warns,errs), mb_r) <- liftIO ioA
     logWarnings warns
     case mb_r of
         Nothing -> throwErrors errs
@@ -844,8 +844,7 @@ hscFileFrontEnd mod_summary = do
             return tcg_env'
   where
     pprMod t  = ppr $ moduleName $ tcg_mod t
-    errSafe t = text "Warning:" <+> quotes (pprMod t)
-                   <+> text "has been infered as safe!"
+    errSafe t = quotes (pprMod t) <+> text "has been infered as safe!"
 
 --------------------------------------------------------------
 -- Safe Haskell
@@ -1120,8 +1119,7 @@ wipeTrust tcg_env whyUnsafe = do
   where
     wiped_trust = (tcg_imports tcg_env) { imp_trust_pkgs = [] }
     pprMod      = ppr $ moduleName $ tcg_mod tcg_env
-    whyUnsafe'  = vcat [ text "Warning:" <+> quotes pprMod
-                             <+> text "has been infered as unsafe!"
+    whyUnsafe'  = vcat [ quotes pprMod <+> text "has been infered as unsafe!"
                        , text "Reason:"
                        , nest 4 (vcat $ pprErrMsgBag whyUnsafe) ]
 
diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs
index 3eda19fba1..b6bf938332 100644
--- a/compiler/main/HscTypes.lhs
+++ b/compiler/main/HscTypes.lhs
@@ -238,12 +238,12 @@ printOrThrowWarnings dflags warns
   = when (not (isEmptyBag warns)) $ do
       throwIO $ mkSrcErr $ warns `snocBag` warnIsErrorMsg
   | otherwise
-  = printBagOfWarnings dflags warns
+  = printBagOfErrors dflags warns
 
 handleFlagWarnings :: DynFlags -> [Located String] -> IO ()
 handleFlagWarnings dflags warns
  = when (wopt Opt_WarnDeprecatedFlags dflags) $ do
-        -- It would be nicer if warns :: [Located Message], but that
+        -- It would be nicer if warns :: [Located MsgDoc], but that
         -- has circular import problems.
       let bag = listToBag [ mkPlainWarnMsg loc (text warn)
                           | L loc warn <- warns ]
diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs
index d7dc6bc764..d1fbe2f253 100644
--- a/compiler/main/Packages.lhs
+++ b/compiler/main/Packages.lhs
@@ -59,7 +59,7 @@ import Distribution.InstalledPackageInfo
 import Distribution.InstalledPackageInfo.Binary
 import Distribution.Package hiding (PackageId,depends)
 import FastString
-import ErrUtils         ( debugTraceMsg, putMsg, Message )
+import ErrUtils         ( debugTraceMsg, putMsg, MsgDoc )
 import Exception
 
 import System.Directory
@@ -986,7 +986,7 @@ closeDeps :: PackageConfigMap
           -> IO [PackageId]
 closeDeps pkg_map ipid_map ps = throwErr (closeDepsErr pkg_map ipid_map ps)
 
-throwErr :: MaybeErr Message a -> IO a
+throwErr :: MaybeErr MsgDoc a -> IO a
 throwErr m = case m of
 		Failed e    -> ghcError (CmdLineError (showSDoc e))
 		Succeeded r -> return r
@@ -994,7 +994,7 @@ throwErr m = case m of
 closeDepsErr :: PackageConfigMap
              -> Map InstalledPackageId PackageId
              -> [(PackageId,Maybe PackageId)]
-             -> MaybeErr Message [PackageId]
+             -> MaybeErr MsgDoc [PackageId]
 closeDepsErr pkg_map ipid_map ps = foldM (add_package pkg_map ipid_map) [] ps
 
 -- internal helper
@@ -1002,7 +1002,7 @@ add_package :: PackageConfigMap
             -> Map InstalledPackageId PackageId
             -> [PackageId]
             -> (PackageId,Maybe PackageId)
-            -> MaybeErr Message [PackageId]
+            -> MaybeErr MsgDoc [PackageId]
 add_package pkg_db ipid_map ps (p, mb_parent)
   | p `elem` ps = return ps	-- Check if we've already added this package
   | otherwise =