Commit 32973bf3 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Major patch to add -fwarn-redundant-constraints

The idea was promted by Trac #9939, but it was Christmas, so I did
some recreational programming that went much further.

The idea is to warn when a constraint in a user-supplied context is
redundant.  Everything is described in detail in
  Note [Tracking redundant constraints]
in TcSimplify.

Main changes:

 * The new ic_status field in an implication, of type ImplicStatus.
   It replaces ic_insol, and includes information about redundant
   constraints.

 * New function TcSimplify.setImplicationStatus sets the ic_status.

 * TcSigInfo has sig_report_redundant field to say whenther a
   redundant constraint should be reported; and similarly
   the FunSigCtxt constructor of UserTypeCtxt

 * EvBinds has a field eb_is_given, to record whether it is a given
   or wanted binding. Some consequential chagnes to creating an evidence
   binding (so that we record whether it is given or wanted).

 * AbsBinds field abs_ev_binds is now a *list* of TcEvBiinds;
   see Note [Typechecking plan for instance declarations] in
   TcInstDcls

 * Some significant changes to the type checking of instance
   declarations; Note [Typechecking plan for instance declarations]
   in TcInstDcls.

 * I found that TcErrors.relevantBindings was failing to zonk the
   origin of the constraint it was looking at, and hence failing to
   find some relevant bindings.  Easy to fix, and orthogonal to
   everything else, but hard to disentangle.

Some minor refactorig:

 * TcMType.newSimpleWanteds moves to Inst, renamed as newWanteds

 * TcClassDcl and TcInstDcls now have their own code for typechecking
   a method body, rather than sharing a single function. The shared
   function (ws TcClassDcl.tcInstanceMethodBody) didn't have much code
   and the differences were growing confusing.

 * Add new function TcRnMonad.pushLevelAndCaptureConstraints, and
   use it

 * Add new function Bag.catBagMaybes, and use it in TcSimplify
