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
......@@ -105,7 +105,7 @@ find an occurence of an Id, we fetch it from the in-scope set.
\begin{code}
lintCoreBindings :: CoreProgram -> (Bag Message, Bag Message)
lintCoreBindings :: CoreProgram -> (Bag MsgDoc, Bag MsgDoc)
-- Returns (warnings, errors)
lintCoreBindings binds
= initL $
......@@ -150,7 +150,7 @@ We use this to check all unfoldings that come in from interfaces
lintUnfolding :: SrcLoc
-> [Var] -- Treat these as in scope
-> CoreExpr
-> Maybe Message -- Nothing => OK
-> Maybe MsgDoc -- Nothing => OK
lintUnfolding locn vars expr
| isEmptyBag errs = Nothing
......@@ -905,7 +905,7 @@ newtype LintM a =
WarnsAndErrs -> -- Error and warning messages so far
(Maybe a, WarnsAndErrs) } -- Result and messages (if any)
type WarnsAndErrs = (Bag Message, Bag Message)
type WarnsAndErrs = (Bag MsgDoc, Bag MsgDoc)
{- Note [Type substitution]
~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -953,23 +953,23 @@ initL m
\end{code}
\begin{code}
checkL :: Bool -> Message -> LintM ()
checkL :: Bool -> MsgDoc -> LintM ()
checkL True _ = return ()
checkL False msg = failWithL msg
failWithL :: Message -> LintM a
failWithL :: MsgDoc -> LintM a
failWithL msg = LintM $ \ loc subst (warns,errs) ->
(Nothing, (warns, addMsg subst errs msg loc))
addErrL :: Message -> LintM ()
addErrL :: MsgDoc -> LintM ()
addErrL msg = LintM $ \ loc subst (warns,errs) ->
(Just (), (warns, addMsg subst errs msg loc))
addWarnL :: Message -> LintM ()
addWarnL :: MsgDoc -> LintM ()
addWarnL msg = LintM $ \ loc subst (warns,errs) ->
(Just (), (addMsg subst warns msg loc, errs))
addMsg :: TvSubst -> Bag Message -> Message -> [LintLocInfo] -> Bag Message
addMsg :: TvSubst -> Bag MsgDoc -> MsgDoc -> [LintLocInfo] -> Bag MsgDoc
addMsg subst msgs msg locs
= ASSERT( notNull locs )
msgs `snocBag` mk_msg msg
......@@ -980,7 +980,7 @@ addMsg subst msgs msg locs
ptext (sLit "Substitution:") <+> ppr subst
| otherwise = cxt1
mk_msg msg = mkLocMessage (mkSrcSpan loc loc) (context $$ msg)
mk_msg msg = mkLocMessage SevWarning (mkSrcSpan loc loc) (context $$ msg)
addLoc :: LintLocInfo -> LintM a -> LintM a
addLoc extra_loc m =
......@@ -1052,7 +1052,7 @@ checkInScope loc_msg var =
; checkL (not (mustHaveLocalBinding var) || (var `isInScope` subst))
(hsep [ppr var, loc_msg]) }
checkTys :: OutType -> OutType -> Message -> LintM ()
checkTys :: OutType -> OutType -> MsgDoc -> LintM ()
-- check ty2 is subtype of ty1 (ie, has same structure but usage
-- annotations need only be consistent, not equal)
-- Assumes ty1,ty2 are have alrady had the substitution applied
......@@ -1110,39 +1110,39 @@ pp_binder b | isId b = hsep [ppr b, dcolon, ppr (idType b)]
------------------------------------------------------
-- Messages for case expressions
mkNullAltsMsg :: CoreExpr -> Message
mkNullAltsMsg :: CoreExpr -> MsgDoc
mkNullAltsMsg e
= hang (text "Case expression with no alternatives:")
4 (ppr e)
mkDefaultArgsMsg :: [Var] -> Message
mkDefaultArgsMsg :: [Var] -> MsgDoc
mkDefaultArgsMsg args
= hang (text "DEFAULT case with binders")
4 (ppr args)
mkCaseAltMsg :: CoreExpr -> Type -> Type -> Message
mkCaseAltMsg :: CoreExpr -> Type -> Type -> MsgDoc
mkCaseAltMsg e ty1 ty2
= hang (text "Type of case alternatives not the same as the annotation on case:")
4 (vcat [ppr ty1, ppr ty2, ppr e])
mkScrutMsg :: Id -> Type -> Type -> TvSubst -> Message
mkScrutMsg :: Id -> Type -> Type -> TvSubst -> MsgDoc
mkScrutMsg var var_ty scrut_ty subst
= vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var,
text "Result binder type:" <+> ppr var_ty,--(idType var),
text "Scrutinee type:" <+> ppr scrut_ty,
hsep [ptext (sLit "Current TV subst"), ppr subst]]
mkNonDefltMsg, mkNonIncreasingAltsMsg :: CoreExpr -> Message
mkNonDefltMsg, mkNonIncreasingAltsMsg :: CoreExpr -> MsgDoc
mkNonDefltMsg e
= hang (text "Case expression with DEFAULT not at the beginnning") 4 (ppr e)
mkNonIncreasingAltsMsg e
= hang (text "Case expression with badly-ordered alternatives") 4 (ppr e)
nonExhaustiveAltsMsg :: CoreExpr -> Message
nonExhaustiveAltsMsg :: CoreExpr -> MsgDoc
nonExhaustiveAltsMsg e
= hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e)
mkBadConMsg :: TyCon -> DataCon -> Message
mkBadConMsg :: TyCon -> DataCon -> MsgDoc
mkBadConMsg tycon datacon
= vcat [
text "In a case alternative, data constructor isn't in scrutinee type:",
......@@ -1150,7 +1150,7 @@ mkBadConMsg tycon datacon
text "Data con:" <+> ppr datacon
]
mkBadPatMsg :: Type -> Type -> Message
mkBadPatMsg :: Type -> Type -> MsgDoc
mkBadPatMsg con_result_ty scrut_ty
= vcat [
text "In a case alternative, pattern result type doesn't match scrutinee type:",
......@@ -1158,17 +1158,17 @@ mkBadPatMsg con_result_ty scrut_ty
text "Scrutinee type:" <+> ppr scrut_ty
]
integerScrutinisedMsg :: Message
integerScrutinisedMsg :: MsgDoc
integerScrutinisedMsg
= text "In a LitAlt, the literal is lifted (probably Integer)"
mkBadAltMsg :: Type -> CoreAlt -> Message
mkBadAltMsg :: Type -> CoreAlt -> MsgDoc
mkBadAltMsg scrut_ty alt
= vcat [ text "Data alternative when scrutinee is not a tycon application",
text "Scrutinee type:" <+> ppr scrut_ty,
text "Alternative:" <+> pprCoreAlt alt ]
mkNewTyDataConAltMsg :: Type -> CoreAlt -> Message
mkNewTyDataConAltMsg :: Type -> CoreAlt -> MsgDoc
mkNewTyDataConAltMsg scrut_ty alt
= vcat [ text "Data alternative for newtype datacon",
text "Scrutinee type:" <+> ppr scrut_ty,
......@@ -1178,21 +1178,21 @@ mkNewTyDataConAltMsg scrut_ty alt
------------------------------------------------------
-- Other error messages
mkAppMsg :: Type -> Type -> CoreExpr -> Message
mkAppMsg :: Type -> Type -> CoreExpr -> MsgDoc
mkAppMsg fun_ty arg_ty arg
= vcat [ptext (sLit "Argument value doesn't match argument type:"),
hang (ptext (sLit "Fun type:")) 4 (ppr fun_ty),
hang (ptext (sLit "Arg type:")) 4 (ppr arg_ty),
hang (ptext (sLit "Arg:")) 4 (ppr arg)]
mkNonFunAppMsg :: Type -> Type -> CoreExpr -> Message
mkNonFunAppMsg :: Type -> Type -> CoreExpr -> MsgDoc
mkNonFunAppMsg fun_ty arg_ty arg
= vcat [ptext (sLit "Non-function type in function position"),
hang (ptext (sLit "Fun type:")) 4 (ppr fun_ty),
hang (ptext (sLit "Arg type:")) 4 (ppr arg_ty),
hang (ptext (sLit "Arg:")) 4 (ppr arg)]
mkLetErr :: TyVar -> CoreExpr -> Message
mkLetErr :: TyVar -> CoreExpr -> MsgDoc
mkLetErr bndr rhs
= vcat [ptext (sLit "Bad `let' binding:"),
hang (ptext (sLit "Variable:"))
......@@ -1200,7 +1200,7 @@ mkLetErr bndr rhs
hang (ptext (sLit "Rhs:"))
4 (ppr rhs)]
mkTyCoAppErrMsg :: TyVar -> Coercion -> Message
mkTyCoAppErrMsg :: TyVar -> Coercion -> MsgDoc
mkTyCoAppErrMsg tyvar arg_co
= vcat [ptext (sLit "Kinds don't match in lifted coercion application:"),
hang (ptext (sLit "Type variable:"))
......@@ -1208,7 +1208,7 @@ mkTyCoAppErrMsg tyvar arg_co
hang (ptext (sLit "Arg coercion:"))
4 (ppr arg_co <+> dcolon <+> pprEqPred (coercionKind arg_co))]
mkTyAppMsg :: Type -> Type -> Message
mkTyAppMsg :: Type -> Type -> MsgDoc
mkTyAppMsg ty arg_ty
= vcat [text "Illegal type application:",
hang (ptext (sLit "Exp type:"))
......@@ -1216,7 +1216,7 @@ mkTyAppMsg ty arg_ty
hang (ptext (sLit "Arg type:"))
4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
mkRhsMsg :: Id -> Type -> Message
mkRhsMsg :: Id -> Type -> MsgDoc
mkRhsMsg binder ty
= vcat
[hsep [ptext (sLit "The type of this binder doesn't match the type of its RHS:"),
......@@ -1224,14 +1224,14 @@ mkRhsMsg binder ty
hsep [ptext (sLit "Binder's type:"), ppr (idType binder)],
hsep [ptext (sLit "Rhs type:"), ppr ty]]
mkRhsPrimMsg :: Id -> CoreExpr -> Message
mkRhsPrimMsg :: Id -> CoreExpr -> MsgDoc
mkRhsPrimMsg binder _rhs
= vcat [hsep [ptext (sLit "The type of this binder is primitive:"),
ppr binder],
hsep [ptext (sLit "Binder's type:"), ppr (idType binder)]
]
mkStrictMsg :: Id -> Message
mkStrictMsg :: Id -> MsgDoc
mkStrictMsg binder
= vcat [hsep [ptext (sLit "Recursive or top-level binder has strict demand info:"),
ppr binder],
......@@ -1239,7 +1239,7 @@ mkStrictMsg binder
]
mkKindErrMsg :: TyVar -> Type -> Message
mkKindErrMsg :: TyVar -> Type -> MsgDoc
mkKindErrMsg tyvar arg_ty
= vcat [ptext (sLit "Kinds don't match in type application:"),
hang (ptext (sLit "Type variable:"))
......@@ -1247,7 +1247,7 @@ mkKindErrMsg tyvar arg_ty
hang (ptext (sLit "Arg type:"))
4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
mkArityMsg :: Id -> Message
mkArityMsg :: Id -> MsgDoc
mkArityMsg binder
= vcat [hsep [ptext (sLit "Demand type has "),
ppr (dmdTypeDepth dmd_ty),
......@@ -1260,24 +1260,24 @@ mkArityMsg binder
]
where (StrictSig dmd_ty) = idStrictness binder
mkUnboxedTupleMsg :: Id -> Message
mkUnboxedTupleMsg :: Id -> MsgDoc
mkUnboxedTupleMsg binder
= vcat [hsep [ptext (sLit "A variable has unboxed tuple type:"), ppr binder],
hsep [ptext (sLit "Binder's type:"), ppr (idType binder)]]
mkCastErr :: Type -> Type -> Message
mkCastErr :: Type -> Type -> MsgDoc
mkCastErr from_ty expr_ty
= vcat [ptext (sLit "From-type of Cast differs from type of enclosed expression"),
ptext (sLit "From-type:") <+> ppr from_ty,
ptext (sLit "Type of enclosed expr:") <+> ppr expr_ty
]
dupVars :: [[Var]] -> Message
dupVars :: [[Var]] -> MsgDoc
dupVars vars
= hang (ptext (sLit "Duplicate variables brought into scope"))
2 (ppr vars)
dupExtVars :: [[Name]] -> Message
dupExtVars :: [[Name]] -> MsgDoc
dupExtVars vars
= hang (ptext (sLit "Duplicate top-level variables with the same qualified name"))
2 (ppr vars)
......@@ -1310,7 +1310,7 @@ lintSplitCoVar cv
Nothing -> failWithL (sep [ ptext (sLit "Coercion variable with non-equality kind:")
, nest 2 (ppr cv <+> dcolon <+> ppr (tyVarKind cv))])
mkCoVarLetErr :: CoVar -> Coercion -> Message
mkCoVarLetErr :: CoVar -> Coercion -> MsgDoc
mkCoVarLetErr covar co
= vcat [ptext (sLit "Bad `let' binding for coercion variable:"),
hang (ptext (sLit "Coercion variable:"))
......@@ -1318,7 +1318,7 @@ mkCoVarLetErr covar co
hang (ptext (sLit "Arg coercion:"))
4 (ppr co)]
mkCoAppErrMsg :: CoVar -> Coercion -> Message
mkCoAppErrMsg :: CoVar -> Coercion -> MsgDoc
mkCoAppErrMsg covar arg_co
= vcat [ptext (sLit "Kinds don't match in coercion application:"),
hang (ptext (sLit "Coercion variable:"))
......@@ -1327,7 +1327,7 @@ mkCoAppErrMsg covar arg_co
4 (ppr arg_co <+> dcolon <+> pprEqPred (coercionKind arg_co))]
mkCoAppMsg :: Type -> Coercion -> Message
mkCoAppMsg :: Type -> Coercion -> MsgDoc
mkCoAppMsg ty arg_co
= vcat [text "Illegal type application:",
hang (ptext (sLit "exp type:"))
......
......@@ -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
}