Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

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

  • Loading branch information...
commit 4a138b708463a99a1087ce2d8a70239de3aa04e4 2 parents 6784ddd + ed5ebee
@igfoo igfoo authored
View
2  compiler/deSugar/MatchLit.lhs
@@ -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]
View
2  compiler/hsSyn/HsExpr.lhs
@@ -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
View
91 compiler/typecheck/TcErrors.lhs
@@ -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
View
9 compiler/typecheck/TcRnMonad.lhs
@@ -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) }
View
5 compiler/typecheck/TcRnTypes.lhs
@@ -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 } }
View
30 compiler/typecheck/TcSMonad.lhs
@@ -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
View
4 compiler/typecheck/TcSimplify.lhs
@@ -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)
Please sign in to comment.
Something went wrong with that request. Please try again.