parent da9b2ec3
......@@ -125,10 +125,12 @@ type RepArity = Int
-}
-- | Type of the tags associated with each constructor possibility
-- or superclass selector
type ConTag = Int
fIRST_TAG :: ConTag
-- ^ Tags are allocated from here for real constructors
-- or for superclass selectors
fIRST_TAG = 1
{-
......
......@@ -1156,8 +1156,8 @@ collectEvBinders (EvBinds bs) = foldrBag add_ev_bndr [] bs
collectEvBinders (TcEvBinds {}) = panic "ToDo: collectEvBinders"
add_ev_bndr :: EvBind -> [Id] -> [Id]
add_ev_bndr (EvBind b _) bs | isId b = b:bs
| otherwise = bs
add_ev_bndr (EvBind { eb_lhs = b }) bs | isId b = b:bs
| otherwise = bs
-- A worry: what about coercion variable binders??
collectLStmtsBinders :: [LStmt Id body] -> [Id]
......
......@@ -13,7 +13,7 @@ lower levels it is preserved with @let@/@letrec@s).
{-# LANGUAGE CPP #-}
module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec,
dsHsWrapper, dsTcEvBinds, dsEvBinds
dsHsWrapper, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds
) where
#include "HsVersions.h"
......@@ -137,9 +137,9 @@ dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
| ABE { abe_wrap = wrap, abe_poly = global
, abe_mono = local, abe_prags = prags } <- export
= do { dflags <- getDynFlags
; bind_prs <- ds_lhs_binds binds
; let core_bind = Rec (fromOL bind_prs)
; ds_binds <- dsTcEvBinds ev_binds
; bind_prs <- ds_lhs_binds binds
; let core_bind = Rec (fromOL bind_prs)
; ds_binds <- dsTcEvBinds_s ev_binds
; rhs <- dsHsWrapper wrap $ -- Usually the identity
mkLams tyvars $ mkLams dicts $
mkCoreLets ds_binds $
......@@ -167,7 +167,7 @@ dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
locals = map abe_mono exports
tup_expr = mkBigCoreVarTup locals
tup_ty = exprType tup_expr
; ds_binds <- dsTcEvBinds ev_binds
; ds_binds <- dsTcEvBinds_s ev_binds
; let poly_tup_rhs = mkLams tyvars $ mkLams dicts $
mkCoreLets ds_binds $
Let core_bind $
......@@ -832,6 +832,11 @@ dsHsWrapper (WpTyLam tv) e = return $ Lam tv e
dsHsWrapper (WpEvApp tm) e = liftM (App e) (dsEvTerm tm)
--------------------------------------
dsTcEvBinds_s :: [TcEvBinds] -> DsM [CoreBind]
dsTcEvBinds_s [] = return []
dsTcEvBinds_s (b:rest) = ASSERT( null rest ) -- Zonker ensures null
dsTcEvBinds b
dsTcEvBinds :: TcEvBinds -> DsM [CoreBind]
dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds" -- Zonker has got rid of this
dsTcEvBinds (EvBinds bs) = dsEvBinds bs
......@@ -839,10 +844,11 @@ dsTcEvBinds (EvBinds bs) = dsEvBinds bs
dsEvBinds :: Bag EvBind -> DsM [CoreBind]
dsEvBinds bs = mapM ds_scc (sccEvBinds bs)
where
ds_scc (AcyclicSCC (EvBind v r)) = liftM (NonRec v) (dsEvTerm r)
ds_scc (CyclicSCC bs) = liftM Rec (mapM ds_pair bs)
ds_scc (AcyclicSCC (EvBind { eb_lhs = v, eb_rhs = r }))
= liftM (NonRec v) (dsEvTerm r)
ds_scc (CyclicSCC bs) = liftM Rec (mapM ds_pair bs)
ds_pair (EvBind v r) = liftM ((,) v) (dsEvTerm r)
ds_pair (EvBind { eb_lhs = v, eb_rhs = r }) = liftM ((,) v) (dsEvTerm r)
sccEvBinds :: Bag EvBind -> [SCC EvBind]
sccEvBinds bs = stronglyConnCompFromEdgedVertices edges
......@@ -851,7 +857,8 @@ sccEvBinds bs = stronglyConnCompFromEdgedVertices edges
edges = foldrBag ((:) . mk_node) [] bs
mk_node :: EvBind -> (EvBind, EvVar, [EvVar])
mk_node b@(EvBind var term) = (b, var, varSetElems (evVarsOfTerm term))
mk_node b@(EvBind { eb_lhs = var, eb_rhs = term })
= (b, var, varSetElems (evVarsOfTerm term))
---------------------------------------
......@@ -974,7 +981,7 @@ ds_tc_coercion subst tc_co
ds_co_binds eb@(TcEvBinds {}) = pprPanic "ds_co_binds" (ppr eb)
ds_scc :: CvSubst -> SCC EvBind -> CvSubst
ds_scc subst (AcyclicSCC (EvBind v ev_term))
ds_scc subst (AcyclicSCC (EvBind { eb_lhs = v, eb_rhs = ev_term }))
= extendCvSubstAndInScope subst v (ds_co_term subst ev_term)
ds_scc _ (CyclicSCC other) = pprPanic "ds_scc:cyclic" (ppr other $$ ppr tc_co)
......
......@@ -142,7 +142,7 @@ dsStrictBind (AbsBinds { abs_tvs = [], abs_ev_vars = []
bind_export export b = bindNonRec (abe_poly export) (Var (abe_mono export)) b
; body2 <- foldlBagM (\body lbind -> dsStrictBind (unLoc lbind) body)
body1 lbinds
; ds_binds <- dsTcEvBinds ev_binds
; ds_binds <- dsTcEvBinds_s ev_binds
; return (mkCoreLets ds_binds body2) }
dsStrictBind (FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn
......
......@@ -191,8 +191,13 @@ data HsBindLR idL idR
-- to have the right type
abs_exports :: [ABExport idL],
abs_ev_binds :: TcEvBinds, -- ^ Evidence bindings
abs_binds :: LHsBinds idL -- ^ Typechecked user bindings
-- | Evidence bindings
-- Why a list? See TcInstDcls
-- Note [Typechecking plan for instance declarations]
abs_ev_binds :: [TcEvBinds],
-- | Typechecked user bindings
abs_binds :: LHsBinds idL
}
| PatSynBind (PatSynBind idL idR)
......
......@@ -239,7 +239,7 @@ buildClass tycon_name tvs roles sc_theta fds at_items sig_stuff mindef tc_isrec
-- Make selectors for the superclasses
; sc_sel_names <- mapM (newImplicitBinder tycon_name . mkSuperDictSelOcc)
[1..length sc_theta]
(takeList sc_theta [fIRST_TAG..])
; let sc_sel_ids = [ mkDictSelId sc_name rec_clas
| sc_name <- sc_sel_names]
-- We number off the Dict superclass selectors, 1, 2, 3 etc so that we
......
......@@ -114,7 +114,7 @@ data IfaceDecl
-- the tycon)
ifFamFlav :: IfaceFamTyConFlav }
| IfaceClass { ifCtxt :: IfaceContext, -- Context...
| IfaceClass { ifCtxt :: IfaceContext, -- Superclasses
ifName :: IfaceTopBndr, -- Name of the class TyCon
ifTyVars :: [IfaceTvBndr], -- Type variables
ifRoles :: [Role], -- Roles
......
......@@ -467,6 +467,7 @@ data WarningFlag =
-- See Note [Updating flag description in the User's Guide]
Opt_WarnDuplicateExports
| Opt_WarnDuplicateConstraints
| Opt_WarnRedundantConstraints
| Opt_WarnHiShadows
| Opt_WarnImplicitPrelude
| Opt_WarnIncompletePatterns
......@@ -2825,7 +2826,9 @@ fWarningFlags = [
flagSpec "warn-dodgy-imports" Opt_WarnDodgyImports,
flagSpec "warn-empty-enumerations" Opt_WarnEmptyEnumerations,
flagSpec "warn-context-quantification" Opt_WarnContextQuantification,
flagSpec "warn-duplicate-constraints" Opt_WarnDuplicateConstraints,
flagSpec' "warn-duplicate-constraints" Opt_WarnDuplicateConstraints
(\_ -> deprecate "it is subsumed by -fwarn-redundant-constraints"),
flagSpec "warn-redundant-constraints" Opt_WarnRedundantConstraints,
flagSpec "warn-duplicate-exports" Opt_WarnDuplicateExports,
flagSpec "warn-hi-shadowing" Opt_WarnHiShadows,
flagSpec "warn-implicit-prelude" Opt_WarnImplicitPrelude,
......@@ -3317,7 +3320,7 @@ standardWarnings -- see Note [Documenting warning flags]
Opt_WarnPartialTypeSignatures,
Opt_WarnUnrecognisedPragmas,
Opt_WarnPointlessPragmas,
Opt_WarnDuplicateConstraints,
Opt_WarnRedundantConstraints,
Opt_WarnDuplicateExports,
Opt_WarnOverflowedLiterals,
Opt_WarnEmptyEnumerations,
......
......@@ -11,6 +11,7 @@ The @Inst@ type: dictionaries or method instances
module Inst (
deeplySkolemise, deeplyInstantiate,
instCall, instDFunType, instStupidTheta,
newWanted, newWanteds,
emitWanted, emitWanteds,
newOverloadedLit, mkOverLit,
......@@ -62,11 +63,22 @@ import Data.Maybe( isJust )
{-
************************************************************************
* *
Emitting constraints
Creating and emittind constraints
* *
************************************************************************
-}
newWanted :: CtOrigin -> PredType -> TcM CtEvidence
newWanted orig pty
= do loc <- getCtLoc orig
v <- newEvVar pty
return $ CtWanted { ctev_evar = v
, ctev_pred = pty
, ctev_loc = loc }
newWanteds :: CtOrigin -> ThetaType -> TcM [CtEvidence]
newWanteds orig = mapM (newWanted orig)
emitWanteds :: CtOrigin -> TcThetaType -> TcM [EvVar]
emitWanteds origin theta = mapM (emitWanted origin) theta
......@@ -75,7 +87,7 @@ emitWanted origin pred
= do { loc <- getCtLoc origin
; ev <- newEvVar pred
; emitSimple $ mkNonCanonical $
CtWanted { ctev_pred = pred, ctev_evar = ev, ctev_loc = loc }
CtWanted { ctev_pred = pred, ctev_evar = ev, ctev_loc = loc }
; return ev }
newMethodFromName :: CtOrigin -> Name -> TcRhoType -> TcM (HsExpr TcId)
......@@ -634,3 +646,5 @@ tyVarsOfImplic (Implic { ic_skols = skols
tyVarsOfBag :: (a -> TyVarSet) -> Bag a -> TyVarSet
tyVarsOfBag tvs_of = foldrBag (unionVarSet . tvs_of) emptyVarSet
......@@ -200,7 +200,7 @@ tcHsBootSigs (ValBindsOut binds sigs)
where
tc_boot_sig (TypeSig lnames ty _) = mapM f lnames
where
f (L _ name) = do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty
f (L _ name) = do { sigma_ty <- tcHsSigType (FunSigCtxt name True) ty
; return (mkVanillaGlobal name sigma_ty) }
-- Notice that we make GlobalIds, not LocalIds
tc_boot_sig s = pprPanic "tcHsBootSigs/tc_boot_sig" (ppr s)
......@@ -552,7 +552,8 @@ tcPolyNoGen rec_tc prag_fn tc_sig_fn bind_list
------------------
tcPolyCheck :: RecFlag -- Whether it's recursive after breaking
-- dependencies based on type signatures
-> PragFun -> TcSigInfo
-> PragFun
-> TcSigInfo
-> LHsBind Name
-> TcM (LHsBinds TcId, [TcId], TopLevelFlag)
-- There is just one binding,
......@@ -561,11 +562,13 @@ tcPolyCheck :: RecFlag -- Whether it's recursive after breaking
tcPolyCheck rec_tc prag_fn
sig@(TcSigInfo { sig_id = poly_id, sig_tvs = tvs_w_scoped
, sig_nwcs = sig_nwcs, sig_theta = theta
, sig_tau = tau, sig_loc = loc })
, sig_tau = tau, sig_loc = loc
, sig_warn_redundant = warn_redundant })
bind
= ASSERT( null sig_nwcs ) -- We should be in tcPolyInfer if there are wildcards
do { ev_vars <- newEvVars theta
; let skol_info = SigSkol (FunSigCtxt (idName poly_id)) (mkPhiTy theta tau)
; let ctxt = FunSigCtxt (idName poly_id) warn_redundant
skol_info = SigSkol ctxt (mkPhiTy theta tau)
prag_sigs = prag_fn (idName poly_id)
tvs = map snd tvs_w_scoped
; (ev_binds, (binds', [mono_info]))
......@@ -583,7 +586,7 @@ tcPolyCheck rec_tc prag_fn
, abe_prags = SpecPrags spec_prags }
abs_bind = L loc $ AbsBinds
{ abs_tvs = tvs
, abs_ev_vars = ev_vars, abs_ev_binds = ev_binds
, abs_ev_vars = ev_vars, abs_ev_binds = [ev_binds]
, abs_exports = [export], abs_binds = binds' }
closed | isEmptyVarSet (tyVarsOfType (idType poly_id)) = TopLevel
| otherwise = NotTopLevel
......@@ -602,9 +605,8 @@ tcPolyInfer
-> [LHsBind Name]
-> TcM (LHsBinds TcId, [TcId], TopLevelFlag)
tcPolyInfer rec_tc prag_fn tc_sig_fn mono closed bind_list
= do { (((binds', mono_infos), tclvl), wanted)
<- captureConstraints $
captureTcLevel $
= do { ((binds', mono_infos), tclvl, wanted)
<- pushLevelAndCaptureConstraints $
tcMonoBinds rec_tc tc_sig_fn LetLclBndr bind_list
; let name_taus = [(name, idType mono_id) | (name, _, mono_id) <- mono_infos]
......@@ -622,7 +624,7 @@ tcPolyInfer rec_tc prag_fn tc_sig_fn mono closed bind_list
| otherwise = NotTopLevel
abs_bind = L loc $
AbsBinds { abs_tvs = qtvs
, abs_ev_vars = givens, abs_ev_binds = ev_binds
, abs_ev_vars = givens, abs_ev_binds = [ev_binds]
, abs_exports = exports, abs_binds = binds' }
; traceTc "Binding:" (ppr final_closed $$
......@@ -922,7 +924,7 @@ tcSpec poly_id prag@(SpecSig fun_name hs_tys inl)
where
name = idName poly_id
poly_ty = idType poly_id
sig_ctxt = FunSigCtxt name
sig_ctxt = FunSigCtxt name True
spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag)
tcSpec _ prag = pprPanic "tcSpec" (ppr prag)
......@@ -1395,9 +1397,13 @@ tcTySig (L _ (IdSig id))
; return ([sig], []) }
tcTySig (L loc (TypeSig names@(L _ name1 : _) hs_ty wcs))
= setSrcSpan loc $
pushTcLevelM $
do { nwc_tvs <- mapM newWildcardVarMetaKind wcs -- Generate fresh meta vars for the wildcards
; sigma_ty <- tcExtendTyVarEnv nwc_tvs $ tcHsSigType (FunSigCtxt name1) hs_ty
pushTcLevelM_ $ -- When instantiating the signature, do so "one level in"
-- so that they can be unified under the forall
do { -- Generate fresh meta vars for the wildcards
; nwc_tvs <- mapM newWildcardVarMetaKind wcs
; sigma_ty <- tcExtendTyVarEnv nwc_tvs $ tcHsSigType (FunSigCtxt name1 False) hs_ty
; sigs <- mapM (instTcTySig hs_ty sigma_ty (extra_cts hs_ty) (zip wcs nwc_tvs))
(map unLoc names)
; return (sigs, nwc_tvs) }
......@@ -1408,7 +1414,7 @@ tcTySig (L loc (TypeSig names@(L _ name1 : _) hs_ty wcs))
tcTySig (L loc (PatSynSig (L _ name) (_, qtvs) prov req ty))
= setSrcSpan loc $
do { traceTc "tcTySig {" $ ppr name $$ ppr qtvs $$ ppr prov $$ ppr req $$ ppr ty
; let ctxt = FunSigCtxt name
; let ctxt = FunSigCtxt name False
; tcHsTyVarBndrs qtvs $ \ qtvs' -> do
{ ty' <- tcHsSigType ctxt ty
; req' <- tcHsContext req
......@@ -1440,12 +1446,18 @@ instTcTySigFromId id
, sig_nwcs = []
, sig_theta = theta, sig_tau = tau
, sig_extra_cts = Nothing
, sig_partial = False }) }
, sig_partial = False
, sig_warn_redundant = False
-- Do not report redundant constraints for
-- instance methods and record selectors
}) }
instTcTySig :: LHsType Name -> TcType -- HsType and corresponding TcType
-> Maybe SrcSpan -- Just loc <=> an extra-constraints
-- wildcard is present at location loc.
-> [(Name, TcTyVar)] -> Name -> TcM TcSigInfo
-- wildcard is present at location loc.
-> [(Name, TcTyVar)] -- Named wildcards
-> Name -- Name of the function
-> TcM TcSigInfo
instTcTySig hs_ty@(L loc _) sigma_ty extra_cts nwcs name
= do { (inst_tvs, theta, tau) <- tcInstType tcInstSigTyVars sigma_ty
; return (TcSigInfo { sig_id = mkLocalId name sigma_ty
......@@ -1454,7 +1466,9 @@ instTcTySig hs_ty@(L loc _) sigma_ty extra_cts nwcs name
, sig_nwcs = nwcs
, sig_theta = theta, sig_tau = tau
, sig_extra_cts = extra_cts
, sig_partial = isJust extra_cts || not (null nwcs) }) }
, sig_partial = isJust extra_cts || not (null nwcs)
, sig_warn_redundant = True
}) }
-------------------------------
data GeneralisationPlan
......@@ -1649,6 +1663,6 @@ typeSigCtxt _ (TcPatSynInfo _)
typeSigCtxt name (TcSigInfo { sig_id = _id, sig_tvs = tvs
, sig_theta = theta, sig_tau = tau
, sig_extra_cts = extra_cts })
= sep [ text "In" <+> pprUserTypeCtxt (FunSigCtxt name) <> colon
= sep [ text "In" <+> pprUserTypeCtxt (FunSigCtxt name False) <> colon
, nest 2 (pprSigmaTypeExtraCts (isJust extra_cts)
(mkSigmaTy (map snd tvs) theta tau)) ]
......@@ -27,7 +27,6 @@ import DataCon ( dataConName )
import Name( isSystemName, nameOccName )
import OccName( OccName )
import Outputable
import Control.Monad
import DynFlags( DynFlags )
import VarSet
import RdrName
......@@ -189,7 +188,7 @@ canTuple :: CtEvidence -> [PredType] -> TcS (StopOrContinue Ct)
canTuple ev preds
| CtWanted { ctev_evar = evar, ctev_loc = loc } <- ev
= do { new_evars <- mapM (newWantedEvVar loc) preds
; setEvBind evar (EvTupleMk (map (ctEvTerm . fst) new_evars))
; setWantedEvBind evar (EvTupleMk (map (ctEvTerm . fst) new_evars))
; emitWorkNC (freshGoals new_evars)
-- Note the "NC": these are fresh goals, not necessarily canonical
; stopWith ev "Decomposed tuple constraint" }
......@@ -485,9 +484,8 @@ can_eq_nc' _rdr_env _envs ev eq_rel ty1 ps_ty1 (TyVarTy tv2) _
-- Literals
can_eq_nc' _rdr_env _envs ev eq_rel ty1@(LitTy l1) _ (LitTy l2) _
| l1 == l2
= do { when (isWanted ev) $
setEvBind (ctev_evar ev) (EvCoercion $
mkTcReflCo (eqRelRole eq_rel) ty1)
= do { setEvBindIfWanted ev (EvCoercion $
mkTcReflCo (eqRelRole eq_rel) ty1)
; stopWith ev "Equal LitTy" }
-- Decomposable type constructor applications
......@@ -523,7 +521,7 @@ can_eq_nc' _rdr_env _envs ev eq_rel s1@(ForAllTy {}) _ s2@(ForAllTy {}) _
do { traceTcS "Creating implication for polytype equality" $ ppr ev
; ev_term <- deferTcSForAllEq (eqRelRole eq_rel)
loc (tvs1,body1) (tvs2,body2)
; setEvBind orig_ev ev_term
; setWantedEvBind orig_ev ev_term
; stopWith ev "Deferred polytype equality" } }
| otherwise
= do { traceTcS "Ommitting decomposition of given polytype equality" $
......@@ -704,7 +702,7 @@ try_decompose_nom_app ev ty1 ty2
= do { ev_s <- newWantedEvVarNC loc (mkTcEqPred s1 s2)
; co_t <- unifyWanted loc Nominal t1 t2
; let co = mkTcAppCo (ctEvCoercion ev_s) co_t
; setEvBind evar (EvCoercion co)
; setWantedEvBind evar (EvCoercion co)
; canEqNC ev_s NomEq s1 s2 }
| CtGiven { ctev_evtm = ev_tm, ctev_loc = loc } <- ev
= do { let co = evTermCoercion ev_tm
......@@ -767,7 +765,7 @@ canDecomposableTyConAppOK ev eq_rel tc tys1 tys2
CtWanted { ctev_evar = evar, ctev_loc = loc }
-> do { cos <- zipWith3M (unifyWanted loc) tc_roles tys1 tys2
; setEvBind evar (EvCoercion (mkTcTyConAppCo role tc cos)) }
; setWantedEvBind evar (EvCoercion (mkTcTyConAppCo role tc cos)) }
CtGiven { ctev_evtm = ev_tm, ctev_loc = loc }
-> do { let ev_co = evTermCoercion ev_tm
......@@ -1063,9 +1061,8 @@ canEqTyVarTyVar :: CtEvidence -- tv1 ~ orhs (or orhs ~ tv1, if swapped
-- See Note [Canonical orientation for tyvar/tyvar equality constraints]
canEqTyVarTyVar ev eq_rel swapped tv1 tv2 co2
| tv1 == tv2
= do { when (isWanted ev) $
ASSERT( tcCoercionRole co2 == eqRelRole eq_rel )
setEvBind (ctev_evar ev) (EvCoercion (maybeSym swapped co2))
= do { ASSERT( tcCoercionRole co2 == eqRelRole eq_rel )
setEvBindIfWanted ev (EvCoercion (maybeSym swapped co2))
; stopWith ev "Equal tyvars" }
| incompat_kind = incompat
......@@ -1151,9 +1148,8 @@ canEqReflexive :: CtEvidence -- ty ~ ty
-> TcType -- ty
-> TcS (StopOrContinue Ct) -- always Stop
canEqReflexive ev eq_rel ty
= do { when (isWanted ev) $
setEvBind (ctev_evar ev) (EvCoercion $
mkTcReflCo (eqRelRole eq_rel) ty)
= do { setEvBindIfWanted ev (EvCoercion $
mkTcReflCo (eqRelRole eq_rel) ty)
; stopWith ev "Solved by reflexivity" }
incompatibleKind :: CtEvidence -- t1~t2
......@@ -1485,8 +1481,8 @@ rewriteEvidence ev@(CtGiven { ctev_evtm = old_tm , ctev_loc = loc }) new_pred co
rewriteEvidence ev@(CtWanted { ctev_evar = evar, ctev_loc = loc }) new_pred co
= do { (new_ev, freshness) <- newWantedEvVar loc new_pred
; MASSERT( tcCoercionRole co == ctEvRole ev )
; setEvBind evar (mkEvCast (ctEvTerm new_ev)
(tcDowngradeRole Representational (ctEvRole ev) co))
; setWantedEvBind evar (mkEvCast (ctEvTerm new_ev)
(tcDowngradeRole Representational (ctEvRole ev) co))
; case freshness of
Fresh -> continueWith new_ev
Cached -> stopWith ev "Cached wanted" }
......@@ -1542,7 +1538,7 @@ rewriteEqEvidence old_ev eq_rel swapped nlhs nrhs lhs_co rhs_co
mkTcSymCo lhs_co
`mkTcTransCo` ctEvCoercion new_evar
`mkTcTransCo` rhs_co
; setEvBind evar (EvCoercion co)
; setWantedEvBind evar (EvCoercion co)
; traceTcS "rewriteEqEvidence" (vcat [ppr old_ev, ppr nlhs, ppr nrhs, ppr co])
; return (ContinueWith new_evar) }
......
......@@ -9,7 +9,7 @@ Typechecking class declarations
{-# LANGUAGE CPP #-}
module TcClassDcl ( tcClassSigs, tcClassDecl2,
findMethodBind, instantiateMethod, tcInstanceMethodBody,
findMethodBind, instantiateMethod,
tcClassMinimalDef,
HsSigFun, mkHsSigFun, lookupHsSig, emptyHsSigs,
tcMkDeclCtxt, tcAddDeclCtxt, badMethodErr
......@@ -20,7 +20,7 @@ module TcClassDcl ( tcClassSigs, tcClassDecl2,
import HsSyn
import TcEnv
import TcPat( addInlinePrags )
import TcEvidence( HsWrapper, idHsWrapper )
import TcEvidence( idHsWrapper )
import TcBinds
import TcUnify
import TcHsType
......@@ -156,28 +156,35 @@ tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
-- dm1 = \d -> case ds d of (a,b,c) -> a
-- And since ds is big, it doesn't get inlined, so we don't get good
-- default methods. Better to make separate AbsBinds for each
; let
(tyvars, _, _, op_items) = classBigSig clas
; let (tyvars, _, _, op_items) = classBigSig clas
prag_fn = mkPragFun sigs default_binds
sig_fn = mkHsSigFun sigs
clas_tyvars = snd (tcSuperSkolTyVars tyvars)
pred = mkClassPred clas (mkTyVarTys clas_tyvars)
; this_dict <- newEvVar pred
; traceTc "TIM2" (ppr sigs)
; let tc_dm = tcDefMeth clas clas_tyvars
this_dict default_binds
sig_fn prag_fn
; let tc_item (sel_id, dm_info)
= case dm_info of
DefMeth dm_name -> tc_dm sel_id dm_name False
GenDefMeth dm_name -> tc_dm sel_id dm_name True
-- For GenDefMeth, warn if the user specifies a signature
-- with redundant constraints; but not for DefMeth, where
-- the default method may well be 'error' or something
NoDefMeth -> do { mapM_ (addLocM (badDmPrag sel_id))
(prag_fn (idName sel_id))
; return emptyBag }
tc_dm = tcDefMeth clas clas_tyvars this_dict
default_binds sig_fn prag_fn
; dm_binds <- tcExtendTyVarEnv clas_tyvars $
mapM tc_dm op_items
mapM tc_item op_items
; return (unionManyBags dm_binds) }
tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d)
tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds Name
-> HsSigFun -> PragFun -> ClassOpItem
-> HsSigFun -> PragFun -> Id -> Name -> Bool
-> TcM (LHsBinds TcId)
-- Generate code for polymorphic default methods only (hence DefMeth)
-- (Generic default methods have turned into instance decls by now.)
......@@ -185,78 +192,62 @@ tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds Name
-- default method for every class op, regardless of whether or not
-- the programmer supplied an explicit default decl for the class.
-- (If necessary we can fix that, but we don't have a convenient Id to hand.)
tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn (sel_id, dm_info)
= case dm_info of
NoDefMeth -> do { mapM_ (addLocM (badDmPrag sel_id)) prags
; return emptyBag }
DefMeth dm_name -> tc_dm dm_name
GenDefMeth dm_name -> tc_dm dm_name
where
sel_name = idName sel_id
prags = prag_fn sel_name
(dm_bind,bndr_loc) = findMethodBind sel_name binds_in
`orElse` pprPanic "tcDefMeth" (ppr sel_id)
-- Eg. class C a where
-- op :: forall b. Eq b => a -> [b] -> a
-- gen_op :: a -> a
-- generic gen_op :: D a => a -> a
-- The "local_dm_ty" is precisely the type in the above
-- type signatures, ie with no "forall a. C a =>" prefix
tc_dm dm_name
= do { dm_id <- tcLookupId dm_name
; local_dm_name <- setSrcSpan bndr_loc (newLocalName sel_name)
-- Base the local_dm_name on the selector name, because
-- type errors from tcInstanceMethodBody come from here
; dm_id_w_inline <- addInlinePrags dm_id prags
; spec_prags <- tcSpecPrags dm_id prags
; let local_dm_ty = instantiateMethod clas dm_id (mkTyVarTys tyvars)
hs_ty = lookupHsSig hs_sig_fn sel_name
`orElse` pprPanic "tc_dm" (ppr sel_name)
; local_dm_sig <- instTcTySig hs_ty local_dm_ty Nothing [] local_dm_name
; warnTc (not (null spec_prags))
(ptext (sLit "Ignoring SPECIALISE pragmas on default method")
<+> quotes (ppr sel_name))
; tc_bind <- tcInstanceMethodBody (ClsSkol clas) tyvars [this_dict]
dm_id_w_inline local_dm_sig idHsWrapper
IsDefaultMethod dm_bind
; return (unitBag tc_bind) }
---------------
tcInstanceMethodBody :: SkolemInfo -> [TcTyVar] -> [EvVar]
-> Id -> TcSigInfo
-> HsWrapper -- See Note [Instance method signatures] in TcInstDcls
-> TcSpecPrags -> LHsBind Name
-> TcM (LHsBind Id)
tcInstanceMethodBody skol_info tyvars dfun_ev_vars
meth_id local_meth_sig wrapper
specs (L loc bind)
= do { let local_meth_id = case local_meth_sig of
TcSigInfo{ sig_id = meth_id } -> meth_id
_ -> pprPanic "tcInstanceMethodBody" (ppr local_meth_sig)
lm_bind = L loc (bind { fun_id = L loc (idName local_meth_id) })
tcDefMeth clas tyvars this_dict binds_in
hs_sig_fn prag_fn sel_id dm_name warn_redundant
| Just (L bind_loc dm_bind, bndr_loc) <- findMethodBind sel_name binds_in
-- First look up the default method -- it should be there!
= do { global_dm_id <- tcLookupId dm_name
; global_dm_id <- addInlinePrags global_dm_id prags
; local_dm_name <- setSrcSpan bndr_loc (newLocalName sel_name)
-- Base the local_dm_name on the selector name, because
-- type errors from tcInstanceMethodBody come from here
; spec_prags <- tcSpecPrags global_dm_id prags
; warnTc (not (null spec_prags))
(ptext (sLit "Ignoring SPECIALISE pragmas on default method")
<+> quotes (ppr sel_name))
; let hs_ty = lookupHsSig hs_sig_fn sel_name
`orElse` pprPanic "tc_dm" (ppr sel_name)
-- We need the HsType so that we can bring the right
-- type variables into scope
--
-- Eg. class C a where
-- op :: forall b. Eq b => a -> [b] -> a
-- gen_op :: a -> a
-- generic gen_op :: D a => a -> a
-- The "local_dm_ty" is precisely the type in the above
-- type signatures, ie with no "forall a. C a =>" prefix
local_dm_ty = instantiateMethod clas global_dm_id (mkTyVarTys tyvars)
lm_bind = dm_bind { fun_id = L bind_loc local_dm_name }
-- Substitute the local_meth_name for the binder
-- NB: the binding is always a FunBind
; (ev_binds, (tc_bind, _, _))
<- checkConstraints skol_info tyvars dfun_ev_vars $
tcPolyCheck NonRecursive no_prag_fn local_meth_sig lm_bind
; let export = ABE { abe_wrap = wrapper, abe_poly = meth_id
, abe_mono = local_meth_id, abe_prags = specs }
; local_dm_sig <- instTcTySig hs_ty local_dm_ty Nothing [] local_dm_name
; let local_dm_sig' = local_dm_sig { sig_warn_redundant = warn_redundant }
; (ev_binds, (tc_bind, _, _))
<- checkConstraints (ClsSkol clas) tyvars [this_dict] $
tcPolyCheck NonRecursive no_prag_fn local_dm_sig'
(L bind_loc lm_bind)