Commit 4a138b70 authored by ian@well-typed.com's avatar ian@well-typed.com

Merge branch 'master' of darcs.haskell.org:/srv/darcs//ghc

parents 6784dddc ed5ebee4
......@@ -107,7 +107,7 @@ dsOverLit' dflags (OverLit { ol_val = val, ol_rebindable = rebindable
, ol_witness = witness, ol_type = ty })
| not rebindable
, Just expr <- shortCutLit dflags val ty = dsExpr expr -- Note [Literal short cut]
| otherwise = dsExpr witness
| otherwise = dsExpr witness
\end{code}
Note [Literal short cut]
......
......@@ -619,6 +619,7 @@ hsExprNeedsParens (PArrSeq {}) = False
hsExprNeedsParens (HsLit {}) = False
hsExprNeedsParens (HsOverLit {}) = False
hsExprNeedsParens (HsVar {}) = False
hsExprNeedsParens (HsHole {}) = False
hsExprNeedsParens (HsIPVar {}) = False
hsExprNeedsParens (ExplicitTuple {}) = False
hsExprNeedsParens (ExplicitList {}) = False
......@@ -637,6 +638,7 @@ isAtomicHsExpr (HsVar {}) = True
isAtomicHsExpr (HsLit {}) = True
isAtomicHsExpr (HsOverLit {}) = True
isAtomicHsExpr (HsIPVar {}) = True
isAtomicHsExpr (HsHole {}) = True
isAtomicHsExpr (HsWrap _ e) = isAtomicHsExpr e
isAtomicHsExpr (HsPar e) = isAtomicHsExpr (unLoc e)
isAtomicHsExpr _ = False
......
......@@ -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
......
......@@ -627,8 +627,7 @@ discardWarnings thing_inside
\begin{code}
mkLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ErrMsg
mkLongErrAt loc msg extra
= do { traceTc "Adding error:" (mkLocMessage SevError loc (msg $$ extra)) ;
rdr_env <- getGlobalRdrEnv ;
= do { rdr_env <- getGlobalRdrEnv ;
dflags <- getDynFlags ;
return $ mkLongErrMsg dflags loc (mkPrintUnqualified dflags rdr_env) msg extra }
......@@ -640,13 +639,15 @@ reportErrors = mapM_ reportError
reportError :: ErrMsg -> TcRn ()
reportError err
= do { errs_var <- getErrsVar ;
= do { traceTc "Adding error:" (pprLocErrMsg err) ;
errs_var <- getErrsVar ;
(warns, errs) <- readTcRef errs_var ;
writeTcRef errs_var (warns, errs `snocBag` err) }
reportWarning :: ErrMsg -> TcRn ()
reportWarning warn
= do { errs_var <- getErrsVar ;
= do { traceTc "Adding warning:" (pprLocErrMsg warn) ;
errs_var <- getErrsVar ;
(warns, errs) <- readTcRef errs_var ;
writeTcRef errs_var (warns `snocBag` warn, errs) }
......
......@@ -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 } }
......
......@@ -1600,28 +1600,28 @@ Main purpose: create new evidence for new_pred;
-- NB: this allows us to sneak away with ``error'' thunks for
-- coercions that come from derived ids (which don't exist!)
rewriteCtFlavor (CtDerived {}) pty_new _co
= newDerived pty_new
rewriteCtFlavor (CtGiven { ctev_evtm = old_tm }) pty_new co
= do { new_ev <- newGivenEvVar pty_new new_tm -- See Note [Bind new Givens immediately]
; return (Just new_ev) }
where
new_tm = mkEvCast old_tm (mkTcSymCo co) -- mkEvCast optimises ReflCo
rewriteCtFlavor ctev@(CtWanted { ctev_evar = evar, ctev_pred = old_pred })
new_pred co
rewriteCtFlavor old_ev new_pred co
| isTcReflCo co -- If just reflexivity then you may re-use the same variable
= return (Just (if old_pred `eqType` new_pred
then ctev
else ctev { ctev_pred = new_pred }))
= return (Just (if ctEvPred old_ev `eqType` new_pred
then old_ev
else old_ev { ctev_pred = new_pred }))
-- Even if the coercion is Refl, it might reflect the result of unification alpha := ty
-- so old_pred and new_pred might not *look* the same, and it's vital to proceed from
-- now on using new_pred.
-- However, if they *do* look the same, we'd prefer to stick with old_pred
-- then retain the old type, so that error messages come out mentioning synonyms
| otherwise
rewriteCtFlavor (CtDerived {}) new_pred _co
= newDerived new_pred
rewriteCtFlavor (CtGiven { ctev_evtm = old_tm }) new_pred co
= do { new_ev <- newGivenEvVar new_pred new_tm -- See Note [Bind new Givens immediately]
; return (Just new_ev) }
where
new_tm = mkEvCast old_tm (mkTcSymCo co) -- mkEvCast optimises ReflCo
rewriteCtFlavor (CtWanted { ctev_evar = evar, ctev_pred = old_pred }) new_pred co
= do { new_evar <- newWantedEvVar new_pred
; setEvBind evar (mkEvCast (getEvTerm new_evar) co)
; case new_evar of
......
......@@ -79,7 +79,9 @@ simplifyTop wanteds
; simpl_top_loop wc_first_go }
simpl_top_loop wc
| isEmptyWC wc
| isEmptyWC wc || insolubleWC wc
-- Don't do type-class defaulting if there are insolubles
-- Doing so is not going to solve the insolubles
= return wc
| otherwise
= do { wc_residual <- nestTcS (solve_wanteds_and_drop wc)
......
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