diff options
Diffstat (limited to 'compiler')
35 files changed, 1292 insertions, 785 deletions
diff --git a/compiler/basicTypes/BasicTypes.hs b/compiler/basicTypes/BasicTypes.hs index 99e6de6454..f4b7e80e51 100644 --- a/compiler/basicTypes/BasicTypes.hs +++ b/compiler/basicTypes/BasicTypes.hs @@ -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 {- diff --git a/compiler/deSugar/DsArrows.hs b/compiler/deSugar/DsArrows.hs index 1a73210571..8f5b30e73d 100644 --- a/compiler/deSugar/DsArrows.hs +++ b/compiler/deSugar/DsArrows.hs @@ -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] diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs index e79c88c250..3e91806c4c 100644 --- a/compiler/deSugar/DsBinds.hs +++ b/compiler/deSugar/DsBinds.hs @@ -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) diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs index d252d91894..dbc9a76664 100644 --- a/compiler/deSugar/DsExpr.hs +++ b/compiler/deSugar/DsExpr.hs @@ -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 diff --git a/compiler/hsSyn/HsBinds.hs b/compiler/hsSyn/HsBinds.hs index ef14fab248..82d014b642 100644 --- a/compiler/hsSyn/HsBinds.hs +++ b/compiler/hsSyn/HsBinds.hs @@ -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) diff --git a/compiler/iface/BuildTyCl.hs b/compiler/iface/BuildTyCl.hs index 33be51ff7f..6e14700cfa 100644 --- a/compiler/iface/BuildTyCl.hs +++ b/compiler/iface/BuildTyCl.hs @@ -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 diff --git a/compiler/iface/IfaceSyn.hs b/compiler/iface/IfaceSyn.hs index 7cd875fd2c..0b17d61b07 100644 --- a/compiler/iface/IfaceSyn.hs +++ b/compiler/iface/IfaceSyn.hs @@ -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 diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 8857925f9e..b8c2bb1a2c 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -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, diff --git a/compiler/typecheck/Inst.hs b/compiler/typecheck/Inst.hs index d38f28131f..6b08822824 100644 --- a/compiler/typecheck/Inst.hs +++ b/compiler/typecheck/Inst.hs @@ -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 + + diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs index b4bb65d074..7d66d16776 100644 --- a/compiler/typecheck/TcBinds.hs +++ b/compiler/typecheck/TcBinds.hs @@ -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)) ] diff --git a/compiler/typecheck/TcCanonical.hs b/compiler/typecheck/TcCanonical.hs index a5b0d99b5b..65ebfd9195 100644 --- a/compiler/typecheck/TcCanonical.hs +++ b/compiler/typecheck/TcCanonical.hs @@ -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) } diff --git a/compiler/typecheck/TcClassDcl.hs b/compiler/typecheck/TcClassDcl.hs index 719c2f3eb5..e113682112 100644 --- a/compiler/typecheck/TcClassDcl.hs +++ b/compiler/typecheck/TcClassDcl.hs @@ -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) + + ; let export = ABE { abe_poly = global_dm_id + , abe_mono = sig_id local_dm_sig' + , abe_wrap = idHsWrapper + , abe_prags = IsDefaultMethod } full_bind = AbsBinds { abs_tvs = tyvars - , abs_ev_vars = dfun_ev_vars + , abs_ev_vars = [this_dict] , abs_exports = [export] - , abs_ev_binds = ev_binds + , abs_ev_binds = [ev_binds] , abs_binds = tc_bind } - ; return (L loc full_bind) } + ; return (unitBag (L bind_loc full_bind)) } + + | otherwise = pprPanic "tcDefMeth" (ppr sel_id) where + sel_name = idName sel_id + prags = prag_fn sel_name no_prag_fn _ = [] -- No pragmas for local_meth_id; -- they are all for meth_id diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs index 960b03f7fa..10191aee55 100644 --- a/compiler/typecheck/TcDeriv.hs +++ b/compiler/typecheck/TcDeriv.hs @@ -1857,7 +1857,7 @@ simplifyDeriv pred tvs theta skol_set = mkVarSet tvs_skols doc = ptext (sLit "deriving") <+> parens (ppr pred) - ; wanted <- mapM (\(PredOrigin t o) -> newSimpleWanted o (substTy skol_subst t)) theta + ; wanted <- mapM (\(PredOrigin t o) -> newWanted o (substTy skol_subst t)) theta ; traceTc "simplifyDeriv" $ vcat [ pprTvBndrs tvs $$ ppr theta $$ ppr wanted, doc ] diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs index 23cc0481f1..d9b6fc7a47 100644 --- a/compiler/typecheck/TcErrors.hs +++ b/compiler/typecheck/TcErrors.hs @@ -42,6 +42,7 @@ import DynFlags import StaticFlags ( opt_PprStyle_Debug ) import ListSetOps ( equivClasses ) +import Control.Monad ( when ) import Data.Maybe import Data.List ( partition, mapAccumL, nub, sortBy ) @@ -133,6 +134,7 @@ report_unsolved mb_binds_var defer_errors expr_holes type_holes wanted = return () | otherwise = do { traceTc "reportUnsolved (before unflattening)" (ppr wanted) + ; warn_redundant <- woptM Opt_WarnRedundantConstraints ; env0 <- tcInitTidyEnv @@ -146,6 +148,7 @@ report_unsolved mb_binds_var defer_errors expr_holes type_holes wanted , cec_expr_holes = expr_holes , cec_type_holes = type_holes , cec_suppress = False -- See Note [Suppressing error messages] + , cec_warn_redundant = warn_redundant , cec_binds = mb_binds_var } ; traceTc "reportUnsolved (after unflattening):" $ @@ -181,6 +184,8 @@ data ReportErrCtxt , cec_expr_holes :: HoleChoice -- Holes in expressions , cec_type_holes :: HoleChoice -- Holes in types + , cec_warn_redundant :: Bool -- True <=> -fwarn-redundant-constraints + , cec_suppress :: Bool -- True <=> More important errors have occurred, -- so create bindings if need be, but -- don't issue any more errors/warnings @@ -204,15 +209,20 @@ Specifically (see reportWanteds) reportImplic :: ReportErrCtxt -> Implication -> TcM () reportImplic ctxt implic@(Implic { ic_skols = tvs, ic_given = given , ic_wanted = wanted, ic_binds = evb - , ic_insol = ic_insoluble, ic_info = info }) + , ic_status = status, ic_info = info + , ic_env = tcl_env }) | BracketSkol <- info - , not ic_insoluble -- For Template Haskell brackets report only - = return () -- definite errors. The whole thing will be re-checked + , not (isInsolubleStatus status) + = return () -- For Template Haskell brackets report only + -- definite errors. The whole thing will be re-checked -- later when we plug it in, and meanwhile there may -- certainly be un-satisfied constraints | otherwise - = reportWanteds ctxt' wanted + = do { reportWanteds ctxt' wanted + ; traceTc "reportImplic" (ppr implic) + ; when (cec_warn_redundant ctxt) $ + warnRedundantConstraints ctxt' tcl_env info' dead_givens } where (env1, tvs') = mapAccumL tidyTyVarBndr (cec_tidy ctxt) tvs (env2, info') = tidySkolemInfo env1 info @@ -224,40 +234,65 @@ reportImplic ctxt implic@(Implic { ic_skols = tvs, ic_given = given , cec_binds = case cec_binds ctxt of Nothing -> Nothing Just {} -> Just evb } + dead_givens = case status of + IC_Solved { ics_dead = dead } -> dead + _ -> [] + +warnRedundantConstraints :: ReportErrCtxt -> TcLclEnv -> SkolemInfo -> [EvVar] -> TcM () +warnRedundantConstraints ctxt env info ev_vars + | null ev_vars + = return () + + | SigSkol {} <- info + = setLclEnv env $ -- We want to add "In the type signature for f" + -- to the error context, which is a bit tiresome + addErrCtxt (ptext (sLit "In") <+> ppr info) $ + do { env <- getLclEnv + ; msg <- mkErrorMsg ctxt env doc + ; reportWarning msg } + + | otherwise -- But for InstSkol there already *is* a surrounding + -- "In the instance declaration for Eq [a]" context + -- and we don't want to say it twice. Seems a bit ad-hoc + = do { msg <- mkErrorMsg ctxt env doc + ; reportWarning msg } + where + doc = ptext (sLit "Redundant constraint") <> plural ev_vars <> colon + <+> pprEvVarTheta ev_vars reportWanteds :: ReportErrCtxt -> WantedConstraints -> TcM () -reportWanteds ctxt wanted@(WC { wc_simple = simples, wc_insol = insols, wc_impl = implics }) - = do { reportSimples ctxt (mapBag (tidyCt env) insol_given) - ; reportSimples ctxt1 (mapBag (tidyCt env) insol_wanted) - ; reportSimples ctxt2 (mapBag (tidyCt env) simples) +reportWanteds ctxt (WC { wc_simple = simples, wc_insol = insols, wc_impl = implics }) + = do { ctxt1 <- reportSimples ctxt (mapBag (tidyCt env) insol_given) + ; ctxt2 <- reportSimples ctxt1 (mapBag (tidyCt env) insol_wanted) + + -- For the simple wanteds, suppress them if there are any + -- insolubles in the tree, to avoid unnecessary clutter + ; let ctxt2' = ctxt { cec_suppress = cec_suppress ctxt2 + || anyBag insolubleImplic implics } + ; _ <- reportSimples ctxt2' (mapBag (tidyCt env) simples) + -- All the Derived ones have been filtered out of simples -- 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 ctxt1) implics } -- NB ctxt1: don't suppress inner insolubles if there's only a - -- wanted insoluble here; but do suppress inner insolubles - -- if there's a given insoluble here (= inaccessible code) + -- *wanted* insoluble here; but do suppress inner insolubles + -- if there's a *given* insoluble here (= inaccessible code) where - (insol_given, insol_wanted) = partitionBag isGivenCt insols env = cec_tidy ctxt + (insol_given, insol_wanted) = partitionBag isGivenCt insols - -- See Note [Suppressing error messages] - suppress0 = cec_suppress ctxt - suppress1 = suppress0 || not (isEmptyBag insol_given) - suppress2 = suppress0 || insolubleWC wanted - ctxt1 = ctxt { cec_suppress = suppress1 } - ctxt2 = ctxt { cec_suppress = suppress2 } - -reportSimples :: ReportErrCtxt -> Cts -> TcM () +reportSimples :: ReportErrCtxt -> Cts -> TcM ReportErrCtxt reportSimples ctxt simples -- Here 'simples' includes insolble goals = traceTc "reportSimples" (vcat [ ptext (sLit "Simples =") <+> ppr simples , ptext (sLit "Suppress =") <+> ppr (cec_suppress ctxt)]) - >> tryReporters + >> tryReporters ctxt [ -- First deal with things that are utterly wrong -- Like Int ~ Bool (incl nullary TyCons) -- or Int ~ t a (AppTy on one side) - ("Utterly wrong", utterly_wrong, True, mkGroupReporter mkEqErr) + ("Utterly wrong (given)", utterly_wrong_given, True, mkGroupReporter mkEqErr) + , ("Utterly wrong (other)", utterly_wrong_other, True, mkGroupReporter mkEqErr) , ("Holes", is_hole, False, mkHoleReporter) -- Report equalities of form (a~ty). They are usually @@ -272,15 +307,19 @@ reportSimples ctxt simples -- Here 'simples' includes insolble goals , ("Irreds", is_irred, False, mkGroupReporter mkIrredErr) , ("Dicts", is_dict, False, mkGroupReporter mkDictErr) ] - panicReporter ctxt (bagToList simples) + (bagToList simples) -- TuplePreds should have been expanded away by the constraint -- simplifier, so they shouldn't show up at this point where - utterly_wrong, skolem_eq, is_hole, is_dict, + utterly_wrong_given, utterly_wrong_other, skolem_eq, is_hole, is_dict, is_equality, is_ip, is_irred :: Ct -> PredTree -> Bool - utterly_wrong _ (EqPred _ ty1 ty2) = isRigid ty1 && isRigid ty2 - utterly_wrong _ _ = False + utterly_wrong_given ct (EqPred _ ty1 ty2) + | isGivenCt ct = isRigid ty1 && isRigid ty2 + utterly_wrong_given _ _ = False + + utterly_wrong_other _ (EqPred _ ty1 ty2) = isRigid ty1 && isRigid ty2 + utterly_wrong_other _ _ = False is_hole ct _ = isHoleCt ct @@ -330,11 +369,6 @@ type ReporterSpec , Bool -- True <=> suppress subsequent reporters , Reporter) -- The reporter itself -panicReporter :: Reporter -panicReporter _ cts - | null cts = return () - | otherwise = pprPanic "reportSimples" (ppr cts) - mkSkolReporter :: Reporter -- Suppress duplicates with the same LHS mkSkolReporter ctxt cts @@ -418,7 +452,7 @@ addDeferredBinding ctxt err ct err_msg $$ text "(deferred type error)" -- Create the binding - ; addTcEvBind ev_binds_var ev_id (EvDelayedError pred err_fs) } + ; addTcEvBind ev_binds_var (mkWantedEvBind ev_id (EvDelayedError pred err_fs)) } | otherwise -- Do not set any evidence for Given/Derived = return () @@ -441,14 +475,18 @@ maybeAddDeferredBinding ctxt err ct | otherwise = return () -tryReporters :: [ReporterSpec] -> Reporter -> Reporter +tryReporters :: ReportErrCtxt -> [ReporterSpec] -> [Ct] -> TcM ReportErrCtxt -- Use the first reporter in the list whose predicate says True -tryReporters reporters deflt ctxt cts +tryReporters ctxt reporters cts = do { traceTc "tryReporters {" (ppr cts) - ; go ctxt reporters cts - ; traceTc "tryReporters }" empty } + ; ctxt' <- go ctxt reporters cts + ; traceTc "tryReporters }" empty + ; return ctxt' } where - go ctxt [] cts = deflt ctxt cts + go ctxt [] cts + | null cts = return ctxt + | otherwise = pprPanic "tryReporters" (ppr cts) + go ctxt ((str, pred, suppress_after, reporter) : rs) cts | null yeses = do { traceTc "tryReporters: no" (text str) ; go ctxt rs cts } @@ -487,10 +525,13 @@ pprWithArising (ct:cts) ppr_one ct' = hang (parens (pprType (ctPred ct'))) 2 (pprArisingAt (ctLoc ct')) -mkErrorMsg :: ReportErrCtxt -> Ct -> SDoc -> TcM ErrMsg -mkErrorMsg ctxt ct msg - = do { let tcl_env = ctLocEnv (ctLoc ct) - ; err_info <- mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env) +mkErrorMsgFromCt :: ReportErrCtxt -> Ct -> SDoc -> TcM ErrMsg +mkErrorMsgFromCt ctxt ct msg + = mkErrorMsg ctxt (ctLocEnv (ctLoc ct)) msg + +mkErrorMsg :: ReportErrCtxt -> TcLclEnv -> SDoc -> TcM ErrMsg +mkErrorMsg ctxt tcl_env msg + = do { err_info <- mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env) ; mkLongErrAt (RealSrcSpan (tcl_loc tcl_env)) msg err_info } type UserGiven = ([EvVar], SkolemInfo, Bool, RealSrcSpan) @@ -572,16 +613,16 @@ solve it. ************************************************************************ -* * +* * Irreducible predicate errors -* * +* * ************************************************************************ -} mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg mkIrredErr ctxt cts - = do { (ctxt, binds_msg) <- relevantBindings True ctxt ct1 - ; mkErrorMsg ctxt ct1 (msg $$ binds_msg) } + = do { (ctxt, binds_msg, _) <- relevantBindings True ctxt ct1 + ; mkErrorMsgFromCt ctxt ct1 (msg $$ binds_msg) } where (ct1:_) = cts orig = ctLocOrigin (ctLoc ct1) @@ -597,9 +638,9 @@ mkHoleError ctxt ct@(CHoleCan { cc_occ = occ, cc_hole = hole_sort }) 2 (ptext (sLit "with type:") <+> pprType (ctEvPred (ctEvidence ct))) , ppUnless (null tyvars_msg) (ptext (sLit "Where:") <+> vcat tyvars_msg) , pts_hint ] - ; (ctxt, binds_doc) <- relevantBindings False ctxt ct + ; (ctxt, binds_doc, _) <- relevantBindings False ctxt ct -- The 'False' means "don't filter the bindings"; see Trac #8191 - ; mkErrorMsg ctxt ct (msg $$ binds_doc) } + ; mkErrorMsgFromCt ctxt ct (msg $$ binds_doc) } where pts_hint | TypeHole <- hole_sort @@ -621,8 +662,8 @@ mkHoleError _ ct = pprPanic "mkHoleError" (ppr ct) ---------------- mkIPErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg mkIPErr ctxt cts - = do { (ctxt, bind_msg) <- relevantBindings True ctxt ct1 - ; mkErrorMsg ctxt ct1 (msg $$ bind_msg) } + = do { (ctxt, bind_msg, _) <- relevantBindings True ctxt ct1 + ; mkErrorMsgFromCt ctxt ct1 (msg $$ bind_msg) } where (ct1:_) = cts orig = ctLocOrigin (ctLoc ct1) @@ -671,7 +712,7 @@ mkEqErr1 :: ReportErrCtxt -> Ct -> TcM ErrMsg -- Wanted constraints only! mkEqErr1 ctxt ct | isGiven ev - = do { (ctxt, binds_msg) <- relevantBindings True ctxt ct + = do { (ctxt, binds_msg, _) <- relevantBindings True ctxt ct ; let (given_loc, given_msg) = mk_given (cec_encl ctxt) ; dflags <- getDynFlags ; mkEqErr_help dflags ctxt (given_msg $$ binds_msg) @@ -679,8 +720,7 @@ mkEqErr1 ctxt ct Nothing ty1 ty2 } | otherwise -- Wanted or derived - = do { (ctxt, binds_msg) <- relevantBindings True ctxt ct - ; (env1, tidy_orig) <- zonkTidyOrigin (cec_tidy ctxt) (ctLocOrigin loc) + = do { (ctxt, binds_msg, tidy_orig) <- relevantBindings True ctxt ct ; rdr_env <- getGlobalRdrEnv ; fam_envs <- tcGetFamInstEnvs ; let (is_oriented, wanted_msg) = mk_wanted_extra tidy_orig @@ -689,8 +729,7 @@ mkEqErr1 ctxt ct ReprEq -> mkCoercibleExplanation rdr_env fam_envs ty1 ty2 ; dflags <- getDynFlags ; traceTc "mkEqErr1" (ppr ct $$ pprCtOrigin (ctLocOrigin loc) $$ pprCtOrigin tidy_orig) - ; mkEqErr_help dflags (ctxt {cec_tidy = env1}) - (wanted_msg $$ coercible_msg $$ binds_msg) + ; mkEqErr_help dflags ctxt (wanted_msg $$ coercible_msg $$ binds_msg) ct is_oriented ty1 ty2 } where ev = ctEvidence ct @@ -818,8 +857,8 @@ reportEqErr :: ReportErrCtxt -> SDoc -> TcType -> TcType -> TcM ErrMsg reportEqErr ctxt extra1 ct oriented ty1 ty2 = do { let extra2 = mkEqInfoMsg ct ty1 ty2 - ; mkErrorMsg ctxt ct (vcat [ misMatchOrCND ctxt ct oriented ty1 ty2 - , extra2, extra1]) } + ; mkErrorMsgFromCt ctxt ct (vcat [ misMatchOrCND ctxt ct oriented ty1 ty2 + , extra2, extra1]) } mkTyVarEqErr :: DynFlags -> ReportErrCtxt -> SDoc -> Ct -> Maybe SwapFlag -> TcTyVar -> TcType -> TcM ErrMsg @@ -829,29 +868,29 @@ mkTyVarEqErr dflags ctxt extra ct oriented tv1 ty2 -- be oriented the other way round; -- see TcCanonical.canEqTyVarTyVar || isSigTyVar tv1 && not (isTyVarTy ty2) - = mkErrorMsg ctxt ct (vcat [ misMatchOrCND ctxt ct oriented ty1 ty2 - , extraTyVarInfo ctxt tv1 ty2 - , extra ]) + = mkErrorMsgFromCt ctxt ct (vcat [ misMatchOrCND ctxt ct oriented ty1 ty2 + , extraTyVarInfo ctxt tv1 ty2 + , extra ]) -- So tv is a meta tyvar (or started that way before we -- generalised it). So presumably it is an *untouchable* -- meta tyvar or a SigTv, else it'd have been unified | not (k2 `tcIsSubKind` k1) -- Kind error - = mkErrorMsg ctxt ct $ (kindErrorMsg (mkTyVarTy tv1) ty2 $$ extra) + = mkErrorMsgFromCt ctxt ct $ (kindErrorMsg (mkTyVarTy tv1) ty2 $$ extra) | OC_Occurs <- occ_check_expand , NomEq <- ctEqRel ct -- reporting occurs check for Coercible is strange = do { let occCheckMsg = hang (text "Occurs check: cannot construct the infinite type:") 2 (sep [ppr ty1, char '~', ppr ty2]) extra2 = mkEqInfoMsg ct ty1 ty2 - ; mkErrorMsg ctxt ct (occCheckMsg $$ extra2 $$ extra) } + ; mkErrorMsgFromCt ctxt ct (occCheckMsg $$ extra2 $$ extra) } | OC_Forall <- occ_check_expand = do { let msg = vcat [ ptext (sLit "Cannot instantiate unification variable") <+> quotes (ppr tv1) , hang (ptext (sLit "with a type involving foralls:")) 2 (ppr ty2) , nest 2 (ptext (sLit "Perhaps you want ImpredicativeTypes")) ] - ; mkErrorMsg ctxt ct msg } + ; mkErrorMsgFromCt ctxt ct msg } -- If the immediately-enclosing implication has 'tv' a skolem, and -- we know by now its an InferSkol kind of skolem, then presumably @@ -860,9 +899,9 @@ mkTyVarEqErr dflags ctxt extra ct oriented tv1 ty2 | (implic:_) <- cec_encl ctxt , Implic { ic_skols = skols } <- implic , tv1 `elem` skols - = mkErrorMsg ctxt ct (vcat [ misMatchMsg oriented eq_rel ty1 ty2 - , extraTyVarInfo ctxt tv1 ty2 - , extra ]) + = mkErrorMsgFromCt ctxt ct (vcat [ misMatchMsg oriented eq_rel ty1 ty2 + , extraTyVarInfo ctxt tv1 ty2 + , extra ]) -- Check for skolem escape | (implic:_) <- cec_encl ctxt -- Get the innermost context @@ -882,7 +921,7 @@ mkTyVarEqErr dflags ctxt extra ct oriented tv1 ty2 <+> ptext (sLit "bound by") , nest 2 $ ppr skol_info , nest 2 $ ptext (sLit "at") <+> ppr (tcl_loc env) ] ] - ; mkErrorMsg ctxt ct (msg $$ tv_extra $$ extra) } + ; mkErrorMsgFromCt ctxt ct (msg $$ tv_extra $$ extra) } -- Nastiest case: attempt to unify an untouchable variable | (implic:_) <- cec_encl ctxt -- Get the innermost context @@ -896,7 +935,7 @@ mkTyVarEqErr dflags ctxt extra ct oriented tv1 ty2 , nest 2 $ ptext (sLit "at") <+> ppr (tcl_loc env) ] tv_extra = extraTyVarInfo ctxt tv1 ty2 add_sig = suggestAddSig ctxt ty1 ty2 - ; mkErrorMsg ctxt ct (vcat [msg, tclvl_extra, tv_extra, add_sig, extra]) } + ; mkErrorMsgFromCt ctxt ct (vcat [msg, tclvl_extra, tv_extra, add_sig, extra]) } | otherwise = reportEqErr ctxt extra ct oriented (mkTyVarTy tv1) ty2 @@ -1166,7 +1205,7 @@ mkDictErr ctxt cts -- have the same source-location origin, to try avoid a cascade -- of error from one location ; (ctxt, err) <- mk_dict_err ctxt (head (no_inst_cts ++ overlap_cts)) - ; mkErrorMsg ctxt ct1 err } + ; mkErrorMsgFromCt ctxt ct1 err } where no_givens = null (getUserGivens ctxt) @@ -1198,7 +1237,7 @@ mk_dict_err :: ReportErrCtxt -> (Ct, ClsInstLookupResult) mk_dict_err ctxt (ct, (matches, unifiers, safe_haskell)) | null matches -- No matches but perhaps several unifiers = do { let (is_ambig, ambig_msg) = mkAmbigMsg ct - ; (ctxt, binds_msg) <- relevantBindings True ctxt ct + ; (ctxt, binds_msg, _) <- relevantBindings True ctxt ct ; traceTc "mk_dict_err" (ppr ct $$ ppr is_ambig $$ ambig_msg) ; return (ctxt, cannot_resolve_msg is_ambig binds_msg ambig_msg) } @@ -1348,15 +1387,22 @@ usefulContext ctxt pred pred_tvs = tyVarsOfType pred go [] = [] go (ic : ics) - = case ic_info ic of - -- Do not suggest adding constraints to an *inferred* type signature! - SigSkol (InfSigCtxt {}) _ -> rest - info -> info : rest + | implausible ic = rest + | otherwise = ic_info ic : rest where -- Stop when the context binds a variable free in the predicate rest | any (`elemVarSet` pred_tvs) (ic_skols ic) = [] | otherwise = go ics + implausible ic + | null (ic_skols ic) = True + | implausible_info (ic_info ic) = True + | otherwise = False + + implausible_info (SigSkol (InfSigCtxt {}) _) = True + implausible_info _ = False + -- Do not suggest adding constraints to an *inferred* type signature! + show_fixes :: [SDoc] -> SDoc show_fixes [] = empty show_fixes (f:fs) = sep [ ptext (sLit "Possible fix:") @@ -1493,17 +1539,31 @@ getSkolemInfo (implic:implics) tv relevantBindings :: Bool -- True <=> filter by tyvar; False <=> no filtering -- See Trac #8191 -> ReportErrCtxt -> Ct - -> TcM (ReportErrCtxt, SDoc) + -> TcM (ReportErrCtxt, SDoc, CtOrigin) +-- Also returns the zonked and tidied CtOrigin of the constraint relevantBindings want_filtering ctxt ct = do { dflags <- getDynFlags + ; (env1, tidy_orig) <- zonkTidyOrigin (cec_tidy ctxt) (ctLocOrigin loc) + ; let ct_tvs = tyVarsOfCt ct `unionVarSet` extra_tvs + + -- For *kind* errors, report the relevant bindings of the + -- enclosing *type* equality, because that's more useful for the programmer + extra_tvs = case tidy_orig of + KindEqOrigin t1 t2 _ -> tyVarsOfTypes [t1,t2] + _ -> emptyVarSet + ; traceTc "relevantBindings" $ + vcat [ ppr ct + , pprCtOrigin (ctLocOrigin loc) + , ppr ct_tvs + , ppr [id | TcIdBndr id _ <- tcl_bndrs lcl_env] ] + ; (tidy_env', docs, discards) - <- go (cec_tidy ctxt) (maxRelevantBinds dflags) + <- go env1 ct_tvs (maxRelevantBinds dflags) emptyVarSet [] False (tcl_bndrs lcl_env) -- tcl_bndrs has the innermost bindings first, -- which are probably the most relevant ones - ; traceTc "relevantBindings" (ppr ct $$ ppr [id | TcIdBndr id _ <- tcl_bndrs lcl_env]) ; let doc = hang (ptext (sLit "Relevant bindings include")) 2 (vcat docs $$ max_msg) max_msg | discards @@ -1511,19 +1571,11 @@ relevantBindings want_filtering ctxt ct | otherwise = empty ; if null docs - then return (ctxt, empty) - else do { traceTc "rb" doc - ; return (ctxt { cec_tidy = tidy_env' }, doc) } } + then return (ctxt, empty, tidy_orig) + else return (ctxt { cec_tidy = tidy_env' }, doc, tidy_orig) } where loc = ctLoc ct lcl_env = ctLocEnv loc - ct_tvs = tyVarsOfCt ct `unionVarSet` extra_tvs - - -- For *kind* errors, report the relevant bindings of the - -- enclosing *type* equality, because that's more useful for the programmer - extra_tvs = case ctLocOrigin loc of - KindEqOrigin t1 t2 _ -> tyVarsOfTypes [t1,t2] - _ -> emptyVarSet run_out :: Maybe Int -> Bool run_out Nothing = False @@ -1532,14 +1584,14 @@ relevantBindings want_filtering ctxt ct dec_max :: Maybe Int -> Maybe Int dec_max = fmap (\n -> n - 1) - go :: TidyEnv -> Maybe Int -> TcTyVarSet -> [SDoc] + go :: TidyEnv -> TcTyVarSet -> Maybe Int -> TcTyVarSet -> [SDoc] -> Bool -- True <=> some filtered out due to lack of fuel -> [TcIdBinder] -> TcM (TidyEnv, [SDoc], Bool) -- The bool says if we filtered any out -- because of lack of fuel - go tidy_env _ _ docs discards [] + go tidy_env _ _ _ docs discards [] = return (tidy_env, reverse docs, discards) - go tidy_env n_left tvs_seen docs discards (TcIdBndr id top_lvl : tc_bndrs) + go tidy_env ct_tvs n_left tvs_seen docs discards (TcIdBndr id top_lvl : tc_bndrs) = do { (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env (idType id) ; traceTc "relevantBindings 1" (ppr id <+> dcolon <+> ppr tidy_ty) ; let id_tvs = tyVarsOfType tidy_ty @@ -1552,30 +1604,30 @@ relevantBindings want_filtering ctxt ct && id_tvs `disjointVarSet` ct_tvs) -- We want to filter out this binding anyway -- so discard it silently - then go tidy_env n_left tvs_seen docs discards tc_bndrs + then go tidy_env ct_tvs n_left tvs_seen docs discards tc_bndrs else if isTopLevel top_lvl && not (isNothing n_left) -- It's a top-level binding and we have not specified -- -fno-max-relevant-bindings, so discard it silently - then go tidy_env n_left tvs_seen docs discards tc_bndrs + then go tidy_env ct_tvs n_left tvs_seen docs discards tc_bndrs else if run_out n_left && id_tvs `subVarSet` tvs_seen -- We've run out of n_left fuel and this binding only -- mentions aleady-seen type variables, so discard it - then go tidy_env n_left tvs_seen docs True tc_bndrs + then go tidy_env ct_tvs n_left tvs_seen docs True tc_bndrs -- Keep this binding, decrement fuel - else go tidy_env' (dec_max n_left) new_seen (doc:docs) discards tc_bndrs } + else go tidy_env' ct_tvs (dec_max n_left) new_seen (doc:docs) discards tc_bndrs } ----------------------- -warnDefaulting :: Cts -> Type -> TcM () +warnDefaulting :: [Ct] -> Type -> TcM () warnDefaulting wanteds default_ty = do { warn_default <- woptM Opt_WarnTypeDefaults ; env0 <- tcInitTidyEnv ; let tidy_env = tidyFreeTyVars env0 $ - tyVarsOfCts wanteds - tidy_wanteds = mapBag (tidyCt tidy_env) wanteds - (loc, ppr_wanteds) = pprWithArising (bagToList tidy_wanteds) + foldr (unionVarSet . tyVarsOfCt) emptyVarSet wanteds + tidy_wanteds = map (tidyCt tidy_env) wanteds + (loc, ppr_wanteds) = pprWithArising tidy_wanteds warn_msg = hang (ptext (sLit "Defaulting the following constraint(s) to type") <+> quotes (ppr default_ty)) 2 ppr_wanteds diff --git a/compiler/typecheck/TcEvidence.hs b/compiler/typecheck/TcEvidence.hs index 552a403ae7..ca819c3e8a 100644 --- a/compiler/typecheck/TcEvidence.hs +++ b/compiler/typecheck/TcEvidence.hs @@ -11,8 +11,9 @@ module TcEvidence ( -- Evidence bindings TcEvBinds(..), EvBindsVar(..), - EvBindMap(..), emptyEvBindMap, extendEvBinds, lookupEvBind, evBindMapBinds, - EvBind(..), emptyTcEvBinds, isEmptyTcEvBinds, + EvBindMap(..), emptyEvBindMap, extendEvBinds, + lookupEvBind, evBindMapBinds, foldEvBindMap, + EvBind(..), emptyTcEvBinds, isEmptyTcEvBinds, mkGivenEvBind, mkWantedEvBind, EvTerm(..), mkEvCast, evVarsOfTerm, EvLit(..), evTermCoercion, @@ -446,10 +447,10 @@ coVarsOfTcCo tc_co -- We expect only coercion bindings, so use evTermCoercion go_bind :: EvBind -> VarSet - go_bind (EvBind _ tm) = go (evTermCoercion tm) + go_bind (EvBind { eb_rhs =tm }) = go (evTermCoercion tm) get_bndrs :: Bag EvBind -> VarSet - get_bndrs = foldrBag (\ (EvBind b _) bs -> extendVarSet bs b) emptyVarSet + get_bndrs = foldrBag (\ (EvBind { eb_lhs = b }) bs -> extendVarSet bs b) emptyVarSet -- Pretty printing @@ -665,20 +666,35 @@ newtype EvBindMap emptyEvBindMap :: EvBindMap emptyEvBindMap = EvBindMap { ev_bind_varenv = emptyVarEnv } -extendEvBinds :: EvBindMap -> EvVar -> EvTerm -> EvBindMap -extendEvBinds bs v t - = EvBindMap { ev_bind_varenv = extendVarEnv (ev_bind_varenv bs) v (EvBind v t) } +extendEvBinds :: EvBindMap -> EvBind -> EvBindMap +extendEvBinds bs ev_bind + = EvBindMap { ev_bind_varenv = extendVarEnv (ev_bind_varenv bs) + (eb_lhs ev_bind) + ev_bind } lookupEvBind :: EvBindMap -> EvVar -> Maybe EvBind lookupEvBind bs = lookupVarEnv (ev_bind_varenv bs) evBindMapBinds :: EvBindMap -> Bag EvBind -evBindMapBinds bs - = foldVarEnv consBag emptyBag (ev_bind_varenv bs) +evBindMapBinds = foldEvBindMap consBag emptyBag + +foldEvBindMap :: (EvBind -> a -> a) -> a -> EvBindMap -> a +foldEvBindMap k z bs = foldVarEnv k z (ev_bind_varenv bs) ----------------- -- All evidence is bound by EvBinds; no side effects -data EvBind = EvBind EvVar EvTerm +data EvBind + = EvBind { eb_lhs :: EvVar + , eb_rhs :: EvTerm + , eb_is_given :: Bool -- True <=> given + -- See Note [Tracking redundant constraints] in TcSimplify + } + +mkWantedEvBind :: EvVar -> EvTerm -> EvBind +mkWantedEvBind ev tm = EvBind { eb_is_given = False, eb_lhs = ev, eb_rhs = tm } + +mkGivenEvBind :: EvVar -> EvTerm -> EvBind +mkGivenEvBind ev tm = EvBind { eb_is_given = True, eb_lhs = ev, eb_rhs = tm } data EvTerm = EvId EvId -- Any sort of evidence Id, including coercions @@ -888,7 +904,11 @@ instance Outputable EvBindsVar where ppr (EvBindsVar _ u) = ptext (sLit "EvBindsVar") <> angleBrackets (ppr u) instance Outputable EvBind where - ppr (EvBind v e) = sep [ ppr v, nest 2 $ equals <+> ppr e ] + ppr (EvBind { eb_lhs = v, eb_rhs = e, eb_is_given = is_given }) + = sep [ pp_gw <+> ppr v + , nest 2 $ equals <+> ppr e ] + where + pp_gw = brackets (if is_given then ptext (sLit "[G]") else ptext (sLit "[W]")) -- We cheat a bit and pretend EqVars are CoVars for the purposes of pretty printing instance Outputable EvTerm where diff --git a/compiler/typecheck/TcFlatten.hs b/compiler/typecheck/TcFlatten.hs index 3e13a00443..2a76023339 100644 --- a/compiler/typecheck/TcFlatten.hs +++ b/compiler/typecheck/TcFlatten.hs @@ -1531,8 +1531,7 @@ unflatten tv_eqs funeqs = do { ty1 <- zonkTcTyVar tv ; ty2 <- zonkTcType rhs ; let is_refl = ty1 `tcEqType` ty2 - ; if is_refl then do { when (isWanted ev) $ - setEvBind (ctEvId ev) + ; if is_refl then do { setEvBindIfWanted ev (EvCoercion $ mkTcReflCo (eqRelRole eq_rel) rhs) ; return rest } @@ -1563,8 +1562,7 @@ tryFill dflags tv rhs ev do { rhs' <- zonkTcType rhs ; case occurCheckExpand dflags tv rhs' of OC_OK rhs'' -- Normal case: fill the tyvar - -> do { when (isWanted ev) $ - setEvBind (ctEvId ev) + -> do { setEvBindIfWanted ev (EvCoercion (mkTcReflCo (ctEvRole ev) rhs'')) ; setWantedTyBind tv rhs'' ; return True } diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs index ee97ee8aff..27ba99beb7 100644 --- a/compiler/typecheck/TcHsSyn.hs +++ b/compiler/typecheck/TcHsSyn.hs @@ -462,7 +462,7 @@ zonk_bind env sig_warn (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs = ASSERT( all isImmutableTyVar tyvars ) do { (env0, new_tyvars) <- zonkTyBndrsX env tyvars ; (env1, new_evs) <- zonkEvBndrsX env0 evs - ; (env2, new_ev_binds) <- zonkTcEvBinds env1 ev_binds + ; (env2, new_ev_binds) <- zonkTcEvBinds_s env1 ev_binds ; (new_val_bind, new_exports) <- fixM $ \ ~(new_val_binds, _) -> do { let env3 = extendIdZonkEnv env2 (collectHsBindsBinders new_val_binds) ; new_val_binds <- zonkMonoBinds env3 noSigWarn val_binds @@ -1254,11 +1254,17 @@ zonkEvTerm env (EvDelayedError ty msg) = do { ty' <- zonkTcTypeToType env ty ; return (EvDelayedError ty' msg) } +zonkTcEvBinds_s :: ZonkEnv -> [TcEvBinds] -> TcM (ZonkEnv, [TcEvBinds]) +zonkTcEvBinds_s env bs = do { (env, bs') <- mapAccumLM zonk_tc_ev_binds env bs + ; return (env, [EvBinds (unionManyBags bs')]) } + zonkTcEvBinds :: ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, TcEvBinds) -zonkTcEvBinds env (TcEvBinds var) = do { (env', bs') <- zonkEvBindsVar env var - ; return (env', EvBinds bs') } -zonkTcEvBinds env (EvBinds bs) = do { (env', bs') <- zonkEvBinds env bs - ; return (env', EvBinds bs') } +zonkTcEvBinds env bs = do { (env', bs') <- zonk_tc_ev_binds env bs + ; return (env', EvBinds bs') } + +zonk_tc_ev_binds :: ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, Bag EvBind) +zonk_tc_ev_binds env (TcEvBinds var) = zonkEvBindsVar env var +zonk_tc_ev_binds env (EvBinds bs) = zonkEvBinds env bs zonkEvBindsVar :: ZonkEnv -> EvBindsVar -> TcM (ZonkEnv, Bag EvBind) zonkEvBindsVar env (EvBindsVar ref _) = do { bs <- readMutVar ref @@ -1274,22 +1280,21 @@ zonkEvBinds env binds where collect_ev_bndrs :: Bag EvBind -> [EvVar] collect_ev_bndrs = foldrBag add [] - add (EvBind var _) vars = var : vars + add (EvBind { eb_lhs = var }) vars = var : vars zonkEvBind :: ZonkEnv -> EvBind -> TcM EvBind -zonkEvBind env (EvBind var term) +zonkEvBind env (EvBind { eb_lhs = var, eb_rhs = term, eb_is_given = is_given }) = do { var' <- {-# SCC "zonkEvBndr" #-} zonkEvBndr env var -- Optimise the common case of Refl coercions -- See Note [Optimise coercion zonking] -- This has a very big effect on some programs (eg Trac #5030) - ; let ty' = idType var' - - ; case getEqPredTys_maybe ty' of + ; term' <- case getEqPredTys_maybe (idType var') of Just (r, ty1, ty2) | ty1 `eqType` ty2 - -> return (EvBind var' (EvCoercion (mkTcReflCo r ty1))) - _other -> do { term' <- zonkEvTerm env term - ; return (EvBind var' term') } } + -> return (EvCoercion (mkTcReflCo r ty1)) + _other -> zonkEvTerm env term + + ; return (EvBind { eb_lhs = var', eb_rhs = term', eb_is_given = is_given }) } {- ************************************************************************ diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs index c8746ff00e..ced063dcc6 100644 --- a/compiler/typecheck/TcInstDcls.hs +++ b/compiler/typecheck/TcInstDcls.hs @@ -17,7 +17,7 @@ import TcBinds import TcTyClsDecls import TcClassDcl( tcClassDecl2, HsSigFun, lookupHsSig, mkHsSigFun, - findMethodBind, instantiateMethod, tcInstanceMethodBody ) + findMethodBind, instantiateMethod ) import TcPat ( addInlinePrags ) import TcRnMonad import TcValidity @@ -60,7 +60,7 @@ import Util import BooleanFormula ( isUnsatisfied, pprBooleanFormulaNice ) import Control.Monad -import Maybes ( isNothing, isJust, whenIsJust ) +import Maybes ( isNothing, isJust, whenIsJust, catMaybes ) import Data.List ( mapAccumL, partition ) {- @@ -817,29 +817,53 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) addErrCtxt (instDeclCtxt2 (idType dfun_id)) $ do { -- Instantiate the instance decl with skolem constants ; (inst_tyvars, dfun_theta, inst_head) <- tcSkolDFunType (idType dfun_id) + ; dfun_ev_vars <- newEvVars dfun_theta -- We instantiate the dfun_id with superSkolems. -- See Note [Subtle interaction of recursion and overlap] -- and Note [Binding when looking up instances] + ; let (clas, inst_tys) = tcSplitDFunHead inst_head (class_tyvars, sc_theta, _, op_items) = classBigSig clas sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys) sc_theta - ; dfun_ev_vars <- newEvVars dfun_theta - ; traceTc "tcInstDecl2" (vcat [ppr inst_tyvars, ppr inst_tys, ppr dfun_theta, ppr sc_theta']) - ; fam_envs <- tcGetFamInstEnvs - ; (sc_ids, sc_binds) <- tcSuperClasses fam_envs loc clas inst_tyvars - dfun_ev_vars sc_theta' inst_tys - -- Deal with 'SPECIALISE instance' pragmas - -- See Note [SPECIALISE instance pragmas] + -- Deal with 'SPECIALISE instance' pragmas + -- See Note [SPECIALISE instance pragmas] ; spec_inst_info@(spec_inst_prags,_) <- tcSpecInstPrags dfun_id ibinds - -- Typecheck the methods - ; (meth_ids, meth_binds) - <- tcInstanceMethods dfun_id clas inst_tyvars dfun_ev_vars - inst_tys spec_inst_info - op_items ibinds + -- Typecheck superclasses and methods + -- See Note [Typechecking plan for instance declarations] + ; dfun_ev_binds_var <- newTcEvBinds + ; let dfun_ev_binds = TcEvBinds dfun_ev_binds_var + ; ((sc_meth_ids, sc_meth_binds, sc_meth_implics), tclvl) + <- pushTcLevelM $ + do { fam_envs <- tcGetFamInstEnvs + ; (sc_ids, sc_binds, sc_implics) + <- tcSuperClasses dfun_id clas inst_tyvars dfun_ev_vars + inst_tys dfun_ev_binds fam_envs + sc_theta' + + -- Typecheck the methods + ; (meth_ids, meth_binds, meth_implics) + <- tcMethods dfun_id clas inst_tyvars dfun_ev_vars + inst_tys dfun_ev_binds spec_inst_info + op_items ibinds + + ; return ( sc_ids ++ meth_ids + , sc_binds `unionBags` meth_binds + , sc_implics `unionBags` meth_implics ) } + + ; env <- getLclEnv + ; emitImplication $ Implic { ic_tclvl = tclvl + , ic_skols = inst_tyvars + , ic_no_eqs = False + , ic_given = dfun_ev_vars + , ic_wanted = addImplics emptyWC sc_meth_implics + , ic_status = IC_Unsolved + , ic_binds = dfun_ev_binds_var + , ic_env = env + , ic_info = InstSkol } -- Create the result bindings ; self_dict <- newDict clas inst_tys @@ -858,8 +882,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) -- con_app_args = MkD ty1 ty2 sc1 sc2 op1 op2 con_app_tys = wrapId (mkWpTyApps inst_tys) (dataConWrapId dict_constr) --- con_app_scs = mkHsWrap (mkWpEvApps (map EvId sc_ev_vars)) con_app_tys - con_app_args = foldl app_to_meth con_app_tys (sc_ids ++ meth_ids) + con_app_args = foldl app_to_meth con_app_tys sc_meth_ids app_to_meth :: HsExpr Id -> Id -> HsExpr Id app_to_meth fun meth_id = L loc fun `HsApp` L loc (wrapId arg_wrapper meth_id) @@ -881,102 +904,78 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) main_bind = AbsBinds { abs_tvs = inst_tyvars , abs_ev_vars = dfun_ev_vars , abs_exports = [export] - , abs_ev_binds = emptyTcEvBinds + , abs_ev_binds = [] , abs_binds = unitBag dict_bind } - ; return (unitBag (L loc main_bind) `unionBags` - listToBag meth_binds `unionBags` - listToBag sc_binds) + ; return (unitBag (L loc main_bind) `unionBags` sc_meth_binds) } where dfun_id = instanceDFunId ispec loc = getSrcSpan dfun_id ----------------------- -mkMethIds :: HsSigFun -> Class -> [TcTyVar] -> [EvVar] - -> [TcType] -> Id -> TcM (TcId, TcSigInfo, HsWrapper) -mkMethIds sig_fn clas tyvars dfun_ev_vars inst_tys sel_id - = do { poly_meth_name <- newName (mkClassOpAuxOcc sel_occ) - ; local_meth_name <- newName sel_occ - -- Base the local_meth_name on the selector name, because - -- type errors from tcInstanceMethodBody come from here - ; let poly_meth_id = mkLocalId poly_meth_name poly_meth_ty - local_meth_id = mkLocalId local_meth_name local_meth_ty +wrapId :: HsWrapper -> id -> HsExpr id +wrapId wrapper id = mkHsWrap wrapper (HsVar id) - ; case lookupHsSig sig_fn sel_name of - Just lhs_ty -- There is a signature in the instance declaration - -- See Note [Instance method signatures] - -> setSrcSpan (getLoc lhs_ty) $ - do { inst_sigs <- xoptM Opt_InstanceSigs - ; checkTc inst_sigs (misplacedInstSig sel_name lhs_ty) - ; sig_ty <- tcHsSigType (FunSigCtxt sel_name) lhs_ty - ; let poly_sig_ty = mkSigmaTy tyvars theta sig_ty - ; tc_sig <- instTcTySig lhs_ty sig_ty Nothing [] local_meth_name - ; hs_wrap <- addErrCtxtM (methSigCtxt sel_name poly_sig_ty poly_meth_ty) $ - tcSubType (FunSigCtxt sel_name) poly_sig_ty poly_meth_ty - ; return (poly_meth_id, tc_sig, hs_wrap) } +{- Note [Typechecking plan for instance declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For intance declarations we generate the following bindings and implication +constraints. Example: - Nothing -- No type signature - -> do { tc_sig <- instTcTySigFromId local_meth_id - ; return (poly_meth_id, tc_sig, idHsWrapper) } } - -- Absent a type sig, there are no new scoped type variables here - -- Only the ones from the instance decl itself, which are already - -- in scope. Example: - -- class C a where { op :: forall b. Eq b => ... } - -- instance C [c] where { op = <rhs> } - -- In <rhs>, 'c' is scope but 'b' is not! - where - sel_name = idName sel_id - sel_occ = nameOccName sel_name - local_meth_ty = instantiateMethod clas sel_id inst_tys - poly_meth_ty = mkSigmaTy tyvars theta local_meth_ty - theta = map idType dfun_ev_vars + instance Ord a => Ord [a] where compare = <compare-rhs> -methSigCtxt :: Name -> TcType -> TcType -> TidyEnv -> TcM (TidyEnv, MsgDoc) -methSigCtxt sel_name sig_ty meth_ty env0 - = do { (env1, sig_ty) <- zonkTidyTcType env0 sig_ty - ; (env2, meth_ty) <- zonkTidyTcType env1 meth_ty - ; let msg = hang (ptext (sLit "When checking that instance signature for") <+> quotes (ppr sel_name)) - 2 (vcat [ ptext (sLit "is more general than its signature in the class") - , ptext (sLit "Instance sig:") <+> ppr sig_ty - , ptext (sLit " Class sig:") <+> ppr meth_ty ]) - ; return (env2, msg) } +generates this: -misplacedInstSig :: Name -> LHsType Name -> SDoc -misplacedInstSig name hs_ty - = vcat [ hang (ptext (sLit "Illegal type signature in instance declaration:")) - 2 (hang (pprPrefixName name) - 2 (dcolon <+> ppr hs_ty)) - , ptext (sLit "(Use InstanceSigs to allow this)") ] + Bindings: + -- Method bindings + $ccompare :: forall a. Ord a => a -> a -> Ordering + $ccompare = /\a \(d:Ord a). let <meth-ev-binds> in ... -{- -Note [Instance method signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -With -XInstanceSigs we allow the user to supply a signature for the -method in an instance declaration. Here is an artificial example: + -- Superclass bindings + $cp1Ord :: forall a. Ord a => Eq [a] + $cp1Ord = /\a \(d:Ord a). let <sc-ev-binds> + in dfEqList (dw :: Eq a) - data Age = MkAge Int - instance Ord Age where - compare :: a -> a -> Bool - compare = error "You can't compare Ages" + Constraints: + forall a. Ord a => + -- Method constraint + (forall. (empty) => <constraints from compare-rhs>) + -- Superclass constraint + /\ (forall. (empty) => dw :: Eq a) -The instance signature can be *more* polymorphic than the instantiated -class method (in this case: Age -> Age -> Bool), but it cannot be less -polymorphic. Moreover, if a signature is given, the implementation -code should match the signature, and type variables bound in the -singature should scope over the method body. +Notice that -We achieve this by building a TcSigInfo for the method, whether or not -there is an instance method signature, and using that to typecheck -the declaration (in tcInstanceMethodBody). That means, conveniently, -that the type variables bound in the signature will scope over the body. + * Per-meth/sc implication. There is one inner implication per + superclass or method, with no skolem variables or givens. The only + reason for this one is to gather the evidence bindings privately + for this superclass or method. This implication is generated + by checkInstConstraints. -What about the check that the instance method signature is more -polymorphic than the instantiated class method type? We just do a -tcSubType call in mkMethIds, and use the HsWrapper thus generated in -the method AbsBind. It's very like the tcSubType impedence-matching -call in mkExport. We have to pass the HsWrapper into -tcInstanceMethodBody. + * Overall instance implication. There is an overall enclosing + implication for the whole instance declaratation, with the expected + skolems and givens. We need this to get the correct "redundant + constraint" warnings, gathering all the uses from all the methods + and superclasses. See TcSimplify Note [Tracking redundant + constraints] + + * The given constraints in the outer implication may generate + evidence, notably by superclass selection. Since the method and + superclass bindings are top-level, we want that evidence copied + into *every* method or superclass definition. (Some of it will + be usused in some, but dead-code elimination will drop it.) + + We achieve this by putting the the evidence variable for the overall + instance implicaiton into the AbsBinds for each method/superclass. + Hence the 'dfun_ev_binds' passed into tcMethods and tcSuperClasses. + (And that in turn is why the abs_ev_binds field of AbBinds is a + [TcEvBinds] rather than simply TcEvBinds. + + This is a bit of a hack, but works very nicely in practice. + + * Note that if a method has a locally-polymorhic binding, there will + be yet another implication for that, generated by tcPolyCheck + in tcMethodBody. E.g. + class C a where + foo :: forall b. Ord b => blah ************************************************************************ @@ -986,22 +985,24 @@ tcInstanceMethodBody. ************************************************************************ -} -tcSuperClasses :: FamInstEnvs -> SrcSpan - -> Class -> [TcTyVar] -> [EvVar] - -> TcThetaType -> [TcType] - -> TcM ([EvVar], [LHsBind Id]) +tcSuperClasses :: DFunId -> Class -> [TcTyVar] -> [EvVar] -> [TcType] + -> TcEvBinds -> FamInstEnvs + -> TcThetaType + -> TcM ([EvVar], LHsBinds Id, Bag Implication) -- Make a new top-level function binding for each superclass, -- something like --- $Ordp0 :: forall a. Ord a => Eq [a] --- $Ordp0 = /\a \(d:Ord a). dfunEqList a (sc_sel d) +-- $Ordp1 :: forall a. Ord a => Eq [a] +-- $Ordp1 = /\a \(d:Ord a). dfunEqList a (sc_sel d) -- -- See Note [Recursive superclasses] for why this is so hard! -- In effect, be build a special-purpose solver for the first step -- of solving each superclass constraint -tcSuperClasses fam_envs loc cls tyvars dfun_evs sc_theta inst_tys +tcSuperClasses dfun_id cls tyvars dfun_evs inst_tys dfun_ev_binds fam_envs sc_theta = do { traceTc "tcSuperClasses" (ppr cls $$ ppr inst_tys $$ ppr given_cls_preds) - ; mapAndUnzipM tc_super (zip sc_theta [0..]) } + ; (ids, binds, implics) <- mapAndUnzip3M tc_super (zip sc_theta [fIRST_TAG..]) + ; return (ids, listToBag binds, listToBag implics) } where + loc = getSrcSpan dfun_id head_size = sizeTypes inst_tys ------------ @@ -1043,8 +1044,8 @@ tcSuperClasses fam_envs loc cls tyvars dfun_evs sc_theta inst_tys ------------ tc_super (sc_pred, n) - = do { (ev_binds, sc_ev_id) <- checkScConstraints InstSkol tyvars dfun_evs $ - emit_sc_pred fam_envs sc_pred + = do { (sc_implic, sc_ev_id) <- checkInstConstraints $ + emit_sc_pred fam_envs sc_pred ; sc_top_name <- newName (mkSuperDictAuxOcc n (getOccName cls)) ; let sc_top_ty = mkForAllTys tyvars (mkPiTypes dfun_evs sc_pred) @@ -1052,35 +1053,39 @@ tcSuperClasses fam_envs loc cls tyvars dfun_evs sc_theta inst_tys export = ABE { abe_wrap = idHsWrapper, abe_poly = sc_top_id , abe_mono = sc_ev_id , abe_prags = SpecPrags [] } + local_ev_binds = TcEvBinds (ic_binds sc_implic) bind = AbsBinds { abs_tvs = tyvars , abs_ev_vars = dfun_evs , abs_exports = [export] - , abs_ev_binds = ev_binds + , abs_ev_binds = [dfun_ev_binds, local_ev_binds] , abs_binds = emptyBag } - ; return (sc_top_id, L loc bind) } + ; return (sc_top_id, L loc bind, sc_implic) } ------------------- emit_sc_pred fam_envs sc_pred ev_binds | (sc_co, norm_sc_pred) <- normaliseType fam_envs Nominal sc_pred -- sc_co :: sc_pred ~ norm_sc_pred , ClassPred cls tys <- classifyPredType norm_sc_pred - = do { (ok, sc_ev_tm) <- emit_sc_cls_pred norm_sc_pred cls tys + = do { sc_ev_tm <- emit_sc_cls_pred norm_sc_pred cls tys ; sc_ev_id <- newEvVar sc_pred ; let tc_co = TcCoercion (mkSubCo (mkSymCo sc_co)) - ; addTcEvBind ev_binds sc_ev_id (mkEvCast sc_ev_tm tc_co) - ; return (ok, sc_ev_id) } + ; addTcEvBind ev_binds (mkWantedEvBind sc_ev_id (mkEvCast sc_ev_tm tc_co)) + -- This is where we set the evidence for the superclass, and do so + -- (very unusually) *outside the solver*. That's why + -- checkInstConstraints passes in the evidence bindings + ; return sc_ev_id } | otherwise = do { sc_ev_id <- emitWanted ScOrigin sc_pred ; traceTc "tcSuperClass 4" (ppr sc_pred $$ ppr sc_ev_id) - ; return (True, sc_ev_id) } + ; return sc_ev_id } ------------------- emit_sc_cls_pred sc_pred cls tys | (ev_tm:_) <- [ ev_tm | (ev_tm, ev_ty) <- given_cls_preds , ev_ty `tcEqType` sc_pred ] = do { traceTc "tcSuperClass 1" (ppr sc_pred $$ ppr ev_tm) - ; return (True, ev_tm) } + ; return ev_tm } | otherwise = do { inst_envs <- tcGetInstEnvs @@ -1091,12 +1096,40 @@ tcSuperClasses fam_envs loc cls tyvars dfun_evs sc_theta inst_tys ; arg_evs <- emitWanteds ScOrigin inst_theta ; let dict_app = EvDFunApp dfun_id inst_tys (map EvId arg_evs) ; traceTc "tcSuperClass 2" (ppr sc_pred $$ ppr dict_app) - ; return (True, dict_app) } - - _ -> do { sc_ev_id <- emitWanted ScOrigin sc_pred - ; traceTc "tcSuperClass 3" (ppr sc_pred $$ ppr sc_ev_id) - ; return (False, EvId sc_ev_id) } } - + ; return dict_app } + + _ -> -- No instance, so we want to report an error + -- Emitting it as an 'insoluble' prevents the solver + -- attempting to solve it (which might, wrongly, succeed) + do { sc_ev <- newWanted ScOrigin sc_pred + ; emitInsoluble (mkNonCanonical sc_ev) + ; traceTc "tcSuperClass 3" (ppr sc_pred $$ ppr sc_ev) + ; return (ctEvTerm sc_ev) } } + +------------------- +checkInstConstraints :: (EvBindsVar -> TcM result) + -> TcM (Implication, result) +-- See Note [Typechecking plan for instance declarations] +-- The thing_inside is also passed the EvBindsVar, +-- so that emit_sc_pred can add evidence for the superclass +-- (not used for methods) +checkInstConstraints thing_inside + = do { ev_binds_var <- newTcEvBinds + ; env <- getLclEnv + ; (result, tclvl, wanted) <- pushLevelAndCaptureConstraints $ + thing_inside ev_binds_var + + ; let implic = Implic { ic_tclvl = tclvl + , ic_skols = [] + , ic_no_eqs = False + , ic_given = [] + , ic_wanted = wanted + , ic_status = IC_Unsolved + , ic_binds = ev_binds_var + , ic_env = env + , ic_info = InstSkol } + + ; return (implic, result) } {- Note [Recursive superclasses] @@ -1246,94 +1279,8 @@ that were in the original instance declaration. DFun types are built (only) by MkId.mkDictFunId, so that is where we decide what silent arguments are to be added. - - -************************************************************************ -* * - Specialise instance pragmas -* * -************************************************************************ - -Note [SPECIALISE instance pragmas] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - - instance (Ix a, Ix b) => Ix (a,b) where - {-# SPECIALISE instance Ix (Int,Int) #-} - range (x,y) = ... - -We make a specialised version of the dictionary function, AND -specialised versions of each *method*. Thus we should generate -something like this: - - $dfIxPair :: (Ix a, Ix b) => Ix (a,b) - {-# DFUN [$crangePair, ...] #-} - {-# SPECIALISE $dfIxPair :: Ix (Int,Int) #-} - $dfIxPair da db = Ix ($crangePair da db) (...other methods...) - - $crange :: (Ix a, Ix b) -> ((a,b),(a,b)) -> [(a,b)] - {-# SPECIALISE $crange :: ((Int,Int),(Int,Int)) -> [(Int,Int)] #-} - $crange da db = <blah> - -The SPECIALISE pragmas are acted upon by the desugarer, which generate - - dii :: Ix Int - dii = ... - - $s$dfIxPair :: Ix ((Int,Int),(Int,Int)) - {-# DFUN [$crangePair di di, ...] #-} - $s$dfIxPair = Ix ($crangePair di di) (...) - - {-# RULE forall (d1,d2:Ix Int). $dfIxPair Int Int d1 d2 = $s$dfIxPair #-} - - $s$crangePair :: ((Int,Int),(Int,Int)) -> [(Int,Int)] - $c$crangePair = ...specialised RHS of $crangePair... - - {-# RULE forall (d1,d2:Ix Int). $crangePair Int Int d1 d2 = $s$crangePair #-} - -Note that - - * The specialised dictionary $s$dfIxPair is very much needed, in case we - call a function that takes a dictionary, but in a context where the - specialised dictionary can be used. See Trac #7797. - - * The ClassOp rule for 'range' works equally well on $s$dfIxPair, because - it still has a DFunUnfolding. See Note [ClassOp/DFun selection] - - * A call (range ($dfIxPair Int Int d1 d2)) might simplify two ways: - --> {ClassOp rule for range} $crangePair Int Int d1 d2 - --> {SPEC rule for $crangePair} $s$crangePair - or thus: - --> {SPEC rule for $dfIxPair} range $s$dfIxPair - --> {ClassOpRule for range} $s$crangePair - It doesn't matter which way. - - * We want to specialise the RHS of both $dfIxPair and $crangePair, - but the SAME HsWrapper will do for both! We can call tcSpecPrag - just once, and pass the result (in spec_inst_info) to tcInstanceMethods. -} -tcSpecInstPrags :: DFunId -> InstBindings Name - -> TcM ([Located TcSpecPrag], PragFun) -tcSpecInstPrags dfun_id (InstBindings { ib_binds = binds, ib_pragmas = uprags }) - = do { spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) $ - filter isSpecInstLSig uprags - -- The filter removes the pragmas for methods - ; return (spec_inst_prags, mkPragFun uprags binds) } - ------------------------------- -tcSpecInst :: Id -> Sig Name -> TcM TcSpecPrag -tcSpecInst dfun_id prag@(SpecInstSig hs_ty) - = addErrCtxt (spec_ctxt prag) $ - do { (tyvars, theta, clas, tys) <- tcHsInstHead SpecInstCtxt hs_ty - ; let spec_dfun_ty = mkDictFunTy tyvars theta clas tys - ; co_fn <- tcSubType SpecInstCtxt (idType dfun_id) spec_dfun_ty - ; return (SpecPrag dfun_id co_fn defaultInlinePragma) } - where - spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag) - -tcSpecInst _ _ = panic "tcSpecInst" - {- ************************************************************************ * * @@ -1341,7 +1288,7 @@ tcSpecInst _ _ = panic "tcSpecInst" * * ************************************************************************ -tcInstanceMethod +tcMethod - Make the method bindings, as a [(NonRec, HsBinds)], one per method - Remembering to use fresh Name (the instance method Name) as the binder - Bring the instance method Ids into scope, for the benefit of tcInstSig @@ -1350,76 +1297,65 @@ tcInstanceMethod - Use tcValBinds to do the checking -} -tcInstanceMethods :: DFunId -> Class -> [TcTyVar] - -> [EvVar] - -> [TcType] - -> ([Located TcSpecPrag], PragFun) - -> [(Id, DefMeth)] - -> InstBindings Name - -> TcM ([Id], [LHsBind Id]) +tcMethods :: DFunId -> Class + -> [TcTyVar] -> [EvVar] + -> [TcType] + -> TcEvBinds + -> ([Located TcSpecPrag], PragFun) + -> [(Id, DefMeth)] + -> InstBindings Name + -> TcM ([Id], LHsBinds Id, Bag Implication) -- The returned inst_meth_ids all have types starting -- forall tvs. theta => ... -tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys - (spec_inst_prags, prag_fn) - op_items (InstBindings { ib_binds = binds - , ib_tyvars = lexical_tvs - , ib_pragmas = sigs - , ib_extensions = exts - , ib_derived = is_derived }) +tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys + dfun_ev_binds prags@(spec_inst_prags,_) op_items + (InstBindings { ib_binds = binds + , ib_tyvars = lexical_tvs + , ib_pragmas = sigs + , ib_extensions = exts + , ib_derived = is_derived }) = tcExtendTyVarEnv2 (lexical_tvs `zip` tyvars) $ -- The lexical_tvs scope over the 'where' part do { traceTc "tcInstMeth" (ppr sigs $$ ppr binds) - ; let hs_sig_fn = mkHsSigFun sigs ; checkMinimalDefinition - ; set_exts exts $ mapAndUnzipM (tc_item hs_sig_fn) op_items } + ; (ids, binds, mb_implics) <- set_exts exts $ + mapAndUnzip3M tc_item op_items + ; return (ids, listToBag binds, listToBag (catMaybes mb_implics)) } where set_exts :: [ExtensionFlag] -> TcM a -> TcM a set_exts es thing = foldr setXOptM thing es - ---------------------- - tc_item :: HsSigFun -> (Id, DefMeth) -> TcM (Id, LHsBind Id) - tc_item sig_fn (sel_id, dm_info) - = case findMethodBind (idName sel_id) binds of - Just (user_bind, bndr_loc) - -> tc_body sig_fn sel_id user_bind bndr_loc - Nothing -> do { traceTc "tc_def" (ppr sel_id) - ; tc_default sig_fn sel_id dm_info } + hs_sig_fn = mkHsSigFun sigs + inst_loc = getSrcSpan dfun_id ---------------------- - tc_body :: HsSigFun -> Id -> LHsBind Name - -> SrcSpan -> TcM (TcId, LHsBind Id) - tc_body sig_fn sel_id rn_bind bndr_loc - = add_meth_ctxt sel_id rn_bind $ - do { traceTc "tc_item" (ppr sel_id <+> ppr (idType sel_id)) - ; (meth_id, local_meth_sig, hs_wrap) - <- setSrcSpan bndr_loc $ - mkMethIds sig_fn clas tyvars dfun_ev_vars - inst_tys sel_id - ; let prags = prag_fn (idName sel_id) - ; meth_id1 <- addInlinePrags meth_id prags - ; spec_prags <- tcSpecPrags meth_id1 prags - ; bind <- tcInstanceMethodBody InstSkol - tyvars dfun_ev_vars - meth_id1 local_meth_sig hs_wrap - (mk_meth_spec_prags meth_id1 spec_prags) - rn_bind - ; return (meth_id1, bind) } + tc_item :: (Id, DefMeth) -> TcM (Id, LHsBind Id, Maybe Implication) + tc_item (sel_id, dm_info) + | Just (user_bind, bndr_loc) <- findMethodBind (idName sel_id) binds + = tcMethodBody clas tyvars dfun_ev_vars inst_tys + dfun_ev_binds is_derived hs_sig_fn prags + sel_id user_bind bndr_loc + | otherwise + = do { traceTc "tc_def" (ppr sel_id) + ; tc_default sel_id dm_info } ---------------------- - tc_default :: HsSigFun -> Id -> DefMeth -> TcM (TcId, LHsBind Id) + tc_default :: Id -> DefMeth -> TcM (TcId, LHsBind Id, Maybe Implication) - tc_default sig_fn sel_id (GenDefMeth dm_name) + tc_default sel_id (GenDefMeth dm_name) = do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id dm_name - ; tc_body sig_fn sel_id meth_bind inst_loc } + ; tcMethodBody clas tyvars dfun_ev_vars inst_tys + dfun_ev_binds is_derived hs_sig_fn prags + sel_id meth_bind inst_loc } - tc_default sig_fn sel_id NoDefMeth -- No default method at all + tc_default sel_id NoDefMeth -- No default method at all = do { traceTc "tc_def: warn" (ppr sel_id) - ; (meth_id, _, _) <- mkMethIds sig_fn clas tyvars dfun_ev_vars + ; (meth_id, _, _) <- mkMethIds hs_sig_fn clas tyvars dfun_ev_vars inst_tys sel_id ; dflags <- getDynFlags - ; return (meth_id, - mkVarBind meth_id $ - mkLHsWrap lam_wrapper (error_rhs dflags)) } + ; let meth_bind = mkVarBind meth_id $ + mkLHsWrap lam_wrapper (error_rhs dflags) + ; return (meth_id, meth_bind, Nothing) } where error_rhs dflags = L inst_loc $ HsApp error_fun (error_msg dflags) error_fun = L inst_loc $ wrapId (WpTyApp meth_tau) nO_METHOD_BINDING_ERROR_ID @@ -1429,7 +1365,7 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys error_string dflags = showSDoc dflags (hcat [ppr inst_loc, text "|", ppr sel_id ]) lam_wrapper = mkWpTyLams tyvars <.> mkWpLams dfun_ev_vars - tc_default sig_fn sel_id (DefMeth dm_name) -- A polymorphic default method + tc_default sel_id (DefMeth dm_name) -- A polymorphic default method = do { -- Build the typechecked version directly, -- without calling typecheck_method; -- see Note [Default methods in instances] @@ -1439,11 +1375,11 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys -- you to apply a function to a dictionary *expression*. ; self_dict <- newDict clas inst_tys - ; let self_ev_bind = EvBind self_dict - (EvDFunApp dfun_id (mkTyVarTys tyvars) (map EvId dfun_ev_vars)) + ; let self_ev_bind = mkWantedEvBind self_dict + (EvDFunApp dfun_id (mkTyVarTys tyvars) (map EvId dfun_ev_vars)) ; (meth_id, local_meth_sig, hs_wrap) - <- mkMethIds sig_fn clas tyvars dfun_ev_vars inst_tys sel_id + <- mkMethIds hs_sig_fn clas tyvars dfun_ev_vars inst_tys sel_id ; dm_id <- tcLookupId dm_name ; let dm_inline_prag = idInlinePragma dm_id rhs = HsWrap (mkWpEvVarApps [self_dict] <.> mkWpTyApps inst_tys) $ @@ -1458,56 +1394,191 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys export = ABE { abe_wrap = hs_wrap, abe_poly = meth_id1 , abe_mono = local_meth_id - , abe_prags = mk_meth_spec_prags meth_id1 [] } + , abe_prags = mk_meth_spec_prags meth_id1 spec_inst_prags [] } bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars , abs_exports = [export] - , abs_ev_binds = EvBinds (unitBag self_ev_bind) + , abs_ev_binds = [EvBinds (unitBag self_ev_bind)] , abs_binds = unitBag meth_bind } -- Default methods in an instance declaration can't have their own -- INLINE or SPECIALISE pragmas. It'd be possible to allow them, but -- currently they are rejected with -- "INLINE pragma lacks an accompanying binding" - ; return (meth_id1, L inst_loc bind) } + ; return (meth_id1, L inst_loc bind, Nothing) } ---------------------- - mk_meth_spec_prags :: Id -> [LTcSpecPrag] -> TcSpecPrags - -- Adapt the 'SPECIALISE instance' pragmas to work for this method Id - -- There are two sources: - -- * spec_prags_for_me: {-# SPECIALISE op :: <blah> #-} - -- * spec_prags_from_inst: derived from {-# SPECIALISE instance :: <blah> #-} - -- These ones have the dfun inside, but [perhaps surprisingly] - -- the correct wrapper. - mk_meth_spec_prags meth_id spec_prags_for_me - = SpecPrags (spec_prags_for_me ++ spec_prags_from_inst) + -- Check if one of the minimal complete definitions is satisfied + checkMinimalDefinition + = whenIsJust (isUnsatisfied methodExists (classMinimalDef clas)) $ + warnUnsatisifiedMinimalDefinition where - spec_prags_from_inst - | isInlinePragma (idInlinePragma meth_id) - = [] -- Do not inherit SPECIALISE from the instance if the - -- method is marked INLINE, because then it'll be inlined - -- and the specialisation would do nothing. (Indeed it'll provoke - -- a warning from the desugarer - | otherwise - = [ L inst_loc (SpecPrag meth_id wrap inl) - | L inst_loc (SpecPrag _ wrap inl) <- spec_inst_prags] - - inst_loc = getSrcSpan dfun_id + methodExists meth = isJust (findMethodBind meth binds) +------------------------ +tcMethodBody :: Class -> [TcTyVar] -> [EvVar] -> [TcType] + -> TcEvBinds -> Bool + -> HsSigFun + -> ([LTcSpecPrag], PragFun) + -> Id -> LHsBind Name -> SrcSpan + -> TcM (TcId, LHsBind Id, Maybe Implication) +tcMethodBody clas tyvars dfun_ev_vars inst_tys + dfun_ev_binds is_derived + sig_fn (spec_inst_prags, prag_fn) + sel_id (L bind_loc meth_bind) bndr_loc + = add_meth_ctxt $ + do { traceTc "tcMethodBody" (ppr sel_id <+> ppr (idType sel_id)) + ; (global_meth_id, local_meth_sig, hs_wrap) + <- setSrcSpan bndr_loc $ + mkMethIds sig_fn clas tyvars dfun_ev_vars + inst_tys sel_id + + ; let prags = prag_fn (idName sel_id) + local_meth_id = sig_id local_meth_sig + lm_bind = meth_bind { fun_id = L bndr_loc (idName local_meth_id) } + -- Substitute the local_meth_name for the binder + -- NB: the binding is always a FunBind + + ; global_meth_id <- addInlinePrags global_meth_id prags + ; spec_prags <- tcSpecPrags global_meth_id prags + ; (meth_implic, (tc_bind, _, _)) + <- checkInstConstraints $ \ _ev_binds -> + tcPolyCheck NonRecursive no_prag_fn local_meth_sig + (L bind_loc lm_bind) + + ; let specs = mk_meth_spec_prags global_meth_id spec_inst_prags spec_prags + export = ABE { abe_poly = global_meth_id + , abe_mono = local_meth_id + , abe_wrap = hs_wrap + , abe_prags = specs } + + local_ev_binds = TcEvBinds (ic_binds meth_implic) + full_bind = AbsBinds { abs_tvs = tyvars + , abs_ev_vars = dfun_ev_vars + , abs_exports = [export] + , abs_ev_binds = [dfun_ev_binds, local_ev_binds] + , abs_binds = tc_bind } + + ; return (global_meth_id, L bind_loc full_bind, Just meth_implic) } + where -- For instance decls that come from deriving clauses -- we want to print out the full source code if there's an error -- because otherwise the user won't see the code at all - add_meth_ctxt sel_id rn_bind thing - | is_derived = addLandmarkErrCtxt (derivBindCtxt sel_id clas inst_tys rn_bind) thing + add_meth_ctxt thing + | is_derived = addLandmarkErrCtxt (derivBindCtxt sel_id clas inst_tys) thing | otherwise = thing - ---------------------- + no_prag_fn _ = [] -- No pragmas for local_meth_id; + -- they are all for meth_id + + +------------------------ +mkMethIds :: HsSigFun -> Class -> [TcTyVar] -> [EvVar] + -> [TcType] -> Id -> TcM (TcId, TcSigInfo, HsWrapper) +mkMethIds sig_fn clas tyvars dfun_ev_vars inst_tys sel_id + = do { poly_meth_name <- newName (mkClassOpAuxOcc sel_occ) + ; local_meth_name <- newName sel_occ + -- Base the local_meth_name on the selector name, because + -- type errors from tcMethodBody come from here + ; let poly_meth_id = mkLocalId poly_meth_name poly_meth_ty + local_meth_id = mkLocalId local_meth_name local_meth_ty + + ; case lookupHsSig sig_fn sel_name of + Just lhs_ty -- There is a signature in the instance declaration + -- See Note [Instance method signatures] + -> setSrcSpan (getLoc lhs_ty) $ + do { inst_sigs <- xoptM Opt_InstanceSigs + ; checkTc inst_sigs (misplacedInstSig sel_name lhs_ty) + ; sig_ty <- tcHsSigType (FunSigCtxt sel_name True) lhs_ty + ; let poly_sig_ty = mkSigmaTy tyvars theta sig_ty + ; tc_sig <- instTcTySig lhs_ty sig_ty Nothing [] local_meth_name + ; hs_wrap <- addErrCtxtM (methSigCtxt sel_name poly_sig_ty poly_meth_ty) $ + tcSubType (FunSigCtxt sel_name False) poly_sig_ty poly_meth_ty + ; return (poly_meth_id, tc_sig, hs_wrap) } + + Nothing -- No type signature + -> do { tc_sig <- instTcTySigFromId local_meth_id + ; return (poly_meth_id, tc_sig, idHsWrapper) } } + -- Absent a type sig, there are no new scoped type variables here + -- Only the ones from the instance decl itself, which are already + -- in scope. Example: + -- class C a where { op :: forall b. Eq b => ... } + -- instance C [c] where { op = <rhs> } + -- In <rhs>, 'c' is scope but 'b' is not! + where + sel_name = idName sel_id + sel_occ = nameOccName sel_name + local_meth_ty = instantiateMethod clas sel_id inst_tys + poly_meth_ty = mkSigmaTy tyvars theta local_meth_ty + theta = map idType dfun_ev_vars + +methSigCtxt :: Name -> TcType -> TcType -> TidyEnv -> TcM (TidyEnv, MsgDoc) +methSigCtxt sel_name sig_ty meth_ty env0 + = do { (env1, sig_ty) <- zonkTidyTcType env0 sig_ty + ; (env2, meth_ty) <- zonkTidyTcType env1 meth_ty + ; let msg = hang (ptext (sLit "When checking that instance signature for") <+> quotes (ppr sel_name)) + 2 (vcat [ ptext (sLit "is more general than its signature in the class") + , ptext (sLit "Instance sig:") <+> ppr sig_ty + , ptext (sLit " Class sig:") <+> ppr meth_ty ]) + ; return (env2, msg) } + +misplacedInstSig :: Name -> LHsType Name -> SDoc +misplacedInstSig name hs_ty + = vcat [ hang (ptext (sLit "Illegal type signature in instance declaration:")) + 2 (hang (pprPrefixName name) + 2 (dcolon <+> ppr hs_ty)) + , ptext (sLit "(Use InstanceSigs to allow this)") ] + +{- +Note [Instance method signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +With -XInstanceSigs we allow the user to supply a signature for the +method in an instance declaration. Here is an artificial example: + + data Age = MkAge Int + instance Ord Age where + compare :: a -> a -> Bool + compare = error "You can't compare Ages" + +The instance signature can be *more* polymorphic than the instantiated +class method (in this case: Age -> Age -> Bool), but it cannot be less +polymorphic. Moreover, if a signature is given, the implementation +code should match the signature, and type variables bound in the +singature should scope over the method body. + +We achieve this by building a TcSigInfo for the method, whether or not +there is an instance method signature, and using that to typecheck +the declaration (in tcMethodBody). That means, conveniently, +that the type variables bound in the signature will scope over the body. + +What about the check that the instance method signature is more +polymorphic than the instantiated class method type? We just do a +tcSubType call in mkMethIds, and use the HsWrapper thus generated in +the method AbsBind. It's very like the tcSubType impedence-matching +call in mkExport. We have to pass the HsWrapper into +tcMethodBody. +-} + +---------------------- +mk_meth_spec_prags :: Id -> [LTcSpecPrag] -> [LTcSpecPrag] -> TcSpecPrags + -- Adapt the 'SPECIALISE instance' pragmas to work for this method Id + -- There are two sources: + -- * spec_prags_for_me: {-# SPECIALISE op :: <blah> #-} + -- * spec_prags_from_inst: derived from {-# SPECIALISE instance :: <blah> #-} + -- These ones have the dfun inside, but [perhaps surprisingly] + -- the correct wrapper. +mk_meth_spec_prags meth_id spec_inst_prags spec_prags_for_me + = SpecPrags (spec_prags_for_me ++ spec_prags_from_inst) + where + spec_prags_from_inst + | isInlinePragma (idInlinePragma meth_id) + = [] -- Do not inherit SPECIALISE from the instance if the + -- method is marked INLINE, because then it'll be inlined + -- and the specialisation would do nothing. (Indeed it'll provoke + -- a warning from the desugarer + | otherwise + = [ L inst_loc (SpecPrag meth_id wrap inl) + | L inst_loc (SpecPrag _ wrap inl) <- spec_inst_prags] - -- check if one of the minimal complete definitions is satisfied - checkMinimalDefinition - = whenIsJust (isUnsatisfied methodExists (classMinimalDef clas)) $ - warnUnsatisifiedMinimalDefinition - where - methodExists meth = isJust (findMethodBind meth binds) mkGenericDefMethBind :: Class -> [Type] -> Id -> Name -> TcM (LHsBind Name) mkGenericDefMethBind clas inst_tys sel_id dm_name @@ -1525,12 +1596,9 @@ mkGenericDefMethBind clas inst_tys sel_id dm_name rhs = nlHsVar dm_name ---------------------- -wrapId :: HsWrapper -> id -> HsExpr id -wrapId wrapper id = mkHsWrap wrapper (HsVar id) - -derivBindCtxt :: Id -> Class -> [Type ] -> LHsBind Name -> SDoc -derivBindCtxt sel_id clas tys _bind - = vcat [ ptext (sLit "When typechecking the code for ") <+> quotes (ppr sel_id) +derivBindCtxt :: Id -> Class -> [Type ] -> SDoc +derivBindCtxt sel_id clas tys + = vcat [ ptext (sLit "When typechecking the code for") <+> quotes (ppr sel_id) , nest 2 (ptext (sLit "in a derived instance for") <+> quotes (pprClassPred clas tys) <> colon) , nest 2 $ ptext (sLit "To see the code I am typechecking, use -ddump-deriv") ] @@ -1659,6 +1727,93 @@ Note carefully: ************************************************************************ * * + Specialise instance pragmas +* * +************************************************************************ + +Note [SPECIALISE instance pragmas] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + instance (Ix a, Ix b) => Ix (a,b) where + {-# SPECIALISE instance Ix (Int,Int) #-} + range (x,y) = ... + +We make a specialised version of the dictionary function, AND +specialised versions of each *method*. Thus we should generate +something like this: + + $dfIxPair :: (Ix a, Ix b) => Ix (a,b) + {-# DFUN [$crangePair, ...] #-} + {-# SPECIALISE $dfIxPair :: Ix (Int,Int) #-} + $dfIxPair da db = Ix ($crangePair da db) (...other methods...) + + $crange :: (Ix a, Ix b) -> ((a,b),(a,b)) -> [(a,b)] + {-# SPECIALISE $crange :: ((Int,Int),(Int,Int)) -> [(Int,Int)] #-} + $crange da db = <blah> + +The SPECIALISE pragmas are acted upon by the desugarer, which generate + + dii :: Ix Int + dii = ... + + $s$dfIxPair :: Ix ((Int,Int),(Int,Int)) + {-# DFUN [$crangePair di di, ...] #-} + $s$dfIxPair = Ix ($crangePair di di) (...) + + {-# RULE forall (d1,d2:Ix Int). $dfIxPair Int Int d1 d2 = $s$dfIxPair #-} + + $s$crangePair :: ((Int,Int),(Int,Int)) -> [(Int,Int)] + $c$crangePair = ...specialised RHS of $crangePair... + + {-# RULE forall (d1,d2:Ix Int). $crangePair Int Int d1 d2 = $s$crangePair #-} + +Note that + + * The specialised dictionary $s$dfIxPair is very much needed, in case we + call a function that takes a dictionary, but in a context where the + specialised dictionary can be used. See Trac #7797. + + * The ClassOp rule for 'range' works equally well on $s$dfIxPair, because + it still has a DFunUnfolding. See Note [ClassOp/DFun selection] + + * A call (range ($dfIxPair Int Int d1 d2)) might simplify two ways: + --> {ClassOp rule for range} $crangePair Int Int d1 d2 + --> {SPEC rule for $crangePair} $s$crangePair + or thus: + --> {SPEC rule for $dfIxPair} range $s$dfIxPair + --> {ClassOpRule for range} $s$crangePair + It doesn't matter which way. + + * We want to specialise the RHS of both $dfIxPair and $crangePair, + but the SAME HsWrapper will do for both! We can call tcSpecPrag + just once, and pass the result (in spec_inst_info) to tcMethods. +-} + +tcSpecInstPrags :: DFunId -> InstBindings Name + -> TcM ([Located TcSpecPrag], PragFun) +tcSpecInstPrags dfun_id (InstBindings { ib_binds = binds, ib_pragmas = uprags }) + = do { spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) $ + filter isSpecInstLSig uprags + -- The filter removes the pragmas for methods + ; return (spec_inst_prags, mkPragFun uprags binds) } + +------------------------------ +tcSpecInst :: Id -> Sig Name -> TcM TcSpecPrag +tcSpecInst dfun_id prag@(SpecInstSig hs_ty) + = addErrCtxt (spec_ctxt prag) $ + do { (tyvars, theta, clas, tys) <- tcHsInstHead SpecInstCtxt hs_ty + ; let spec_dfun_ty = mkDictFunTy tyvars theta clas tys + ; co_fn <- tcSubType SpecInstCtxt (idType dfun_id) spec_dfun_ty + ; return (SpecPrag dfun_id co_fn defaultInlinePragma) } + where + spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag) + +tcSpecInst _ _ = panic "tcSpecInst" + +{- +************************************************************************ +* * \subsection{Error messages} * * ************************************************************************ diff --git a/compiler/typecheck/TcInteract.hs b/compiler/typecheck/TcInteract.hs index 79a61a306a..d38036c7af 100644 --- a/compiler/typecheck/TcInteract.hs +++ b/compiler/typecheck/TcInteract.hs @@ -39,6 +39,7 @@ import Data.List( partition, foldl', deleteFirstsBy ) import VarEnv import Control.Monad +import Maybes( isJust ) import Pair (Pair(..)) import Unique( hasKey ) import FastString ( sLit ) @@ -109,7 +110,6 @@ to float. This means that Note [Running plugins on unflattened wanteds] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - There is an annoying mismatch between solveSimpleGivens and solveSimpleWanteds, because the latter needs to fiddle with the inert set, unflatten and and zonk the wanteds. It passes the zonked wanteds @@ -151,6 +151,7 @@ solveSimpleWanteds = go emptyBag ; (wanteds', insols', rerun) <- runTcPluginsWanted zonked -- See Note [Running plugins on unflattened wanteds] ; let all_insols = insols0 `unionBags` insols `unionBags` insols' + ; if rerun then do { updInertTcS prepareInertsForImplications ; go all_insols wanteds' } else return (WC { wc_simple = wanteds' @@ -220,7 +221,7 @@ runTcPluginsWanted zonked_wanteds where setEv :: (EvTerm,Ct) -> TcS () setEv (ev,ct) = case ctEvidence ct of - CtWanted {ctev_evar = evar} -> setEvBind evar ev + CtWanted {ctev_evar = evar} -> setWantedEvBind evar ev _ -> panic "runTcPluginsWanted.setEv: attempt to solve non-wanted!" -- | A triple of (given, derived, wanted) constraints to pass to plugins @@ -476,26 +477,37 @@ solveOneFromTheOther ev_i ev_w = return (IRDelete, False) | CtWanted { ctev_evar = ev_id } <- ev_w - = do { setEvBind ev_id (ctEvTerm ev_i) + = do { setWantedEvBind ev_id (ctEvTerm ev_i) ; return (IRKeep, True) } | CtWanted { ctev_evar = ev_id } <- ev_i - = do { setEvBind ev_id (ctEvTerm ev_w) + = do { setWantedEvBind ev_id (ctEvTerm ev_w) ; return (IRReplace, True) } - | otherwise -- Both are Given - = return (if use_replacement then IRReplace else IRKeep, True) + -- So they are both Given + -- See Note [Replacement vs keeping] + | lvl_i == lvl_w + = do { binds <- getTcEvBindsMap + ; if has_binding binds ev_w && not (has_binding binds ev_i) + then return (IRReplace, True) + else return (IRKeep, True) } - where - pred = ctEvPred ev_i - loc_i = ctEvLoc ev_i - loc_w = ctEvLoc ev_w - lvl_i = ctLocLevel loc_i - lvl_w = ctLocLevel loc_w + | otherwise -- Both are Given + = return (if use_replacement then IRReplace else IRKeep, True) + where + pred = ctEvPred ev_i + loc_i = ctEvLoc ev_i + loc_w = ctEvLoc ev_w + lvl_i = ctLocLevel loc_i + lvl_w = ctLocLevel loc_w - use_replacement -- See Note [Replacement vs keeping] - | isIPPred pred = lvl_w > lvl_i - | otherwise = lvl_w < lvl_i + has_binding binds ev + | EvId v <- ctEvTerm ev = isJust (lookupEvBind binds v) + | otherwise = True + + use_replacement + | isIPPred pred = lvl_w > lvl_i + | otherwise = lvl_w < lvl_i {- Note [Replacement vs keeping] @@ -509,10 +521,23 @@ we keep? * For everything else, we want to keep the outermost one. Reason: that makes it more likely that the inner one will turn out to be unused, - and can be reported as redundant. + and can be reported as redundant. See Note [Tracking redundant constraints] + in TcSimplify. + + It transpires that using the outermost one is reponsible for an + 8% performance improvement in nofib cryptarithm2, compared to + just rolling the dice. I didn't investigate why. + + * If there is no "outermost" one, we keep the one that has a non-trivial + evidence binding. Note [Tracking redundant constraints] again. + Example: f :: (Eq a, Ord a) => blah + then we may find [G] sc_sel (d1::Ord a) :: Eq a + [G] d2 :: Eq a + We want to discard d2 in favour of the superclass selection from + the Ord dictionary. -When there is a choice, use IRKeep rather than IRReplace, to avoid unnecesary -munging of the inert set. + * Finally, when there is still a choice, use IRKeep rather than + IRReplace, to avoid unnecesary munging of the inert set. Doing the depth-check for implicit parameters, rather than making the work item always overrride, is important. Consider @@ -872,8 +897,7 @@ interactTyVarEq inerts workItem@(CTyEqCan { cc_tyvar = tv , rhs_i `tcEqType` rhs ] = -- Inert: a ~ b -- Work item: a ~ b - do { when (isWanted ev) $ - setEvBind (ctev_evar ev) (ctEvTerm ev_i) + do { setEvBindIfWanted ev (ctEvTerm ev_i) ; stopWith ev "Solved from inert" } | Just tv_rhs <- getTyVar_maybe rhs @@ -883,8 +907,7 @@ interactTyVarEq inerts workItem@(CTyEqCan { cc_tyvar = tv , rhs_i `tcEqType` mkTyVarTy tv ] = -- Inert: a ~ b -- Work item: b ~ a - do { when (isWanted ev) $ - setEvBind (ctev_evar ev) + do { setEvBindIfWanted ev (EvCoercion (mkTcSymCo (ctEvCoercion ev_i))) ; stopWith ev "Solved from inert (r)" } @@ -974,8 +997,7 @@ solveByUnification wd tv xi -- cf TcUnify.uUnboundKVar ; setWantedTyBind tv xi' - ; when (isWanted wd) $ - setEvBind (ctEvId wd) (EvCoercion (mkTcNomReflCo xi')) } + ; setEvBindIfWanted wd (EvCoercion (mkTcNomReflCo xi')) } ppr_kicked :: Int -> SDoc @@ -1227,7 +1249,7 @@ doTopReactDict inerts work_item@(CDictCan { cc_ev = fl, cc_class = cls = try_fundeps_and_return | Just ev <- lookupSolvedDict inerts loc cls xis -- Cached - = do { setEvBind dict_id (ctEvTerm ev); + = do { setWantedEvBind dict_id (ctEvTerm ev); ; stopWith fl "Dict/Top (cached)" } | otherwise -- Not cached @@ -1247,12 +1269,12 @@ doTopReactDict inerts work_item@(CDictCan { cc_ev = fl, cc_class = cls | null evs = do { traceTcS "doTopReact/found nullary instance for" $ ppr dict_id - ; setEvBind dict_id ev_term + ; setWantedEvBind dict_id ev_term ; stopWith fl "Dict/Top (solved, no new work)" } | otherwise = do { traceTcS "doTopReact/found non-nullary instance for" $ ppr dict_id - ; setEvBind dict_id ev_term + ; setWantedEvBind dict_id ev_term ; let mk_new_wanted ev = mkNonCanonical (ev {ctev_loc = bumpCtLocDepth CountConstraints loc }) ; updWorkListTcS (extendWorkListCts (map mk_new_wanted evs)) @@ -1378,7 +1400,7 @@ shortCutReduction old_ev fsk ax_co fam_tc tc_args -- old_ev :: F args ~ fsk := ax_co ; sym (G cos) ; new_ev ; new_ev <- newWantedEvVarNC loc (mkTcEqPred (mkTyConApp fam_tc xis) (mkTyVarTy fsk)) - ; setEvBind (ctEvId old_ev) + ; setWantedEvBind (ctEvId old_ev) (EvCoercion (ax_co `mkTcTransCo` mkTcSymCo (mkTcTyConAppCo Nominal fam_tc cos) `mkTcTransCo` ctEvCoercion new_ev)) @@ -1401,7 +1423,7 @@ dischargeFmv :: EvVar -> TcTyVar -> TcCoercion -> TcType -> TcS () dischargeFmv evar fmv co xi = ASSERT2( not (fmv `elemVarSet` tyVarsOfType xi), ppr evar $$ ppr fmv $$ ppr xi ) do { setWantedTyBind fmv xi - ; setEvBind evar (EvCoercion co) + ; setWantedEvBind evar (EvCoercion co) ; n_kicked <- kickOutRewritable Given NomEq fmv ; traceTcS "dischargeFuv" (ppr fmv <+> equals <+> ppr xi $$ ppr_kicked n_kicked) } diff --git a/compiler/typecheck/TcMType.hs b/compiler/typecheck/TcMType.hs index d740f7c8cf..71fc8ffa33 100644 --- a/compiler/typecheck/TcMType.hs +++ b/compiler/typecheck/TcMType.hs @@ -30,7 +30,6 @@ module TcMType ( -- Creating new evidence variables newEvVar, newEvVars, newEq, newDict, newTcEvBinds, addTcEvBind, - newSimpleWanted, newSimpleWanteds, -------------------------------- -- Instantiation @@ -147,25 +146,6 @@ predTypeOccName ty = case classifyPredType ty of TuplePred _ -> mkVarOccFS (fsLit "tup") IrredPred _ -> mkVarOccFS (fsLit "irred") -{- -********************************************************************************* -* * -* Wanted constraints -* * -********************************************************************************* --} - -newSimpleWanted :: CtOrigin -> PredType -> TcM Ct -newSimpleWanted orig pty - = do loc <- getCtLoc orig - v <- newEvVar pty - return $ mkNonCanonical $ - CtWanted { ctev_evar = v - , ctev_pred = pty - , ctev_loc = loc } - -newSimpleWanteds :: CtOrigin -> ThetaType -> TcM [Ct] -newSimpleWanteds orig = mapM (newSimpleWanted orig) {- ************************************************************************ @@ -742,7 +722,7 @@ zonkTcPredType = zonkTcType ************************************************************************ -} -zonkImplication :: Implication -> TcM (Bag Implication) +zonkImplication :: Implication -> TcM Implication zonkImplication implic@(Implic { ic_skols = skols , ic_given = given , ic_wanted = wanted @@ -752,13 +732,10 @@ zonkImplication implic@(Implic { ic_skols = skols ; given' <- mapM zonkEvVar given ; info' <- zonkSkolemInfo info ; wanted' <- zonkWCRec wanted - ; if isEmptyWC wanted' - then return emptyBag - else return $ unitBag $ - implic { ic_skols = skols' - , ic_given = given' - , ic_wanted = wanted' - , ic_info = info' } } + ; return (implic { ic_skols = skols' + , ic_given = given' + , ic_wanted = wanted' + , ic_info = info' }) } zonkEvVar :: EvVar -> TcM EvVar zonkEvVar var = do { ty' <- zonkTcType (varType var) @@ -771,7 +748,7 @@ zonkWC wc = zonkWCRec wc zonkWCRec :: WantedConstraints -> TcM WantedConstraints zonkWCRec (WC { wc_simple = simple, wc_impl = implic, wc_insol = insol }) = do { simple' <- zonkSimples simple - ; implic' <- flatMapBagM zonkImplication implic + ; implic' <- mapBagM zonkImplication implic ; insol' <- zonkSimples insol ; return (WC { wc_simple = simple', wc_impl = implic', wc_insol = insol' }) } diff --git a/compiler/typecheck/TcMatches.hs b/compiler/typecheck/TcMatches.hs index dda97d19ed..af80e2e8c1 100644 --- a/compiler/typecheck/TcMatches.hs +++ b/compiler/typecheck/TcMatches.hs @@ -79,7 +79,7 @@ tcMatchesFun fun_name inf matches exp_ty ; checkArgs fun_name matches ; (wrap_gen, (wrap_fun, group)) - <- tcGen (FunSigCtxt fun_name) exp_ty $ \ _ exp_rho -> + <- tcGen (FunSigCtxt fun_name True) exp_ty $ \ _ exp_rho -> -- Note [Polymorphic expected type for tcMatchesFun] matchFunTys herald arity exp_rho $ \ pat_tys rhs_ty -> tcMatches match_ctxt pat_tys rhs_ty matches diff --git a/compiler/typecheck/TcPat.hs b/compiler/typecheck/TcPat.hs index a8889b545f..819d3ecc94 100644 --- a/compiler/typecheck/TcPat.hs +++ b/compiler/typecheck/TcPat.hs @@ -28,7 +28,6 @@ import Var import Name import NameSet import TcEnv ---import TcExpr import TcMType import TcValidity( arityErr ) import TcType @@ -120,10 +119,10 @@ data LetBndrSpec = LetLclBndr -- The binder is just a local one; -- an AbsBinds will provide the global version - | LetGblBndr TcPragFun -- Genrealisation plan is NoGen, so there isn't going + | LetGblBndr TcPragFun -- Generalisation plan is NoGen, so there isn't going -- to be an AbsBinds; So we must bind the global version -- of the binder right away. - -- Oh, and dhhere is the inline-pragma information + -- Oh, and here is the inline-pragma information makeLazy :: PatEnv -> PatEnv makeLazy penv = penv { pe_lazy = True } @@ -162,8 +161,17 @@ data TcSigInfo sig_loc :: SrcSpan, -- The location of the signature - sig_partial :: Bool -- True <=> a partial type signature + sig_partial :: Bool, -- True <=> a partial type signature -- containing wildcards + + sig_warn_redundant :: Bool -- True <=> report redundant constraints + -- when typechecking the value binding + -- for this type signature + -- This is usually True, but False for + -- * Record selectors (not important here) + -- * Class and instance methods. Here the code may legitimately + -- be more polymorphic than the signature generated from the + -- class declaration } | TcPatSynInfo TcPatSynInfo @@ -290,8 +298,7 @@ tcPatBndr (PE { pe_ctxt = LetPat lookup_sig no_gen}) bndr_name pat_ty ; return (mkTcNomReflCo pat_ty, bndr_id) } tcPatBndr (PE { pe_ctxt = _lam_or_proc }) bndr_name pat_ty - = do { bndr <- mkLocalBinder bndr_name pat_ty - ; return (mkTcNomReflCo pat_ty, bndr) } + = return (mkTcNomReflCo pat_ty, mkLocalId bndr_name pat_ty) ------------ newNoSigLetBndr :: LetBndrSpec -> Name -> TcType -> TcM TcId @@ -302,10 +309,9 @@ newNoSigLetBndr :: LetBndrSpec -> Name -> TcType -> TcM TcId -- use the original name directly newNoSigLetBndr LetLclBndr name ty =do { mono_name <- newLocalName name - ; mkLocalBinder mono_name ty } + ; return (mkLocalId mono_name ty) } newNoSigLetBndr (LetGblBndr prags) name ty - = do { id <- mkLocalBinder name ty - ; addInlinePrags id (prags name) } + = addInlinePrags (mkLocalId name ty) (prags name) ---------- addInlinePrags :: TcId -> [LSig Name] -> TcM TcId @@ -331,11 +337,6 @@ warnPrags id bad_sigs herald where ppr_sigs sigs = vcat (map (ppr . getLoc) sigs) ------------------ -mkLocalBinder :: Name -> TcType -> TcM TcId -mkLocalBinder name ty - = return (Id.mkLocalId name ty) - {- Note [Typing patterns in pattern bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs index 92877575ea..f572f78ae0 100644 --- a/compiler/typecheck/TcPatSyn.hs +++ b/compiler/typecheck/TcPatSyn.hs @@ -67,9 +67,8 @@ tcInferPatSynDecl PSB{ psb_id = lname@(L loc name), psb_args = details, ; let (arg_names, is_infix) = case details of PrefixPatSyn names -> (map unLoc names, False) InfixPatSyn name1 name2 -> (map unLoc [name1, name2], True) - ; (((lpat', (args, pat_ty)), tclvl), wanted) - <- captureConstraints $ - captureTcLevel $ + ; ((lpat', (args, pat_ty)), tclvl, wanted) + <- pushLevelAndCaptureConstraints $ do { pat_ty <- newFlexiTyVarTy openTypeKind ; tcPat PatSyn lpat pat_ty $ do { args <- mapM tcLookupId arg_names @@ -120,7 +119,7 @@ tcCheckPatSynDecl PSB{ psb_id = lname@(L loc name), psb_args = details, ; req_dicts <- newEvVars req_theta -- TODO: find a better SkolInfo - ; let skol_info = SigSkol (FunSigCtxt name) (mkFunTys arg_tys pat_ty) + ; let skol_info = SigSkol (FunSigCtxt name True) (mkFunTys arg_tys pat_ty) ; let (arg_names, is_infix) = case details of PrefixPatSyn names -> (map unLoc names, False) @@ -373,6 +372,7 @@ tcPatSynBuilderBind PSB{ psb_id = L loc name, psb_def = lpat , sig_loc = noSrcSpan , sig_extra_cts = Nothing , sig_partial = False + , sig_warn_redundant = False -- See Note [Redundant constraints for builder] , sig_nwcs = [] } @@ -416,6 +416,14 @@ tcPatSynBuilderOcc orig ps builder = patSynBuilder ps {- +Note [Redundant constraints for builder] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The builder can have redundant constraints, which are awkard to eliminate. +Consider + pattern P = Just 34 +To match against this pattern we need (Eq a, Num a). But to build +(Just 34) we need only (Num a). + ************************************************************************ * * Helper functions diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs index 8cfd43c6fc..b78b69d8be 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -1759,9 +1759,8 @@ tcRnExpr hsc_env rdr_expr -- it might have a rank-2 type (e.g. :t runST) uniq <- newUnique ; let { fresh_it = itName uniq (getLoc rdr_expr) } ; - (((_tc_expr, res_ty), tclvl), lie) <- captureConstraints $ - captureTcLevel $ - tcInferRho rn_expr ; + ((_tc_expr, res_ty), tclvl, lie) <- pushLevelAndCaptureConstraints $ + tcInferRho rn_expr ; ((qtvs, dicts, _, _), lie_top) <- captureConstraints $ {-# SCC "simplifyInfer" #-} simplifyInfer tclvl diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs index 44c71e4a19..31391e4082 100644 --- a/compiler/typecheck/TcRnMonad.hs +++ b/compiler/typecheck/TcRnMonad.hs @@ -32,7 +32,6 @@ import InstEnv import FamInstEnv import PrelNames -import Var import Id import VarSet import VarEnv @@ -1096,13 +1095,12 @@ newTcEvBinds = do { ref <- newTcRef emptyEvBindMap ; uniq <- newUnique ; return (EvBindsVar ref uniq) } -addTcEvBind :: EvBindsVar -> EvVar -> EvTerm -> TcM () +addTcEvBind :: EvBindsVar -> EvBind -> TcM () -- Add a binding to the TcEvBinds by side effect -addTcEvBind (EvBindsVar ev_ref _) ev_id ev_tm - = do { traceTc "addTcEvBind" $ vcat [ text "ev_id =" <+> ppr ev_id - , text "ev_tm =" <+> ppr ev_tm ] +addTcEvBind (EvBindsVar ev_ref _) ev_bind + = do { traceTc "addTcEvBind" $ ppr ev_bind ; bnds <- readTcRef ev_ref - ; writeTcRef ev_ref (extendEvBinds bnds ev_id ev_tm) } + ; writeTcRef ev_ref (extendEvBinds bnds ev_bind) } getTcEvBinds :: EvBindsVar -> TcM (Bag EvBind) getTcEvBinds (EvBindsVar ev_ref _) @@ -1165,24 +1163,31 @@ captureConstraints thing_inside lie <- readTcRef lie_var ; return (res, lie) } -captureTcLevel :: TcM a -> TcM (a, TcLevel) -captureTcLevel thing_inside +pushLevelAndCaptureConstraints :: TcM a -> TcM (a, TcLevel, WantedConstraints) +pushLevelAndCaptureConstraints thing_inside = do { env <- getLclEnv + ; lie_var <- newTcRef emptyWC ; ; let tclvl' = pushTcLevel (tcl_tclvl env) - ; res <- setLclEnv (env { tcl_tclvl = tclvl' }) + ; res <- setLclEnv (env { tcl_tclvl = tclvl' + , tcl_lie = lie_var }) thing_inside - ; return (res, tclvl') } + ; lie <- readTcRef lie_var + ; return (res, tclvl', lie) } + +pushTcLevelM_ :: TcM a -> TcM a +pushTcLevelM_ = updLclEnv (\ env -> env { tcl_tclvl = pushTcLevel (tcl_tclvl env) }) -pushTcLevelM :: TcM a -> TcM a +pushTcLevelM :: TcM a -> TcM (a, TcLevel) pushTcLevelM thing_inside = do { env <- getLclEnv ; let tclvl' = pushTcLevel (tcl_tclvl env) - ; setLclEnv (env { tcl_tclvl = tclvl' }) - thing_inside } + ; res <- setLclEnv (env { tcl_tclvl = tclvl' }) + thing_inside + ; return (res, tclvl') } getTcLevel :: TcM TcLevel getTcLevel = do { env <- getLclEnv - ; return (tcl_tclvl env) } + ; return (tcl_tclvl env) } setTcLevel :: TcLevel -> TcM a -> TcM a setTcLevel tclvl thing_inside diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs index 5b77ebe0cf..90aba1dc88 100644 --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs @@ -61,9 +61,9 @@ module TcRnTypes( WantedConstraints(..), insolubleWC, emptyWC, isEmptyWC, andWC, unionsWC, addSimples, addImplics, mkSimpleWC, addInsols, - dropDerivedWC, + dropDerivedWC, insolubleImplic, trulyInsoluble, - Implication(..), + Implication(..), ImplicStatus(..), isInsolubleStatus, SubGoalCounter(..), SubGoalDepth, initialSubGoalDepth, maxSubGoalDepth, bumpSubGoalDepth, subGoalCounterValue, subGoalDepthExceeded, @@ -1413,22 +1413,16 @@ data WantedConstraints emptyWC :: WantedConstraints emptyWC = WC { wc_simple = emptyBag, wc_impl = emptyBag, wc_insol = emptyBag } -mkSimpleWC :: [Ct] -> WantedConstraints +mkSimpleWC :: [CtEvidence] -> WantedConstraints mkSimpleWC cts - = WC { wc_simple = listToBag cts, wc_impl = emptyBag, wc_insol = emptyBag } + = WC { wc_simple = listToBag (map mkNonCanonical cts) + , wc_impl = emptyBag + , wc_insol = emptyBag } isEmptyWC :: WantedConstraints -> Bool isEmptyWC (WC { wc_simple = f, wc_impl = i, wc_insol = n }) = isEmptyBag f && isEmptyBag i && isEmptyBag n -insolubleWC :: WantedConstraints -> Bool --- True if there are any insoluble constraints in the wanted bag. Ignore --- constraints arising from PartialTypeSignatures to solve as much of the --- constraints as possible before reporting the holes. -insolubleWC wc = not (isEmptyBag (filterBag (not . isTypeHoleCt) - (wc_insol wc))) - || anyBag ic_insol (wc_impl wc) - andWC :: WantedConstraints -> WantedConstraints -> WantedConstraints andWC (WC { wc_simple = f1, wc_impl = i1, wc_insol = n1 }) (WC { wc_simple = f2, wc_impl = i2, wc_insol = n2 }) @@ -1450,6 +1444,24 @@ addInsols :: WantedConstraints -> Bag Ct -> WantedConstraints addInsols wc cts = wc { wc_insol = wc_insol wc `unionBags` cts } +isInsolubleStatus :: ImplicStatus -> Bool +isInsolubleStatus IC_Insoluble = True +isInsolubleStatus _ = False + +insolubleImplic :: Implication -> Bool +insolubleImplic ic = isInsolubleStatus (ic_status ic) + +insolubleWC :: WantedConstraints -> Bool +insolubleWC (WC { wc_impl = implics, wc_insol = insols }) + = anyBag trulyInsoluble insols + || anyBag insolubleImplic implics + +trulyInsoluble :: Ct -> Bool +-- The constraint is in the wc_insol set, but we do not +-- treat type-holes, arising from PartialTypeSignatures, +-- as "truly insoluble". Yuk. +trulyInsoluble insol = not (isTypeHoleCt insol) + instance Outputable WantedConstraints where ppr (WC {wc_simple = s, wc_impl = i, wc_insol = n}) = ptext (sLit "WC") <+> braces (vcat @@ -1488,32 +1500,63 @@ data Implication -- False <=> ic_givens might have equalities ic_env :: TcLclEnv, -- Gives the source location and error context - -- for the implicatdion, and hence for all the + -- for the implication, and hence for all the -- given evidence variables ic_wanted :: WantedConstraints, -- The wanted - ic_insol :: Bool, -- True iff insolubleWC ic_wanted is true - ic_binds :: EvBindsVar -- Points to the place to fill in the - -- abstraction and bindings + ic_binds :: EvBindsVar, -- Points to the place to fill in the + -- abstraction and bindings + + ic_status :: ImplicStatus } +data ImplicStatus + = IC_Solved -- All wanteds in the tree are solved, all the way down + { ics_need :: VarSet -- Evidence variables needed by this implication + , ics_dead :: [EvVar] } -- Subset of ic_given that are not needed + -- See Note [Tracking redundant constraints] in TcSimplify + + | IC_Insoluble -- At least one insoluble constraint in the tree + + | IC_Unsolved -- Neither of the above; might go either way + instance Outputable Implication where ppr (Implic { ic_tclvl = tclvl, ic_skols = skols , ic_given = given, ic_no_eqs = no_eqs - , ic_wanted = wanted, ic_insol = insol + , ic_wanted = wanted, ic_status = status , ic_binds = binds, ic_info = info }) = hang (ptext (sLit "Implic") <+> lbrace) 2 (sep [ ptext (sLit "TcLevel =") <+> ppr tclvl , ptext (sLit "Skolems =") <+> pprTvBndrs skols , ptext (sLit "No-eqs =") <+> ppr no_eqs - , ptext (sLit "Insol =") <+> ppr insol + , ptext (sLit "Status =") <+> ppr status , hang (ptext (sLit "Given =")) 2 (pprEvVars given) , hang (ptext (sLit "Wanted =")) 2 (ppr wanted) , ptext (sLit "Binds =") <+> ppr binds , pprSkolInfo info ] <+> rbrace) +instance Outputable ImplicStatus where + ppr IC_Insoluble = ptext (sLit "Insoluble") + ppr IC_Unsolved = ptext (sLit "Unsolved") + ppr (IC_Solved { ics_need = vs, ics_dead = dead }) + = ptext (sLit "Solved") + <+> (braces $ vcat [ ptext (sLit "Dead givens =") <+> ppr dead + , ptext (sLit "Needed =") <+> ppr vs ]) + {- +Note [Needed evidence variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Th ic_need_evs field holds the free vars of ic_binds, and all the +ic_binds in nested implications. + + * Main purpose: if one of the ic_givens is not mentioned in here, it + is redundant. + + * solveImplication may drop an implication altogether if it has no + remaining 'wanteds'. But we still track the free vars of its + evidence binds, even though it has now disappeared. + Note [Shadowing in a constraint] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We assume NO SHADOWING in a constraint. Specifically diff --git a/compiler/typecheck/TcRules.hs b/compiler/typecheck/TcRules.hs index 7e86e00f0c..17d548f8bf 100644 --- a/compiler/typecheck/TcRules.hs +++ b/compiler/typecheck/TcRules.hs @@ -166,29 +166,29 @@ tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs) -- Simplify the RHS constraints ; lcl_env <- getLclEnv ; rhs_binds_var <- newTcEvBinds - ; emitImplication $ Implic { ic_tclvl = topTcLevel - , ic_skols = qtkvs - , ic_no_eqs = False - , ic_given = lhs_evs - , ic_wanted = rhs_wanted - , ic_insol = insolubleWC rhs_wanted - , ic_binds = rhs_binds_var - , ic_info = RuleSkol (unLoc name) - , ic_env = lcl_env } + ; emitImplication $ Implic { ic_tclvl = topTcLevel + , ic_skols = qtkvs + , ic_no_eqs = False + , ic_given = lhs_evs + , ic_wanted = rhs_wanted + , ic_status = IC_Unsolved + , ic_binds = rhs_binds_var + , ic_info = RuleSkol (unLoc name) + , ic_env = lcl_env } -- For the LHS constraints we must solve the remaining constraints -- (a) so that we report insoluble ones -- (b) so that we bind any soluble ones ; lhs_binds_var <- newTcEvBinds - ; emitImplication $ Implic { ic_tclvl = topTcLevel - , ic_skols = qtkvs - , ic_no_eqs = False - , ic_given = lhs_evs - , ic_wanted = other_lhs_wanted - , ic_insol = insolubleWC other_lhs_wanted - , ic_binds = lhs_binds_var - , ic_info = RuleSkol (unLoc name) - , ic_env = lcl_env } + ; emitImplication $ Implic { ic_tclvl = topTcLevel + , ic_skols = qtkvs + , ic_no_eqs = False + , ic_given = lhs_evs + , ic_wanted = other_lhs_wanted + , ic_status = IC_Unsolved + , ic_binds = lhs_binds_var + , ic_info = RuleSkol (unLoc name) + , ic_env = lcl_env } ; return (HsRule name act (map (noLoc . RuleBndr . noLoc) (qtkvs ++ tpl_ids)) diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs index d7c58d502a..16ac1141a8 100644 --- a/compiler/typecheck/TcSMonad.hs +++ b/compiler/typecheck/TcSMonad.hs @@ -27,7 +27,7 @@ module TcSMonad ( newTcEvBinds, newWantedEvVar, newWantedEvVarNC, setWantedTyBind, reportUnifications, - setEvBind, + setEvBind, setWantedEvBind, setEvBindIfWanted, newEvVar, newGivenEvVar, newGivenEvVars, newDerived, emitNewDerived, @@ -1355,10 +1355,11 @@ checkForCyclicBinds ev_binds cycles = [c | CyclicSCC c <- stronglyConnCompFromEdgedVertices edges] coercion_cycles = [c | c <- cycles, any is_co_bind c] - is_co_bind (EvBind b _) = isEqVar b + is_co_bind (EvBind { eb_lhs = b }) = isEqVar b edges :: [(EvBind, EvVar, [EvVar])] - edges = [(bind, bndr, varSetElems (evVarsOfTerm rhs)) | bind@(EvBind bndr rhs) <- bagToList ev_binds] + edges = [(bind, bndr, varSetElems (evVarsOfTerm rhs)) + | bind@(EvBind { eb_lhs = bndr, eb_rhs = rhs }) <- bagToList ev_binds] #endif nestImplicTcS :: EvBindsVar -> TcLevel -> TcS a -> TcS a @@ -1760,10 +1761,19 @@ isFresh Cached = False freshGoals :: [(CtEvidence, Freshness)] -> [CtEvidence] freshGoals mns = [ ctev | (ctev, Fresh) <- mns ] -setEvBind :: EvVar -> EvTerm -> TcS () -setEvBind the_ev tm +setEvBind :: EvBind -> TcS () +setEvBind ev_bind = do { tc_evbinds <- getTcEvBinds - ; wrapTcS $ TcM.addTcEvBind tc_evbinds the_ev tm } + ; wrapTcS $ TcM.addTcEvBind tc_evbinds ev_bind } + +setWantedEvBind :: EvVar -> EvTerm -> TcS () +setWantedEvBind ev_id tm = setEvBind (mkWantedEvBind ev_id tm) + +setEvBindIfWanted :: CtEvidence -> EvTerm -> TcS () +setEvBindIfWanted ev tm + = case ev of + CtWanted { ctev_evar = ev_id } -> setWantedEvBind ev_id tm + _ -> return () newTcEvBinds :: TcS EvBindsVar newTcEvBinds = wrapTcS TcM.newTcEvBinds @@ -1780,7 +1790,7 @@ newGivenEvVar :: CtLoc -> (TcPredType, EvTerm) -> TcS CtEvidence newGivenEvVar loc (pred, rhs) = ASSERT2( not (isKindEquality pred), ppr pred $$ pprCtOrigin (ctLocOrigin loc) ) do { new_ev <- newEvVar pred - ; setEvBind new_ev rhs + ; setEvBind (mkGivenEvBind new_ev rhs) ; return (CtGiven { ctev_pred = pred, ctev_evtm = EvId new_ev, ctev_loc = loc }) } newGivenEvVars :: CtLoc -> [(TcPredType, EvTerm)] -> TcS [CtEvidence] @@ -1920,15 +1930,15 @@ deferTcSForAllEq role loc (tvs1,body1) (tvs2,body2) ; let wc = WC { wc_simple = singleCt new_ct , wc_impl = emptyBag , wc_insol = emptyCts } - imp = Implic { ic_tclvl = new_tclvl - , ic_skols = skol_tvs - , ic_no_eqs = True - , ic_given = [] - , ic_wanted = wc - , ic_insol = False - , ic_binds = ev_binds_var - , ic_env = env - , ic_info = skol_info } + imp = Implic { ic_tclvl = new_tclvl + , ic_skols = skol_tvs + , ic_no_eqs = True + , ic_given = [] + , ic_wanted = wc + , ic_status = IC_Unsolved + , ic_binds = ev_binds_var + , ic_env = env + , ic_info = skol_info } ; updWorkListTcS (extendWorkListImplic imp) ; return (TcLetCo ev_binds new_co) } diff --git a/compiler/typecheck/TcSimplify.hs b/compiler/typecheck/TcSimplify.hs index 68978dfc23..761a7a5ed4 100644 --- a/compiler/typecheck/TcSimplify.hs +++ b/compiler/typecheck/TcSimplify.hs @@ -40,6 +40,7 @@ import Control.Monad ( unless ) import DynFlags ( ExtensionFlag( Opt_AllowAmbiguousTypes ) ) import Class ( classKey ) import BasicTypes ( RuleName ) +import Maybes ( isNothing ) import Outputable import FastString import TrieMap () -- DV: for now @@ -217,7 +218,7 @@ simplifyDefault :: ThetaType -- Wanted; has no type variables in it -> TcM () -- Succeeds iff the constraint is soluble simplifyDefault theta = do { traceTc "simplifyInteractive" empty - ; wanted <- newSimpleWanteds DefaultOrigin theta + ; wanted <- newWanteds DefaultOrigin theta ; (unsolved, _binds) <- solveWantedsTcM (mkSimpleWC wanted) ; traceTc "reportUnsolved {" empty @@ -245,7 +246,7 @@ Consider To infer f's type we do the following: * Gather the constraints for the RHS with ambient level *one more than* the current one. This is done by the call - captureConstraints (captureTcLevel (tcMonoBinds...)) + pushLevelAndCaptureConstraints (tcMonoBinds...) in TcBinds.tcPolyInfer * Call simplifyInfer to simplify the constraints and decide what to @@ -365,7 +366,7 @@ simplifyInfer rhs_tclvl apply_mr name_taus wanteds , ic_no_eqs = False , ic_given = minimal_bound_ev_vars , ic_wanted = wanted_transformed - , ic_insol = False + , ic_status = IC_Unsolved , ic_binds = ev_binds_var , ic_info = skol_info , ic_env = tc_lcl_env } @@ -782,15 +783,14 @@ solveWanteds wanteds ; return final_wanteds } solveSimples :: WantedConstraints -> TcS WantedConstraints --- Solve the wc_simple and wc_insol components of the WantedConstraints +-- Solve the wc_simple component of the WantedConstraints +-- No point in looking at wc_insol because they are, well, insoluble -- Do not affect the inerts solveSimples (WC { wc_simple = simples, wc_insol = insols, wc_impl = implics }) = nestTcS $ - do { let all_simples = simples `unionBags` filterBag (not . isDerivedCt) insols - -- See Note [Dropping derived constraints] in TcRnTypes for - -- why the insolubles may have derived constraints - ; wc <- solveSimpleWanteds all_simples - ; return ( wc { wc_impl = implics `unionBags` wc_impl wc } ) } + do { wc <- solveSimpleWanteds simples + ; return ( wc { wc_impl = implics `unionBags` wc_impl wc + , wc_insol = insols `unionBags` wc_insol wc } ) } simpl_loop :: Int -> WantedConstraints @@ -833,17 +833,9 @@ solveNestedImplications implics | isEmptyBag implics = return (emptyBag, emptyBag) | otherwise - = do { --- inerts <- getTcSInerts --- ; let thinner_inerts = prepareInertsForImplications inerts --- -- See Note [Preparing inert set for implications] --- - traceTcS "solveNestedImplications starting {" empty --- vcat [ text "original inerts = " <+> ppr inerts --- , text "thinner_inerts = " <+> ppr thinner_inerts ] - - ; (floated_eqs, unsolved_implics) - <- flatMapBagPairM solveImplication implics + = do { traceTcS "solveNestedImplications starting {" empty + ; (floated_eqs_s, unsolved_implics) <- mapAndUnzipBagM solveImplication implics + ; let floated_eqs = concatBag floated_eqs_s -- ... and we are back in the original TcS inerts -- Notice that the original includes the _insoluble_simples so it was safe to ignore @@ -852,11 +844,11 @@ solveNestedImplications implics vcat [ text "all floated_eqs =" <+> ppr floated_eqs , text "unsolved_implics =" <+> ppr unsolved_implics ] - ; return (floated_eqs, unsolved_implics) } + ; return (floated_eqs, catBagMaybes unsolved_implics) } solveImplication :: Implication -- Wanted -> TcS (Cts, -- All wanted or derived floated equalities: var = type - Bag Implication) -- Unsolved rest (always empty or singleton) + Maybe Implication) -- Simplified implication (empty or singleton) -- Precondition: The TcS monad contains an empty worklist and given-only inerts -- which after trying to solve this implication we must restore to their original value solveImplication imp@(Implic { ic_tclvl = tclvl @@ -865,7 +857,15 @@ solveImplication imp@(Implic { ic_tclvl = tclvl , ic_given = givens , ic_wanted = wanteds , ic_info = info + , ic_status = status , ic_env = env }) + | IC_Solved {} <- status + = return (emptyCts, Just imp) -- Do nothing + + | otherwise -- Even for IC_Insoluble it is worth doing more work + -- The insoluble stuff might be in one sub-implication + -- and other unsolved goals in another; and we want to + -- solve the latter as much as possible = do { inerts <- getTcSInerts ; traceTcS "solveImplication {" (ppr imp $$ text "Inerts" <+> ppr inerts) @@ -886,15 +886,8 @@ solveImplication imp@(Implic { ic_tclvl = tclvl ; (floated_eqs, final_wanted) <- floatEqualities skols no_given_eqs residual_wanted - ; let res_implic | isEmptyWC final_wanted -- && no_given_eqs - = emptyBag -- Reason for the no_given_eqs: we don't want to - -- lose the "inaccessible code" error message - -- BUT: final_wanted still has the derived insolubles - -- so it should be fine - | otherwise - = unitBag (imp { ic_no_eqs = no_given_eqs - , ic_wanted = dropDerivedWC final_wanted - , ic_insol = insolubleWC final_wanted }) + ; res_implic <- setImplicationStatus (imp { ic_no_eqs = no_given_eqs + , ic_wanted = final_wanted }) ; evbinds <- getTcEvBindsMap ; traceTcS "solveImplication end }" $ vcat @@ -905,7 +898,213 @@ solveImplication imp@(Implic { ic_tclvl = tclvl ; return (floated_eqs, res_implic) } +---------------------- +setImplicationStatus :: Implication -> TcS (Maybe Implication) +-- Finalise the implication returned from solveImplication: +-- * Set the ic_status field +-- * Trim the ic_wanted field +-- Return Nothing if we can discard the implication altogether +setImplicationStatus implic@(Implic { ic_binds = EvBindsVar ev_binds_var _ + , ic_info = info + , ic_wanted = wc, ic_given = givens }) + | some_insoluble + = return $ Just $ + implic { ic_status = IC_Insoluble + , ic_wanted = trimmed_wc } + + | some_unsolved + = return $ Just $ + implic { ic_status = IC_Unsolved + , ic_wanted = trimmed_wc } + + | otherwise -- Everything is solved; look at the implications + -- See Note [Tracking redundant constraints] + = do { ev_binds <- TcS.readTcRef ev_binds_var + ; let all_needs = neededEvVars ev_binds implic_needs + + dead_givens | warnRedundantGivens info + = filterOut (`elemVarSet` all_needs) givens + | otherwise = [] -- None to report + + final_needs = all_needs `delVarSetList` givens + + discard_implic -- Can we discard the entire implication? + = null dead_givens -- No warning from this implication + && isEmptyBag keep_implics -- No live children + && isEmptyVarSet final_needs -- No needed vars to pass up to parent + + final_implic = implic { ic_status = IC_Solved { ics_need = final_needs + , ics_dead = dead_givens } + , ic_wanted = trimmed_wc } + + ; return $ if discard_implic then Nothing else Just final_implic } + where + WC { wc_simple = simples, wc_impl = implics, wc_insol = insols } = wc + trimmed_wc = wc { wc_simple = drop_der_simples + , wc_impl = keep_implics } + + some_insoluble = insolubleWC wc + some_unsolved = not (isEmptyBag simples && isEmptyBag insols) + || isNothing mb_implic_needs + + drop_der_simples = filterBag isWantedCt simples + keep_implics = filterBag need_to_keep_implic implics + + mb_implic_needs :: Maybe VarSet + -- Just vs => all implics are IC_Solved, with 'vs' needed + -- Nothing => at least one implic is not IC_Solved + mb_implic_needs = foldrBag add_implic (Just emptyVarSet) implics + Just implic_needs = mb_implic_needs + + add_implic implic acc + | Just vs_acc <- acc + , IC_Solved { ics_need = vs } <- ic_status implic + = Just (vs `unionVarSet` vs_acc) + | otherwise = Nothing + + need_to_keep_implic ic + | IC_Solved { ics_dead = [] } <- ic_status ic + -- Fully solved, and no redundant givens to report + , isEmptyBag (wc_impl (ic_wanted ic)) + -- And no children that might have things to report + = False + | otherwise + = True + +warnRedundantGivens :: SkolemInfo -> Bool +warnRedundantGivens (SigSkol ctxt _) + = case ctxt of + FunSigCtxt _ warn_redundant -> warn_redundant + ExprSigCtxt -> True + _ -> False +warnRedundantGivens InstSkol = True +warnRedundantGivens _ = False + +neededEvVars :: EvBindMap -> VarSet -> VarSet +-- Find all the evidence variables that are "needed", +-- and then delete all those bound by the evidence bindings +-- A variable is "needed" if +-- a) it is free in the RHS of a Wanted EvBind (add_wanted) +-- b) it is free in the RHS of an EvBind whose LHS is needed (transClo) +-- c) it is in the ic_need_evs of a nested implication (initial_seeds) +-- (after removing the givens) +neededEvVars ev_binds initial_seeds + = needed `minusVarSet` bndrs + where + seeds = foldEvBindMap add_wanted initial_seeds ev_binds + needed = transCloVarSet also_needs seeds + bndrs = foldEvBindMap add_bndr emptyVarSet ev_binds + + add_wanted :: EvBind -> VarSet -> VarSet + add_wanted (EvBind { eb_is_given = is_given, eb_rhs = rhs }) needs + | is_given = needs -- Add the rhs vars of the Wanted bindings only + | otherwise = evVarsOfTerm rhs `unionVarSet` needs + + also_needs :: VarSet -> VarSet + also_needs needs + = foldVarSet add emptyVarSet needs + where + add v needs + | Just ev_bind <- lookupEvBind ev_binds v + , EvBind { eb_is_given = is_given, eb_rhs = rhs } <- ev_bind + , is_given + = evVarsOfTerm rhs `unionVarSet` needs + | otherwise + = needs + + add_bndr :: EvBind -> VarSet -> VarSet + add_bndr (EvBind { eb_lhs = v }) vs = extendVarSet vs v + + {- +Note [Tracking redundant constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +With Opt_WarnRedundantConstraints, GHC can report which +constraints of a type signature (or instance declaration) are +redundant, and can be omitted. Here is an overview of how it +works: + +----- What is a redudant constraint? + +* The things that can be redundant are precisely the Given + constraints of an implication. + +* A constraint can be redundant in two different ways: + a) It is implied by other givens. E.g. + f :: (Eq a, Ord a) => blah -- Eq a unnecessary + g :: (Eq a, a~b, Eq b) => blah -- Either Eq a or Eq b unnecessary + b) It is not needed by the Wanted constraints covered by the + implication E.g. + f :: Eq a => a -> Bool + f x = True -- Equality not uesd + +* To find (a), when we have two Given constraints, + we must be careful to drop the one that is a naked variable (if poss). + So if we have + f :: (Eq a, Ord a) => blah + then we may find [G] sc_sel (d1::Ord a) :: Eq a + [G] d2 :: Eq a + We want to discard d2 in favour of the superclass selection from + the Ord dictionary. This is done by TcInteract.solveOneFromTheOther + See Note [Replacement vs keeping]. + +* To find (b) we need to know which evidence bindings are 'wanted'; + hence the eb_is_given field on an EvBind. + +----- How tracking works + +* When the constraint solver finishes solving all the wanteds in + an implication, it sets its status to IC_Solved + + - The ics_dead field of IC_Solved records the subset of the ic_given + of this implication that are redundant (not needed). + + - The ics_need field of IC_Solved then records all the + in-scope (given) evidence variables, bound by the context, that + were needed to solve this implication, including all its nested + implications. (We remove the ic_given of this implication from + the set, of course.) + +* We compute which evidence variables are needed by an implication + in setImplicationStatus. A variable is needed if + a) it is free in the RHS of a Wanted EvBind + b) it is free in the RHS of an EvBind whose LHS is needed + c) it is in the ics_need of a nested implication + +* We need to be careful not to discard an implication + prematurely, even one that is fully solved, because we might + thereby forget which variables it needs, and hence wrongly + report a constraint as redundant. But we can discard it once + its free vars have been incorporated into its parent; or if it + simply has no free vars. This careful discarding is also + handled in setImplicationStatus + +----- Reporting redundant constraints + +* TcErrors does the actual warning, in warnRedundantConstraints. + +* We don't report redundant givens for *every* implication; only + for those which reply True to TcSimplify.warnRedundantGivens: + + - For example, in a class declaration, the default method *can* + use the class constraint, but it certainly doesn't *have* to, + and we don't want to report an error there. + + - More subtly, in a function definition + f :: (Ord a, Ord a, Ix a) => a -> a + f x = rhs + we do an ambiguity check on the type (which would find that one + of the Ord a constraints was redundant), and then we check that + the definition has that type (which might find that both are + redundant). We don't want to report the same error twice, so + we disable it for the ambiguity check. Hence the flag in + TcType.FunSigCtxt. + + This decision is taken in setImplicationStatus, rather than TcErrors + so that we can discard implication constraints that we don't need. + So ics_dead consists only of the *reportable* redundant givens. + + Note [Cutting off simpl_loop] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It is very important not to iterate in simpl_loop unless there is a chance @@ -945,7 +1144,7 @@ Consider floated_eqs (all wanted or derived): simpl_loop. So we iterate if there any of these -} -promoteTyVar :: TcLevel -> TcTyVar -> TcS () +promoteTyVar :: TcLevel -> TcTyVar -> TcS TcTyVar -- When we float a constraint out of an implication we must restore -- invariant (MetaTvInv) in Note [TcLevel and untouchable type variables] in TcType -- See Note [Promoting unification variables] @@ -953,11 +1152,12 @@ promoteTyVar tclvl tv | isFloatedTouchableMetaTyVar tclvl tv = do { cloned_tv <- TcS.cloneMetaTyVar tv ; let rhs_tv = setMetaTyVarTcLevel cloned_tv tclvl - ; setWantedTyBind tv (mkTyVarTy rhs_tv) } + ; setWantedTyBind tv (mkTyVarTy rhs_tv) + ; return rhs_tv } | otherwise - = return () + = return tv -promoteAndDefaultTyVar :: TcLevel -> TcTyVarSet -> TyVar -> TcS () +promoteAndDefaultTyVar :: TcLevel -> TcTyVarSet -> TcTyVar -> TcS TcTyVar -- See Note [Promote _and_ default when inferring] promoteAndDefaultTyVar tclvl gbl_tvs tv = do { tv1 <- if tv `elemVarSet` gbl_tvs diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs index 6545e7b8e2..d187b091f4 100644 --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -1690,15 +1690,15 @@ checkValidClass cls ; case dm of GenDefMeth dm_name -> do { dm_id <- tcLookupId dm_name - ; checkValidType (FunSigCtxt op_name) (idType dm_id) } + ; checkValidType ctxt (idType dm_id) } _ -> return () } where - ctxt = FunSigCtxt op_name + ctxt = FunSigCtxt op_name True -- Report redundant class constraints op_name = idName sel_id op_ty = idType sel_id (_,theta1,tau1) = tcSplitSigmaTy op_ty - (_,theta2,tau2) = tcSplitSigmaTy tau1 + (_,theta2,tau2) = tcSplitSigmaTy tau1 (theta,tau) | constrained_class_methods = (theta1 ++ theta2, tau2) | otherwise = (theta1, mkPhiTy (tail theta1) tau1) -- Ugh! The function might have a type like diff --git a/compiler/typecheck/TcType.hs b/compiler/typecheck/TcType.hs index e0ce00f8ea..1cd2b00602 100644 --- a/compiler/typecheck/TcType.hs +++ b/compiler/typecheck/TcType.hs @@ -366,8 +366,12 @@ data MetaInfo -- in the places where we need to an expression has that type data UserTypeCtxt - = FunSigCtxt Name -- Function type signature - -- Also used for types in SPECIALISE pragmas + = FunSigCtxt Name Bool -- Function type signature, when checking the type + -- Also used for types in SPECIALISE pragmas + -- Bool = True <=> report redundant class constraints + -- False <=> do not + -- See Note [Tracking redundant constraints] in TcSimplify + | InfSigCtxt Name -- Inferred type for function | ExprSigCtxt -- Expression type signature | ConArgCtxt Name -- Data constructor argument @@ -528,8 +532,8 @@ pprTcTyVarDetails (MetaTv { mtv_info = info, mtv_tclvl = tclvl }) FlatMetaTv -> ptext (sLit "fuv") pprUserTypeCtxt :: UserTypeCtxt -> SDoc +pprUserTypeCtxt (FunSigCtxt n _) = ptext (sLit "the type signature for") <+> quotes (ppr n) pprUserTypeCtxt (InfSigCtxt n) = ptext (sLit "the inferred type for") <+> quotes (ppr n) -pprUserTypeCtxt (FunSigCtxt n) = ptext (sLit "the type signature for") <+> quotes (ppr n) pprUserTypeCtxt (RuleSigCtxt n) = ptext (sLit "a RULE for") <+> quotes (ppr n) pprUserTypeCtxt ExprSigCtxt = ptext (sLit "an expression type signature") pprUserTypeCtxt (ConArgCtxt c) = ptext (sLit "the type of the constructor") <+> quotes (ppr c) @@ -556,10 +560,10 @@ pprSigCtxt ctxt extra pp_ty = sep [ ptext (sLit "In") <+> extra <+> pprUserTypeCtxt ctxt <> colon , nest 2 (pp_sig ctxt) ] where - pp_sig (FunSigCtxt n) = pp_n_colon n - pp_sig (ConArgCtxt n) = pp_n_colon n - pp_sig (ForSigCtxt n) = pp_n_colon n - pp_sig _ = pp_ty + pp_sig (FunSigCtxt n _) = pp_n_colon n + pp_sig (ConArgCtxt n) = pp_n_colon n + pp_sig (ForSigCtxt n) = pp_n_colon n + pp_sig _ = pp_ty pp_n_colon n = pprPrefixOcc n <+> dcolon <+> pp_ty diff --git a/compiler/typecheck/TcUnify.hs b/compiler/typecheck/TcUnify.hs index 21e81db6ff..93f3f11c4e 100644 --- a/compiler/typecheck/TcUnify.hs +++ b/compiler/typecheck/TcUnify.hs @@ -12,7 +12,7 @@ module TcUnify ( -- Full-blown subsumption tcWrapResult, tcGen, tcSubType, tcSubType_NC, tcSubTypeDS, tcSubTypeDS_NC, - checkConstraints, checkScConstraints, + checkConstraints, -- Various unifications unifyType, unifyTypeList, unifyTheta, @@ -567,9 +567,7 @@ checkConstraints skol_info skol_tvs given thing_inside | otherwise = ASSERT2( all isTcTyVar skol_tvs, ppr skol_tvs ) ASSERT2( all isSkolemTyVar skol_tvs, ppr skol_tvs ) - do { ((result, tclvl), wanted) <- captureConstraints $ - captureTcLevel $ - thing_inside + do { (result, tclvl, wanted) <- pushLevelAndCaptureConstraints thing_inside ; if isEmptyWC wanted && null given -- Optimisation : if there are no wanteds, and no givens @@ -586,42 +584,13 @@ checkConstraints skol_info skol_tvs given thing_inside , ic_no_eqs = False , ic_given = given , ic_wanted = wanted - , ic_insol = insolubleWC wanted + , ic_status = IC_Unsolved , ic_binds = ev_binds_var , ic_env = env , ic_info = skol_info } ; return (TcEvBinds ev_binds_var, result) } } -checkScConstraints :: SkolemInfo - -> [TcTyVar] -- Skolems - -> [EvVar] -- Given - -> (EvBindsVar -> TcM (Bool, result)) - -> TcM (TcEvBinds, result) - --- Like checkConstraints, but the thing_inside --- can generate its own evidence bindings -checkScConstraints skol_info skol_tvs given thing_inside - = ASSERT2( all isTcTyVar skol_tvs, ppr skol_tvs ) - ASSERT2( all isSkolemTyVar skol_tvs, ppr skol_tvs ) - do { ev_binds_var <- newTcEvBinds - ; (((ok, result), tclvl), wanted) <- captureConstraints $ - captureTcLevel $ - thing_inside ev_binds_var - - ; env <- getLclEnv - ; emitImplication $ Implic { ic_tclvl = tclvl - , ic_skols = skol_tvs - , ic_no_eqs = False - , ic_given = if ok then given else [] - , ic_wanted = wanted - , ic_insol = insolubleWC wanted - , ic_binds = ev_binds_var - , ic_env = env - , ic_info = skol_info } - - ; return (TcEvBinds ev_binds_var, result) } - {- ************************************************************************ * * diff --git a/compiler/typecheck/TcValidity.hs b/compiler/typecheck/TcValidity.hs index 5078ede3cd..f6067e61ab 100644 --- a/compiler/typecheck/TcValidity.hs +++ b/compiler/typecheck/TcValidity.hs @@ -159,7 +159,7 @@ checkValidType ctxt ty TySynCtxt _ -> rank0 ExprSigCtxt -> rank1 - FunSigCtxt _ -> rank1 + FunSigCtxt _ _ -> rank1 InfSigCtxt _ -> ArbitraryRank -- Inferred type ConArgCtxt _ -> rank1 -- We are given the type of the entire -- constructor, hence rank 1 diff --git a/compiler/utils/Bag.hs b/compiler/utils/Bag.hs index 95feaed9f8..8fbfa13ccc 100644 --- a/compiler/utils/Bag.hs +++ b/compiler/utils/Bag.hs @@ -15,7 +15,7 @@ module Bag ( mapBag, elemBag, lengthBag, filterBag, partitionBag, partitionBagWith, - concatBag, foldBag, foldrBag, foldlBag, + concatBag, catBagMaybes, foldBag, foldrBag, foldlBag, isEmptyBag, isSingletonBag, consBag, snocBag, anyBag, listToBag, bagToList, foldrBagM, foldlBagM, mapBagM, mapBagM_, @@ -99,10 +99,15 @@ anyBag p (TwoBags b1 b2) = anyBag p b1 || anyBag p b2 anyBag p (ListBag xs) = any p xs concatBag :: Bag (Bag a) -> Bag a -concatBag EmptyBag = EmptyBag -concatBag (UnitBag b) = b -concatBag (TwoBags b1 b2) = concatBag b1 `unionBags` concatBag b2 -concatBag (ListBag bs) = unionManyBags bs +concatBag bss = foldrBag add emptyBag bss + where + add bs rs = bs `unionBags` rs + +catBagMaybes :: Bag (Maybe a) -> Bag a +catBagMaybes bs = foldrBag add emptyBag bs + where + add Nothing rs = rs + add (Just x) rs = x `consBag` rs partitionBag :: (a -> Bool) -> Bag a -> (Bag a {- Satisfy predictate -}, Bag a {- Don't -}) diff --git a/compiler/utils/Util.hs b/compiler/utils/Util.hs index aa3a19b64c..a1dacb45e5 100644 --- a/compiler/utils/Util.hs +++ b/compiler/utils/Util.hs @@ -553,6 +553,8 @@ list giving the break-off point: -} takeList :: [b] -> [a] -> [a] +-- (takeList as bs) trims bs to the be same length +-- as as, unless as is longer in which case it's a no-op takeList [] _ = [] takeList (_:xs) ls = case ls of |