Implememt -fdefer-type-errors (Trac #5624)
[ghc.git] / compiler / main / ErrUtils.lhs
index 1cce4ec..6ba9df4 100644 (file)
@@ -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}