Implememt -fdefer-type-errors (Trac #5624)

This patch implements the idea of deferring (most) type errors to
runtime, instead emitting only a warning at compile time.  The
basic idea is very simple:

 * The on-the-fly unifier in TcUnify never fails; instead if it
   gets stuck it emits a constraint.

 * The constraint solver tries to solve the constraints (and is
   entirely unchanged, hooray).

 * The remaining, unsolved constraints (if any) are passed to
   TcErrors.reportUnsolved.  With -fdefer-type-errors, instead of
   emitting an error message, TcErrors emits a warning, AND emits
   a binding for the constraint witness, binding it
   to (error "the error message"), via the new form of evidence
   TcEvidence.EvDelayedError.  So, when the program is run,
   when (and only when) that witness is needed, the program will
   crash with the exact same error message that would have been
   given at compile time.

Simple really.  But, needless to say, the exercise forced me
into some major refactoring.

 * TcErrors is almost entirely rewritten

 * EvVarX and WantedEvVar have gone away entirely

 * ErrUtils is changed a bit:
     * New Severity field in ErrMsg
     * Renamed the type Message to MsgDoc (this change
       touches a lot of files trivially)

 * One minor change is that in the constraint solver we try
   NOT to combine insoluble constraints, like Int~Bool, else
   all such type errors get combined together and result in
   only one error message!

 * I moved some definitions from TcSMonad to TcRnTypes,
   where they seem to belong more

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 =