Commit 5508ada4 authored by Simon Peyton Jones's avatar Simon Peyton Jones

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
parent b8fe21e9
This diff is collapsed.
......@@ -32,6 +32,7 @@ import DsUtils
import HsSyn -- lots of things
import CoreSyn -- lots of things
import Literal ( Literal(MachStr) )
import CoreSubst
import MkCore
import CoreUtils
......@@ -40,6 +41,7 @@ import CoreUnfold
import CoreFVs
import Digraph
import TyCon ( isTupleTyCon, tyConDataCons_maybe )
import TcEvidence
import TcType
......@@ -705,7 +707,10 @@ dsEvTerm (EvSuperClass d n)
= Var sc_sel_id `mkTyApps` tys `App` Var d
where
sc_sel_id = classSCSelId cls n -- Zero-indexed
(cls, tys) = getClassPredTys (evVarPred d)
(cls, tys) = getClassPredTys (evVarPred d)
dsEvTerm (EvDelayedError ty msg) = Var errorId `mkTyApps` [ty] `mkApps` [litMsg]
where errorId = rUNTIME_ERROR_ID
litMsg = Lit (MachStr msg)
---------------------------------------
dsTcCoercion :: TcCoercion -> (Coercion -> CoreExpr) -> CoreExpr
......
......@@ -226,7 +226,7 @@ initDs hsc_env mod rdr_env type_env thing_inside
where
loadOneModule :: ModuleName -- the module to load
-> DsM Bool -- under which condition
-> Message -- error message if module not found
-> MsgDoc -- error message if module not found
-> DsM GlobalRdrEnv -- empty if condition 'False'
loadOneModule modname check err
= do { doLoad <- check
......@@ -370,8 +370,7 @@ putSrcSpanDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc})
warnDs :: SDoc -> DsM ()
warnDs warn = do { env <- getGblEnv
; loc <- getSrcSpanDs
; let msg = mkWarnMsg loc (ds_unqual env)
(ptext (sLit "Warning:") <+> warn)
; let msg = mkWarnMsg loc (ds_unqual env) warn
; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) }
failWithDs :: SDoc -> DsM a
......
......@@ -443,8 +443,8 @@ linkExpr hsc_env span root_ul_bco
-- All wired-in names are in the base package, which we link
-- by default, so we can safely ignore them here.
dieWith :: SrcSpan -> Message -> IO a
dieWith span msg = ghcError (ProgramError (showSDoc (mkLocMessage span msg)))
dieWith :: SrcSpan -> MsgDoc -> IO a
dieWith span msg = ghcError (ProgramError (showSDoc (mkLocMessage SevFatal span msg)))
checkNonStdWay :: DynFlags -> SrcSpan -> IO Bool
......
......@@ -48,25 +48,25 @@ import GHC.Exts
-------------------------------------------------------------------
-- The external interface
convertToHsDecls :: SrcSpan -> [TH.Dec] -> Either Message [LHsDecl RdrName]
convertToHsDecls :: SrcSpan -> [TH.Dec] -> Either MsgDoc [LHsDecl RdrName]
convertToHsDecls loc ds = initCvt loc (mapM cvt_dec ds)
where
cvt_dec d = wrapMsg "declaration" d (cvtDec d)
convertToHsExpr :: SrcSpan -> TH.Exp -> Either Message (LHsExpr RdrName)
convertToHsExpr :: SrcSpan -> TH.Exp -> Either MsgDoc (LHsExpr RdrName)
convertToHsExpr loc e
= initCvt loc $ wrapMsg "expression" e $ cvtl e
convertToPat :: SrcSpan -> TH.Pat -> Either Message (LPat RdrName)
convertToPat :: SrcSpan -> TH.Pat -> Either MsgDoc (LPat RdrName)
convertToPat loc p
= initCvt loc $ wrapMsg "pattern" p $ cvtPat p
convertToHsType :: SrcSpan -> TH.Type -> Either Message (LHsType RdrName)
convertToHsType :: SrcSpan -> TH.Type -> Either MsgDoc (LHsType RdrName)
convertToHsType loc t
= initCvt loc $ wrapMsg "type" t $ cvtType t
-------------------------------------------------------------------
newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either Message a }
newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either MsgDoc a }
-- Push down the source location;
-- Can fail, with a single error message
......@@ -85,13 +85,13 @@ instance Monad CvtM where
Left err -> Left err
Right v -> unCvtM (k v) loc
initCvt :: SrcSpan -> CvtM a -> Either Message a
initCvt :: SrcSpan -> CvtM a -> Either MsgDoc a
initCvt loc (CvtM m) = m loc
force :: a -> CvtM ()
force a = a `seq` return ()
failWith :: Message -> CvtM a
failWith :: MsgDoc -> CvtM a
failWith m = CvtM (\_ -> Left m)
getL :: CvtM SrcSpan
......@@ -232,7 +232,7 @@ cvtDec (TySynInstD tc tys rhs)
; returnL $ TyClD (TySynonym tc' tvs' tys' rhs') }
----------------
cvt_ci_decs :: Message -> [TH.Dec]
cvt_ci_decs :: MsgDoc -> [TH.Dec]
-> CvtM (LHsBinds RdrName,
[LSig RdrName],
[LTyClDecl RdrName])
......@@ -304,7 +304,7 @@ is_bind :: LHsDecl RdrName -> Either (LHsBind RdrName) (LHsDecl RdrName)
is_bind (L loc (Hs.ValD bind)) = Left (L loc bind)
is_bind decl = Right decl
mkBadDecMsg :: Message -> [LHsDecl RdrName] -> Message
mkBadDecMsg :: MsgDoc -> [LHsDecl RdrName] -> MsgDoc
mkBadDecMsg doc bads
= sep [ ptext (sLit "Illegal declaration(s) in") <+> doc <> colon
, nest 2 (vcat (map Outputable.ppr bads)) ]
......@@ -437,7 +437,7 @@ cvtInlineSpec (Just (TH.InlineSpec inline conlike opt_activation))
-- Declarations
---------------------------------------------------
cvtLocalDecs :: Message -> [TH.Dec] -> CvtM (HsLocalBinds RdrName)
cvtLocalDecs :: MsgDoc -> [TH.Dec] -> CvtM (HsLocalBinds RdrName)
cvtLocalDecs doc ds
| null ds
= return EmptyLocalBinds
......
......@@ -167,7 +167,7 @@ loadInterfaceWithException doc mod_name where_from
------------------
loadInterface :: SDoc -> Module -> WhereFrom
-> IfM lcl (MaybeErr Message ModIface)
-> IfM lcl (MaybeErr MsgDoc ModIface)
-- loadInterface looks in both the HPT and PIT for the required interface
-- If not found, it loads it, and puts it in the PIT (always).
......@@ -294,7 +294,7 @@ loadInterface doc_str mod from
}}}}
wantHiBootFile :: DynFlags -> ExternalPackageState -> Module -> WhereFrom
-> MaybeErr Message IsBootInterface
-> MaybeErr MsgDoc IsBootInterface
-- Figure out whether we want Foo.hi or Foo.hi-boot
wantHiBootFile dflags eps mod from
= case from of
......@@ -472,7 +472,7 @@ bumpDeclStats name
findAndReadIface :: SDoc -> Module
-> IsBootInterface -- True <=> Look for a .hi-boot file
-- False <=> Look for .hi file
-> TcRnIf gbl lcl (MaybeErr Message (ModIface, FilePath))
-> TcRnIf gbl lcl (MaybeErr MsgDoc (ModIface, FilePath))
-- Nothing <=> file not found, or unreadable, or illegible
-- Just x <=> successfully found and parsed
......@@ -537,7 +537,7 @@ findAndReadIface doc_str mod hi_boot_file
\begin{code}
readIface :: Module -> FilePath -> IsBootInterface
-> TcRnIf gbl lcl (MaybeErr Message ModIface)
-> TcRnIf gbl lcl (MaybeErr MsgDoc ModIface)
-- Failed err <=> file not found, or unreadable, or illegible
-- Succeeded iface <=> successfully found and parsed
......@@ -794,7 +794,7 @@ badIfaceFile file err
= vcat [ptext (sLit "Bad interface file:") <+> text file,
nest 4 err]
hiModuleNameMismatchWarn :: Module -> Module -> Message
hiModuleNameMismatchWarn :: Module -> Module -> MsgDoc
hiModuleNameMismatchWarn requested_mod read_mod =
withPprStyle defaultUserStyle $
-- we want the Modules below to be qualified with package names,
......
......@@ -844,7 +844,7 @@ oldMD5 dflags bh = do
instOrphWarn :: PrintUnqualified -> ClsInst -> WarnMsg
instOrphWarn unqual inst
= mkWarnMsg (getSrcSpan inst) unqual $
hang (ptext (sLit "Warning: orphan instance:")) 2 (pprInstanceHdr inst)
hang (ptext (sLit "Orphan instance:")) 2 (pprInstanceHdr inst)
ruleOrphWarn :: PrintUnqualified -> Module -> IfaceRule -> WarnMsg
ruleOrphWarn unqual mod rule
......
......@@ -125,7 +125,7 @@ tcImportDecl name
Succeeded thing -> return thing
Failed err -> failWithTc err }
importDecl :: Name -> IfM lcl (MaybeErr Message TyThing)
importDecl :: Name -> IfM lcl (MaybeErr MsgDoc TyThing)
-- Get the TyThing for this Name from an interface file
-- It's not a wired-in thing -- the caller caught that
importDecl name
......
......@@ -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
......
......@@ -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 ),
......
......@@ -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}
......
......@@ -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}
......@@ -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
--------------------------------------------------------------
......
......@@ -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) ]
......
......@@ -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 ]
......
......@@ -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 =
......
......@@ -145,7 +145,7 @@ haskell :-
-- everywhere: skip whitespace and comments
$white_no_nl+ ;
$tab+ { warn Opt_WarnTabs (text "Warning: Tab character") }
$tab+ { warn Opt_WarnTabs (text "Tab character") }
-- Everywhere: deal with nested comments. We explicitly rule out
-- pragmas, "{-#", so that we don't accidentally treat them as comments.
......@@ -1484,7 +1484,7 @@ data ParseResult a
SrcSpan -- The start and end of the text span related to
-- the error. Might be used in environments which can
-- show this span, e.g. by highlighting it.
Message -- The error message
MsgDoc -- The error message
data PState = PState {
buffer :: StringBuffer,
......@@ -1959,7 +1959,7 @@ getOffside = P $ \s@PState{last_loc=loc, context=stk} ->
srcParseErr
:: StringBuffer -- current buffer (placed just after the last token)
-> Int -- length of the previous token
-> Message
-> MsgDoc
srcParseErr buf len
= hcat [ if null token
then ptext (sLit "parse error (possibly incorrect indentation)")
......
......@@ -63,7 +63,7 @@ import Module ( ModuleName, moduleName )
import UniqFM
import DataCon ( dataConFieldLabels )
import PrelNames ( mkUnboundName, rOOT_MAIN, forall_tv_RDR )
import ErrUtils ( Message )
import ErrUtils ( MsgDoc )
import SrcLoc
import Outputable
import Util
......@@ -672,7 +672,7 @@ lookupSigOccRn ctxt sig
lookupBindGroupOcc :: HsSigCtxt
-> SDoc
-> RdrName -> RnM (Either Message Name)
-> RdrName -> RnM (Either MsgDoc Name)
-- Looks up the RdrName, expecting it to resolve to one of the
-- bound names passed in. If not, return an appropriate error message
--
......
......@@ -725,9 +725,9 @@ filterImports iface decl_spec (Just (want_hiding, import_items))
-- data constructors of an associated family, we need separate
-- AvailInfos for the data constructors and the family (as they have
-- different parents). See the discussion at occ_env.
lookup_ie :: Bool -> IE RdrName -> MaybeErr Message [(IE Name,AvailInfo)]
lookup_ie :: Bool -> IE RdrName -> MaybeErr MsgDoc [(IE Name,AvailInfo)]
lookup_ie opt_typeFamilies ie
= let bad_ie :: MaybeErr Message a
= let bad_ie :: MaybeErr MsgDoc a
bad_ie = Failed (badImportItemErr iface decl_spec ie all_avails)
lookup_name rdr
......@@ -1680,7 +1680,7 @@ typeItemErr name wherestr
ptext (sLit "Use -XTypeFamilies to enable this extension") ]
exportClashErr :: GlobalRdrEnv -> Name -> Name -> IE RdrName -> IE RdrName
-> Message
-> MsgDoc
exportClashErr global_env name1 name2 ie1 ie2
= vcat [ ptext (sLit "Conflicting exports for") <+> quotes (ppr occ) <> colon
, ppr_export ie1' name1'
......
......@@ -184,7 +184,7 @@ lintPassResult dflags pass binds
; displayLintResults dflags pass warns errs binds }
displayLintResults :: DynFlags -> CoreToDo
-> Bag Err.Message -> Bag Err.Message -> CoreProgram
-> Bag Err.MsgDoc -> Bag Err.MsgDoc -> CoreProgram
-> IO ()
displayLintResults dflags pass warns errs binds
| not (isEmptyBag errs)
......
......@@ -24,7 +24,7 @@ import PrimOp ( primOpType )
import Literal ( literalType )
import Maybes
import Name ( getSrcLoc )
import ErrUtils ( Message, mkLocMessage )
import ErrUtils ( MsgDoc, Severity(..), mkLocMessage )
import TypeRep
import Type
import TyCon
......@@ -288,8 +288,8 @@ lintAlt scrut_ty (DataAlt con, args, _, rhs) = do
newtype LintM a = LintM
{ unLintM :: [LintLocInfo] -- Locations
-> IdSet -- Local vars in scope
-> Bag Message -- Error messages so far
-> (a, Bag Message) -- Result and error messages (if any)
-> Bag MsgDoc -- Error messages so far
-> (a, Bag MsgDoc) -- Result and error messages (if any)
}
data LintLocInfo
......@@ -316,7 +316,7 @@ pp_binders bs
\end{code}
\begin{code}
initL :: LintM a -> Maybe Message
initL :: LintM a -> Maybe MsgDoc
initL (LintM m)
= case (m [] emptyVarSet emptyBag) of { (_, errs) ->
if isEmptyBag errs then
......@@ -342,19 +342,19 @@ thenL_ m k = LintM $ \loc scope errs
\end{code}
\begin{code}
checkL :: Bool -> Message -> LintM ()
checkL :: Bool -> MsgDoc -> LintM ()
checkL True _ = return ()
checkL False msg = addErrL msg
addErrL :: Message -> LintM ()
addErrL :: MsgDoc -> LintM ()
addErrL msg = LintM $ \loc _scope errs -> ((), addErr errs msg loc)
addErr :: Bag Message -> Message -> [LintLocInfo] -> Bag Message
addErr :: Bag MsgDoc -> MsgDoc -> [LintLocInfo] -> Bag MsgDoc
addErr errs_so_far msg locs
= errs_so_far `snocBag` mk_msg locs