Commit 629d1f48 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Improve erorr location for Given errors

Note [Inaccessible code].
Fixes Trac #7293.
parent b442ad94
......@@ -93,6 +93,11 @@ in TcErrors. TcErrors.reportTidyWanteds does not print the errors
and does not fail if -fwarn-type-errors is on, so that we can continue
compilation. The errors are turned into warnings in `reportUnsolved`.
Note [Suppressing error messages]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If there are any insolubles, like (Int~Bool), then we suppress all less-drastic
errors (like (Eq a)). Often the latter are a knock-on effect of the former.
\begin{code}
reportUnsolved :: WantedConstraints -> TcM (Bag EvBind)
reportUnsolved wanted
......@@ -122,15 +127,13 @@ report_unsolved mb_binds_var defer wanted
-- If we are deferring we are going to need /all/ evidence around,
-- including the evidence produced by unflattening (zonkWC)
-- ; errs_so_far <- ifErrsM (return True) (return False)
; let tidy_env = tidyFreeTyVars env0 free_tvs
free_tvs = tyVarsOfWC wanted
err_ctxt = CEC { cec_encl = []
, cec_tidy = tidy_env
, cec_defer = defer
, cec_suppress = insolubleWC wanted
-- Suppress all but insolubles if there are
-- any insoulubles, or earlier errors
-- See Note [Suppressing error messages]
, cec_binds = mb_binds_var }
; traceTc "reportUnsolved (after unflattening):" $
......@@ -189,14 +192,13 @@ reportWanteds :: ReportErrCtxt -> WantedConstraints -> TcM ()
reportWanteds ctxt (WC { wc_flat = flats, wc_insol = insols, wc_impl = implics })
= do { reportFlats (ctxt { cec_suppress = False }) (mapBag (tidyCt env) insols)
; reportFlats ctxt (mapBag (tidyCt env) flats)
-- All the Derived ones have been filtered out of flats
-- by the constraint solver. This is ok; we don't want
-- to report unsolved Derived goals as errors
-- See Note [Do not report derived but soluble errors]
; mapBagM_ (reportImplic ctxt) implics }
where
env = cec_tidy ctxt
-- tidy_cts = mapBag (tidyCt env) (insols `unionBags` flats)
-- All the Derived ones have been filtered out alrady
-- by the constraint solver. This is ok; we don't want
-- to report unsolved Derived goals as error
-- See Note [Do not report derived but soluble errors]
reportFlats :: ReportErrCtxt -> Cts -> TcM ()
reportFlats ctxt flats -- Here 'flats' includes insolble goals
......@@ -212,7 +214,6 @@ reportFlats ctxt flats -- Here 'flats' includes insolble goals
-- skolem-equalities, and they cause confusing knock-on
-- effects in other errors; see test T4093b.
, ("Skolem equalities", skolem_eq, mkUniReporter mkEqErr1) ]
-- , ("Unambiguous", unambiguous, reportFlatErrs) ]
reportFlatErrs
ctxt (bagToList flats)
where
......@@ -225,17 +226,6 @@ reportFlats ctxt flats -- Here 'flats' includes insolble goals
skolem_eq _ (EqPred ty1 ty2) = isRigidOrSkol ty1 && isRigidOrSkol ty2
skolem_eq _ _ = False
{-
unambiguous :: Ct -> PredTree -> Bool
unambiguous ct pred
| not (any isAmbiguousTyVar (varSetElems (tyVarsOfCt ct)))
= True
| otherwise
= case pred of
EqPred ty1 ty2 -> isNothing (isTyFun_maybe ty1) && isNothing (isTyFun_maybe ty2)
_ -> False
-}
---------------
isRigid, isRigidOrSkol :: Type -> Bool
isRigid ty
......@@ -324,11 +314,12 @@ mkGroupReporter mk_err ctxt (ct1 : rest)
maybeReportError :: ReportErrCtxt -> ErrMsg -> Ct -> TcM ()
-- Report the error and/or make a deferred binding for it
maybeReportError ctxt err ct
maybeReportError ctxt err _ct
| cec_defer ctxt -- We have -fdefer-type-errors
-- so warn about all, even if cec_suppress is on
= reportWarning (makeIntoWarning err)
| cec_suppress ctxt
= return ()
| isHoleCt ct || cec_defer ctxt -- And it's a hole or we have -fdefer-type-errors
= reportWarning (makeIntoWarning err)
| otherwise
= reportError err
......@@ -338,7 +329,7 @@ maybeAddDeferredBinding ctxt err ct
| CtWanted { ctev_pred = pred, ctev_evar = ev_id } <- cc_ev ct
-- Only add deferred bindings for Wanted constraints
, isHoleCt ct || cec_defer ctxt -- And it's a hole or we have -fdefer-type-errors
, Just ev_binds_var <- cec_binds ctxt -- We hvae somewhere to put the bindings
, Just ev_binds_var <- cec_binds ctxt -- We have somewhere to put the bindings
= do { dflags <- getDynFlags
; let err_msg = pprLocErrMsg err
err_fs = mkFastString $ showSDoc dflags $
......@@ -494,7 +485,7 @@ mkHoleError ctxt ct@(CHoleCan {})
loc_msg tv
= case tcTyVarDetails tv of
SkolemTv {} -> quotes (ppr tv) <+> skol_msg
MetaTv {} -> quotes (ppr tv) <+> text "is a free type variable"
MetaTv {} -> quotes (ppr tv) <+> text "is an ambiguous type variable"
det -> pprTcTyVarDetails det
where
skol_msg = pprSkol (getSkolemInfo (cec_encl ctxt) tv) (getSrcLoc tv)
......@@ -527,6 +518,24 @@ mkIPErr ctxt cts
%* *
%************************************************************************
Note [Inaccessible code]
~~~~~~~~~~~~~~~~~~~~~~~~
Consider
data T a where
T1 :: T a
T2 :: T Bool
f :: (a ~ Int) => T a -> Int
f T1 = 3
f T2 = 4 -- Unreachable code
Here the second equation is unreachable. The original constraint
(a~Int) from the signature gets rewritten by the pattern-match to
(Bool~Int), so the danger is that we report the error as coming from
the *signature* (Trac #7293). So, for Given errors we replace the
env (and hence src-loc) on its CtLoc with that from the immediately
enclosing implication.
\begin{code}
mkEqErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
-- Don't have multiple equality errors from the same location
......@@ -537,20 +546,30 @@ mkEqErr _ [] = panic "mkEqErr"
mkEqErr1 :: ReportErrCtxt -> Ct -> TcM ErrMsg
-- Wanted constraints only!
mkEqErr1 ctxt ct
| isGiven ev
= do { (ctxt, binds_msg) <- relevantBindings ctxt ct
; (ctxt, orig) <- zonkTidyOrigin ctxt orig
; let (is_oriented, wanted_msg) = mk_wanted_extra orig
; if isGiven ev then
mkEqErr_help ctxt (inaccessible_msg orig $$ binds_msg) ct Nothing ty1 ty2
else
mkEqErr_help ctxt (wanted_msg $$ binds_msg) ct is_oriented ty1 ty2 }
; let (given_loc, given_msg) = mk_given (cec_encl ctxt)
; mkEqErr_help ctxt (given_msg $$ binds_msg)
(ct { cc_loc = given_loc}) -- Note [Inaccessible code]
Nothing ty1 ty2 }
| otherwise -- Wanted or derived
= do { (ctxt, binds_msg) <- relevantBindings ctxt ct
; (ctxt, tidy_orig) <- zonkTidyOrigin ctxt (ctLocOrigin (cc_loc ct))
; let (is_oriented, wanted_msg) = mk_wanted_extra tidy_orig
; mkEqErr_help ctxt (wanted_msg $$ binds_msg)
ct is_oriented ty1 ty2 }
where
ev = cc_ev ct
orig = ctLocOrigin (cc_loc ct)
(ty1, ty2) = getEqPredTys (ctPred ct)
inaccessible_msg orig = hang (ptext (sLit "Inaccessible code in"))
2 (ppr orig)
(ty1, ty2) = getEqPredTys (ctEvPred ev)
mk_given :: [Implication] -> (CtLoc, SDoc)
-- For given constraints we overwrite the env (and hence src-loc)
-- with one from the implication. See Note [Inaccessible code]
mk_given [] = (cc_loc ct, empty)
mk_given (implic : _) = (setCtLocEnv (cc_loc ct) (ic_env implic)
, hang (ptext (sLit "Inaccessible code in"))
2 (ppr (ic_info implic)))
-- If the types in the error message are the same as the types
-- we are unifying, don't add the extra expected/actual message
......
......@@ -64,7 +64,7 @@ module TcRnTypes(
Implication(..),
CtLoc(..), ctLocSpan, ctLocEnv, ctLocOrigin,
ctLocDepth, bumpCtLocDepth,
setCtLocOrigin,
setCtLocOrigin, setCtLocEnv,
CtOrigin(..),
pushErrCtxt, pushErrCtxtSameOrigin,
......@@ -1360,6 +1360,9 @@ bumpCtLocDepth loc@(CtLoc { ctl_depth = d }) = loc { ctl_depth = d+1 }
setCtLocOrigin :: CtLoc -> CtOrigin -> CtLoc
setCtLocOrigin ctl orig = ctl { ctl_origin = orig }
setCtLocEnv :: CtLoc -> TcLclEnv -> CtLoc
setCtLocEnv ctl env = ctl { ctl_env = env }
pushErrCtxt :: CtOrigin -> ErrCtxt -> CtLoc -> CtLoc
pushErrCtxt o err loc@(CtLoc { ctl_env = lcl })
= loc { ctl_origin = o, ctl_env = lcl { tcl_ctxt = err : tcl_ctxt lcl } }
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment