diff options
| author | Simon Peyton Jones <simonpj@microsoft.com> | 2015-01-05 13:20:48 +0000 |
|---|---|---|
| committer | Simon Peyton Jones <simonpj@microsoft.com> | 2015-01-06 14:21:13 +0000 |
| commit | 32973bf3c2f6fe00e01b44a63ac1904080466938 (patch) | |
| tree | dcefa6b0b92f2cefda9c0ce8944169da0036d598 | |
| parent | da9b2ec3e19edb1de0e73e8f32aa0443743f072c (diff) | |
| download | haskell-32973bf3c2f6fe00e01b44a63ac1904080466938.tar.gz | |
Major patch to add -fwarn-redundant-constraints
The idea was promted by Trac #9939, but it was Christmas, so I did
some recreational programming that went much further.
The idea is to warn when a constraint in a user-supplied context is
redundant. Everything is described in detail in
Note [Tracking redundant constraints]
in TcSimplify.
Main changes:
* The new ic_status field in an implication, of type ImplicStatus.
It replaces ic_insol, and includes information about redundant
constraints.
* New function TcSimplify.setImplicationStatus sets the ic_status.
* TcSigInfo has sig_report_redundant field to say whenther a
redundant constraint should be reported; and similarly
the FunSigCtxt constructor of UserTypeCtxt
* EvBinds has a field eb_is_given, to record whether it is a given
or wanted binding. Some consequential chagnes to creating an evidence
binding (so that we record whether it is given or wanted).
* AbsBinds field abs_ev_binds is now a *list* of TcEvBiinds;
see Note [Typechecking plan for instance declarations] in
TcInstDcls
* Some significant changes to the type checking of instance
declarations; Note [Typechecking plan for instance declarations]
in TcInstDcls.
* I found that TcErrors.relevantBindings was failing to zonk the
origin of the constraint it was looking at, and hence failing to
find some relevant bindings. Easy to fix, and orthogonal to
everything else, but hard to disentangle.
Some minor refactorig:
* TcMType.newSimpleWanteds moves to Inst, renamed as newWanteds
* TcClassDcl and TcInstDcls now have their own code for typechecking
a method body, rather than sharing a single function. The shared
function (ws TcClassDcl.tcInstanceMethodBody) didn't have much code
and the differences were growing confusing.
* Add new function TcRnMonad.pushLevelAndCaptureConstraints, and
use it
* Add new function Bag.catBagMaybes, and use it in TcSimplify
207 files changed, 2027 insertions, 1287 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 diff --git a/docs/users_guide/using.xml b/docs/users_guide/using.xml index 3059cff485..88dbdb7ab2 100644 --- a/docs/users_guide/using.xml +++ b/docs/users_guide/using.xml @@ -1408,6 +1408,38 @@ foreign import "&f" f :: FunPtr t The warning will indicate the duplicated <literal>Eq a</literal> constraint. </para> + <para>This option is now deprecated in favour of <option>-fwarn-redundant-constraints</option>.</para> + </listitem> + </varlistentry> + + <varlistentry> + <term><option>-fwarn-redundant-constraints</option>:</term> + <listitem> + <indexterm><primary><option>-fwarn-redundant-constraints</option></primary></indexterm> + <indexterm><primary>redundant constraints, warning</primary></indexterm> + + <para>Have the compiler warn about redundant constraints in a type signature. For + example + <itemizedlist> + <listitem><para> + <programlisting> + f :: (Eq a, Ord a) => a -> a + </programlisting> + The warning will indicate the redundant <literal>Eq a</literal> constraint: + it is subsumed by the <literal>Ord a</literal> constraint. + </para></listitem> + <listitem><para> + <programlisting> + f :: Eq a => a -> a -> Bool + f x y = True + </programlisting> + The warning will indicate the redundant <literal>Eq a</literal> constraint: + : it is not used by the definition of <literal>f</literal>.) + </para></listitem> + </itemizedlist> + Similar warnings are given for a redundant constraint in an instance declaration. + </para> + <para>This option is on by default.</para> </listitem> </varlistentry> diff --git a/testsuite/tests/arrows/should_compile/arrowpat.hs b/testsuite/tests/arrows/should_compile/arrowpat.hs index 56b1117e9a..dda06cfedf 100644 --- a/testsuite/tests/arrows/should_compile/arrowpat.hs +++ b/testsuite/tests/arrows/should_compile/arrowpat.hs @@ -1,4 +1,5 @@ -{-# OPTIONS -XArrows #-} +{-# LANGUAGE Arrows #-} +{-# OPTIONS -fno-warn-redundant-constraints #-} -- Test for Trac #1662 diff --git a/testsuite/tests/codeGen/should_compile/T3286.hs b/testsuite/tests/codeGen/should_compile/T3286.hs index 0cc852db94..22c810dcd7 100644 --- a/testsuite/tests/codeGen/should_compile/T3286.hs +++ b/testsuite/tests/codeGen/should_compile/T3286.hs @@ -1,3 +1,4 @@ +{-# OPTIONS -fno-warn-redundant-constraints #-} module T3286 (train) where diff --git a/testsuite/tests/deriving/should_compile/T2856.hs b/testsuite/tests/deriving/should_compile/T2856.hs index c8f81a00bc..fc309585fe 100644 --- a/testsuite/tests/deriving/should_compile/T2856.hs +++ b/testsuite/tests/deriving/should_compile/T2856.hs @@ -1,3 +1,4 @@ +{-# OPTIONS -fno-warn-redundant-constraints #-} {-# LANGUAGE TypeFamilies, GeneralizedNewtypeDeriving, StandaloneDeriving, FlexibleInstances #-} -- Test Trac #2856 diff --git a/testsuite/tests/deriving/should_compile/T4966.hs b/testsuite/tests/deriving/should_compile/T4966.hs index 363627a415..85245b73ff 100644 --- a/testsuite/tests/deriving/should_compile/T4966.hs +++ b/testsuite/tests/deriving/should_compile/T4966.hs @@ -1,3 +1,5 @@ +{-# OPTIONS -fno-warn-redundant-constraints #-} + {-# LANGUAGE DatatypeContexts #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleInstances #-} diff --git a/testsuite/tests/deriving/should_compile/T4966.stderr b/testsuite/tests/deriving/should_compile/T4966.stderr index dceeaa698f..765c69756d 100644 --- a/testsuite/tests/deriving/should_compile/T4966.stderr +++ b/testsuite/tests/deriving/should_compile/T4966.stderr @@ -1,8 +1,8 @@ -T4966.hs:1:14: Warning: +T4966.hs:3:14: Warning: -XDatatypeContexts is deprecated: It was widely considered a misfeature, and has been removed from the Haskell language. -T4966.hs:33:30: Warning: +T4966.hs:35:30: Warning: No explicit implementation for either ‘==’ or ‘/=’ In the instance declaration for ‘Eq (TreeListObject a)’ diff --git a/testsuite/tests/deriving/should_compile/deriving-1935.hs b/testsuite/tests/deriving/should_compile/deriving-1935.hs index 5b3bca0c77..8bccd58182 100644 --- a/testsuite/tests/deriving/should_compile/deriving-1935.hs +++ b/testsuite/tests/deriving/should_compile/deriving-1935.hs @@ -3,6 +3,8 @@ -- Trac #1935 -- See Note [Superclasses of derived instance] in TcDeriv +{-# OPTIONS -fno-warn-redundant-constraints #-} + module Foo where import Data.Data diff --git a/testsuite/tests/deriving/should_compile/deriving-1935.stderr b/testsuite/tests/deriving/should_compile/deriving-1935.stderr index bf2c79cb7a..9901a367d7 100644 --- a/testsuite/tests/deriving/should_compile/deriving-1935.stderr +++ b/testsuite/tests/deriving/should_compile/deriving-1935.stderr @@ -1,15 +1,15 @@ -deriving-1935.hs:15:11: Warning: +deriving-1935.hs:17:11: Warning: No explicit implementation for either ‘==’ or ‘/=’ In the instance declaration for ‘Eq (T a)’ -deriving-1935.hs:18:11: Warning: +deriving-1935.hs:20:11: Warning: No explicit implementation for either ‘==’ or ‘/=’ In the instance declaration for ‘Eq (S a)’ -deriving-1935.hs:19:11: Warning: +deriving-1935.hs:21:11: Warning: No explicit implementation for either ‘compare’ or ‘<=’ In the instance declaration for ‘Ord (S a)’ diff --git a/testsuite/tests/deriving/should_compile/drv001.hs b/testsuite/tests/deriving/should_compile/drv001.hs index 694af6a50f..3afd394cc0 100644 --- a/testsuite/tests/deriving/should_compile/drv001.hs +++ b/testsuite/tests/deriving/should_compile/drv001.hs @@ -1,3 +1,5 @@ +{-# OPTIONS -fno-warn-redundant-constraints #-} + -- !!! canonical weird example for "deriving" module ShouldSucceed where diff --git a/testsuite/tests/deriving/should_compile/drv002.hs b/testsuite/tests/deriving/should_compile/drv002.hs index 15eb2d9ecc..9ccb7b7bb7 100644 --- a/testsuite/tests/deriving/should_compile/drv002.hs +++ b/testsuite/tests/deriving/should_compile/drv002.hs @@ -1,3 +1,5 @@ +{-# OPTIONS -fno-warn-redundant-constraints #-} + module ShouldSucceed where data Z a b diff --git a/testsuite/tests/deriving/should_compile/drv003.hs b/testsuite/tests/deriving/should_compile/drv003.hs index 0b8149ce8a..6fdd763f84 100644 --- a/testsuite/tests/deriving/should_compile/drv003.hs +++ b/testsuite/tests/deriving/should_compile/drv003.hs @@ -1,3 +1,5 @@ +{-# OPTIONS -fno-warn-redundant-constraints #-} + -- !!! This is the example given in TcDeriv -- module ShouldSucceed where diff --git a/testsuite/tests/deriving/should_compile/drv003.stderr b/testsuite/tests/deriving/should_compile/drv003.stderr index 6d9819fee8..ead606d28a 100644 --- a/testsuite/tests/deriving/should_compile/drv003.stderr +++ b/testsuite/tests/deriving/should_compile/drv003.stderr @@ -1,10 +1,10 @@ -drv003.hs:12:10: Warning: +drv003.hs:14:10: Warning: No explicit implementation for either ‘==’ or ‘/=’ In the instance declaration for ‘Eq (Foo a)’ -drv003.hs:15:10: Warning: +drv003.hs:17:10: Warning: No explicit implementation for either ‘==’ or ‘/=’ In the instance declaration for ‘Eq (Bar b)’ diff --git a/testsuite/tests/deriving/should_run/T9576.stderr b/testsuite/tests/deriving/should_run/T9576.stderr index 6f8bf7f4e7..954b2d9de3 100644 --- a/testsuite/tests/deriving/should_run/T9576.stderr +++ b/testsuite/tests/deriving/should_run/T9576.stderr @@ -5,7 +5,7 @@ T9576: T9576.hs:6:31: ‘((.) (showString "MkBar ") (showsPrec 11 b1))’ In the expression: showParen ((a >= 11)) ((.) (showString "MkBar ") (showsPrec 11 b1)) - When typechecking the code for ‘showsPrec’ + When typechecking the code for ‘showsPrec’ in a derived instance for ‘Show Bar’: To see the code I am typechecking, use -ddump-deriv (deferred type error) diff --git a/testsuite/tests/gadt/Gadt17_help.hs b/testsuite/tests/gadt/Gadt17_help.hs index 30b57133d5..e3b8e3a918 100644 --- a/testsuite/tests/gadt/Gadt17_help.hs +++ b/testsuite/tests/gadt/Gadt17_help.hs @@ -1,5 +1,5 @@ {-# LANGUAGE GADTs #-} -{-# OPTIONS_GHC -O #-} +{-# OPTIONS_GHC -O -fno-warn-redundant-constraints #-} module Gadt17_help ( TernOp (..), applyTernOp diff --git a/testsuite/tests/ghci/scripts/T5045.hs b/testsuite/tests/ghci/scripts/T5045.hs index b5b850330d..084dc2fe48 100644 --- a/testsuite/tests/ghci/scripts/T5045.hs +++ b/testsuite/tests/ghci/scripts/T5045.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE Arrows, FunctionalDependencies, FlexibleContexts, MultiParamTypeClasses, RecordWildCards #-} diff --git a/testsuite/tests/ghci/scripts/T8357.hs b/testsuite/tests/ghci/scripts/T8357.hs index 29fe7a85bb..82a34afdc6 100644 --- a/testsuite/tests/ghci/scripts/T8357.hs +++ b/testsuite/tests/ghci/scripts/T8357.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE KindSignatures #-} diff --git a/testsuite/tests/ghci/scripts/T8931.script b/testsuite/tests/ghci/scripts/T8931.script index 152747681c..b0c52d3b3a 100644 --- a/testsuite/tests/ghci/scripts/T8931.script +++ b/testsuite/tests/ghci/scripts/T8931.script @@ -1,3 +1,4 @@ +:set -fno-warn-redundant-constraints :m +Data.Typeable let {f :: Typeable a => (a->Bool) -> Bool; f _ = True} f (\x -> (x == 3)) diff --git a/testsuite/tests/ghci/scripts/ghci044.script b/testsuite/tests/ghci/scripts/ghci044.script index d6f12ada6e..d86557d317 100644 --- a/testsuite/tests/ghci/scripts/ghci044.script +++ b/testsuite/tests/ghci/scripts/ghci044.script @@ -1,3 +1,4 @@ +:set -fno-warn-redundant-constraints --Testing flexible and Overlapping instances class C a where { f :: a -> String; f _ = "Default" } instance C Int where { f _ = "Zeroth" } diff --git a/testsuite/tests/ghci/scripts/ghci044.stderr b/testsuite/tests/ghci/scripts/ghci044.stderr index 9bc8df9994..625696a8ba 100644 --- a/testsuite/tests/ghci/scripts/ghci044.stderr +++ b/testsuite/tests/ghci/scripts/ghci044.stderr @@ -1,8 +1,8 @@ -<interactive>:9:1: +<interactive>:10:1: Overlapping instances for C [Int] arising from a use of ‘f’ Matching instances: - instance C [Int] -- Defined at <interactive>:6:10 - instance C a => C [a] -- Defined at <interactive>:8:10 + instance C [Int] -- Defined at <interactive>:7:10 + instance C a => C [a] -- Defined at <interactive>:9:10 In the expression: f [4 :: Int] In an equation for ‘it’: it = f [4 :: Int] diff --git a/testsuite/tests/ghci/scripts/ghci047.script b/testsuite/tests/ghci/scripts/ghci047.script index 70cc5181d8..d1ceefd482 100644 --- a/testsuite/tests/ghci/scripts/ghci047.script +++ b/testsuite/tests/ghci/scripts/ghci047.script @@ -1,4 +1,5 @@ --Testing GADTs, type families as well as a ton of crazy type stuff +:set -fno-warn-redundant-constraints :set -XGADTs :set -XTypeFamilies :set -XFunctionalDependencies diff --git a/testsuite/tests/ghci/scripts/ghci047.stderr b/testsuite/tests/ghci/scripts/ghci047.stderr index dc8dfc9ecb..9428dbc1a9 100644 --- a/testsuite/tests/ghci/scripts/ghci047.stderr +++ b/testsuite/tests/ghci/scripts/ghci047.stderr @@ -1,5 +1,5 @@ -<interactive>:38:1: +<interactive>:39:1: Couldn't match type ‘HFalse’ with ‘HTrue’ Expected type: HTrue Actual type: Or HFalse HFalse @@ -7,7 +7,7 @@ In the expression: f $ Baz 'a' In an equation for ‘it’: it = f $ Baz 'a' -<interactive>:39:1: +<interactive>:40:1: Couldn't match type ‘HFalse’ with ‘HTrue’ Expected type: HTrue Actual type: Or HFalse HFalse diff --git a/testsuite/tests/haddock/haddock_examples/Test.hs b/testsuite/tests/haddock/haddock_examples/Test.hs index 8336cb543d..da149d0ac0 100644 --- a/testsuite/tests/haddock/haddock_examples/Test.hs +++ b/testsuite/tests/haddock/haddock_examples/Test.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} ----------------------------------------------------------------------------- -- | -- Module : Test diff --git a/testsuite/tests/haddock/haddock_examples/haddock.Test.stderr b/testsuite/tests/haddock/haddock_examples/haddock.Test.stderr index cde205a25d..25225797d4 100644 --- a/testsuite/tests/haddock/haddock_examples/haddock.Test.stderr +++ b/testsuite/tests/haddock/haddock_examples/haddock.Test.stderr @@ -186,10 +186,10 @@ m = undefined -Test.hs:32:9: Warning: ‘p’ is exported by ‘p’ and ‘R(..)’ +Test.hs:33:9: Warning: ‘p’ is exported by ‘p’ and ‘R(..)’ -Test.hs:32:12: Warning: ‘q’ is exported by ‘q’ and ‘R(..)’ +Test.hs:33:12: Warning: ‘q’ is exported by ‘q’ and ‘R(..)’ -Test.hs:32:15: Warning: ‘u’ is exported by ‘u’ and ‘R(..)’ +Test.hs:33:15: Warning: ‘u’ is exported by ‘u’ and ‘R(..)’ -Test.hs:38:9: Warning: ‘a’ is exported by ‘a’ and ‘C(a, b)’ +Test.hs:39:9: Warning: ‘a’ is exported by ‘a’ and ‘C(a, b)’ diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA023.hs b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA023.hs index e197a6b48f..4d1f407cd3 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA023.hs +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA023.hs @@ -1,6 +1,8 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} + module ShouldCompile where -test :: (Eq a) => [a] -- ^ doc1 - -> [a] {-^ doc2 -} +test :: (Eq a) => [a] -- ^ doc1 + -> [a] {-^ doc2 -} -> [a] -- ^ doc3 test xs ys = xs diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA026.hs b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA026.hs index cc2d8bfae5..14d7a268ba 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA026.hs +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA026.hs @@ -1,6 +1,8 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} + module ShouldCompile where -test :: (Eq a) => [a] -- ^ doc1 - -> forall b . [b] {-^ doc2 -} +test :: (Eq a) => [a] -- ^ doc1 + -> forall b . [b] {-^ doc2 -} -> [a] -- ^ doc3 test xs ys = xs diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA027.hs b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA027.hs index 1aa6e37d07..8e03bc2213 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA027.hs +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA027.hs @@ -1,7 +1,9 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} + module ShouldCompile where -test :: [a] -- ^ doc1 - -> forall b. (Ord b) => [b] {-^ doc2 -} +test :: [a] -- ^ doc1 + -> forall b. (Ord b) => [b] {-^ doc2 -} -> forall c. (Num c) => [c] -- ^ doc3 -> [a] test xs ys zs = xs diff --git a/testsuite/tests/haddock/should_compile_noflag_haddock/haddockC026.hs b/testsuite/tests/haddock/should_compile_noflag_haddock/haddockC026.hs index cc2d8bfae5..14d7a268ba 100644 --- a/testsuite/tests/haddock/should_compile_noflag_haddock/haddockC026.hs +++ b/testsuite/tests/haddock/should_compile_noflag_haddock/haddockC026.hs @@ -1,6 +1,8 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} + module ShouldCompile where -test :: (Eq a) => [a] -- ^ doc1 - -> forall b . [b] {-^ doc2 -} +test :: (Eq a) => [a] -- ^ doc1 + -> forall b . [b] {-^ doc2 -} -> [a] -- ^ doc3 test xs ys = xs diff --git a/testsuite/tests/haddock/should_compile_noflag_haddock/haddockC027.hs b/testsuite/tests/haddock/should_compile_noflag_haddock/haddockC027.hs index c22be2fb87..4d6a8c2339 100644 --- a/testsuite/tests/haddock/should_compile_noflag_haddock/haddockC027.hs +++ b/testsuite/tests/haddock/should_compile_noflag_haddock/haddockC027.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} + module ShouldCompile where -- I bet this test is a mistake! From the layout it diff --git a/testsuite/tests/indexed-types/should_compile/Class2.hs b/testsuite/tests/indexed-types/should_compile/Class2.hs index f0d90f35f5..04da8d5949 100644 --- a/testsuite/tests/indexed-types/should_compile/Class2.hs +++ b/testsuite/tests/indexed-types/should_compile/Class2.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE TypeFamilies #-} module Class2 where diff --git a/testsuite/tests/indexed-types/should_compile/Gentle.hs b/testsuite/tests/indexed-types/should_compile/Gentle.hs index 7ceedfd098..5406493097 100644 --- a/testsuite/tests/indexed-types/should_compile/Gentle.hs +++ b/testsuite/tests/indexed-types/should_compile/Gentle.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, UndecidableInstances #-} diff --git a/testsuite/tests/indexed-types/should_compile/InstContextNorm.hs b/testsuite/tests/indexed-types/should_compile/InstContextNorm.hs index 58ff8f8c0a..87aecb0e01 100644 --- a/testsuite/tests/indexed-types/should_compile/InstContextNorm.hs +++ b/testsuite/tests/indexed-types/should_compile/InstContextNorm.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE TypeFamilies, FlexibleContexts #-} {-# LANGUAGE EmptyDataDecls, FlexibleInstances, UndecidableInstances #-} diff --git a/testsuite/tests/indexed-types/should_compile/InstEqContext.hs b/testsuite/tests/indexed-types/should_compile/InstEqContext.hs index e178e110a5..f3bf5cfb2d 100644 --- a/testsuite/tests/indexed-types/should_compile/InstEqContext.hs +++ b/testsuite/tests/indexed-types/should_compile/InstEqContext.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE TypeFamilies #-} module InstEqContext where diff --git a/testsuite/tests/indexed-types/should_compile/InstEqContext2.hs b/testsuite/tests/indexed-types/should_compile/InstEqContext2.hs index c5d017a644..0140d3e74e 100644 --- a/testsuite/tests/indexed-types/should_compile/InstEqContext2.hs +++ b/testsuite/tests/indexed-types/should_compile/InstEqContext2.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE TypeFamilies, EmptyDataDecls #-} module InstEqContext2 where diff --git a/testsuite/tests/indexed-types/should_compile/InstEqContext3.hs b/testsuite/tests/indexed-types/should_compile/InstEqContext3.hs index 3f307f8941..032ef34bc1 100644 --- a/testsuite/tests/indexed-types/should_compile/InstEqContext3.hs +++ b/testsuite/tests/indexed-types/should_compile/InstEqContext3.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE TypeFamilies #-} module InstEqContext where diff --git a/testsuite/tests/indexed-types/should_compile/NonLinearLHS.hs b/testsuite/tests/indexed-types/should_compile/NonLinearLHS.hs index 26ea632a29..d500b324fe 100644 --- a/testsuite/tests/indexed-types/should_compile/NonLinearLHS.hs +++ b/testsuite/tests/indexed-types/should_compile/NonLinearLHS.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE TypeFamilies, EmptyDataDecls, FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances, UndecidableInstances #-} diff --git a/testsuite/tests/indexed-types/should_compile/Rules1.hs b/testsuite/tests/indexed-types/should_compile/Rules1.hs index b936349475..afb8bc2ade 100644 --- a/testsuite/tests/indexed-types/should_compile/Rules1.hs +++ b/testsuite/tests/indexed-types/should_compile/Rules1.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE TypeFamilies #-} module Rules1 where diff --git a/testsuite/tests/indexed-types/should_compile/Simple24.hs b/testsuite/tests/indexed-types/should_compile/Simple24.hs index de33458bc7..fbca4aaadd 100644 --- a/testsuite/tests/indexed-types/should_compile/Simple24.hs +++ b/testsuite/tests/indexed-types/should_compile/Simple24.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FlexibleContexts #-} module Simple24 where diff --git a/testsuite/tests/indexed-types/should_compile/T2448.hs b/testsuite/tests/indexed-types/should_compile/T2448.hs index 806df3ff4c..7393eb1e6b 100644 --- a/testsuite/tests/indexed-types/should_compile/T2448.hs +++ b/testsuite/tests/indexed-types/should_compile/T2448.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE TypeFamilies, UndecidableInstances #-} module T2448 where diff --git a/testsuite/tests/indexed-types/should_compile/T3023.hs b/testsuite/tests/indexed-types/should_compile/T3023.hs index 26966daed7..116e9c77c2 100644 --- a/testsuite/tests/indexed-types/should_compile/T3023.hs +++ b/testsuite/tests/indexed-types/should_compile/T3023.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# OPTIONS_GHC -fwarn-missing-signatures #-} +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances #-} module Bug where diff --git a/testsuite/tests/indexed-types/should_compile/T3023.stderr b/testsuite/tests/indexed-types/should_compile/T3023.stderr index 68066bac91..81afa91f60 100644 --- a/testsuite/tests/indexed-types/should_compile/T3023.stderr +++ b/testsuite/tests/indexed-types/should_compile/T3023.stderr @@ -1,4 +1,3 @@ -T3023.hs:17:1: - Warning: Top-level binding with no type signature: - bar :: Bool -> Bool +T3023.hs:18:1: Warning: + Top-level binding with no type signature: bar :: Bool -> Bool diff --git a/testsuite/tests/indexed-types/should_compile/T3484.hs b/testsuite/tests/indexed-types/should_compile/T3484.hs index 4d1570915e..e558cbbe21 100644 --- a/testsuite/tests/indexed-types/should_compile/T3484.hs +++ b/testsuite/tests/indexed-types/should_compile/T3484.hs @@ -1,5 +1,6 @@ +{-# OPTIONS_GHC -Wall -fno-warn-redundant-constraints #-} {-# LANGUAGE GADTs, RankNTypes, TypeFamilies, FlexibleContexts, ScopedTypeVariables #-} -{-# OPTIONS_GHC -Wall #-} + module Absurd where data Z = Z diff --git a/testsuite/tests/indexed-types/should_compile/T4200.hs b/testsuite/tests/indexed-types/should_compile/T4200.hs index 0d0e23a419..feb91e8d8b 100644 --- a/testsuite/tests/indexed-types/should_compile/T4200.hs +++ b/testsuite/tests/indexed-types/should_compile/T4200.hs @@ -1,12 +1,13 @@ -{-# LANGUAGE TypeFamilies #-}
-
-module T4200 where
-
-class C a where
- type In a :: *
- op :: In a -> Int
-
--- Should be ok; no -XUndecidableInstances required
-instance (In c ~ Int) => C [c] where
- type In [c] = In c
- op x = 3
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} +{-# LANGUAGE TypeFamilies #-} + +module T4200 where + +class C a where + type In a :: * + op :: In a -> Int + +-- Should be ok; no -XUndecidableInstances required +instance (In c ~ Int) => C [c] where + type In [c] = In c + op x = 3 diff --git a/testsuite/tests/indexed-types/should_compile/T4497.hs b/testsuite/tests/indexed-types/should_compile/T4497.hs index 57d3d48ca4..07702bedc3 100644 --- a/testsuite/tests/indexed-types/should_compile/T4497.hs +++ b/testsuite/tests/indexed-types/should_compile/T4497.hs @@ -1,15 +1,16 @@ -{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, TypeFamilies #-}
-
-module T4497 where
-
-norm2PropR a = twiddle (norm2 a) a
-
-twiddle :: Normed a => a -> a -> Double
-twiddle a b = undefined
-
-norm2 :: e -> RealOf e
-norm2 = undefined
-
-class (Num (RealOf t)) => Normed t
-
-type family RealOf x
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} +{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, TypeFamilies #-} + +module T4497 where + +norm2PropR a = twiddle (norm2 a) a + +twiddle :: Normed a => a -> a -> Double +twiddle a b = undefined + +norm2 :: e -> RealOf e +norm2 = undefined + +class (Num (RealOf t)) => Normed t + +type family RealOf x diff --git a/testsuite/tests/indexed-types/should_compile/T4981-V1.hs b/testsuite/tests/indexed-types/should_compile/T4981-V1.hs index 629028748a..47e3b1c87a 100644 --- a/testsuite/tests/indexed-types/should_compile/T4981-V1.hs +++ b/testsuite/tests/indexed-types/should_compile/T4981-V1.hs @@ -1,34 +1,36 @@ -{-# LANGUAGE CPP, TypeFamilies, FlexibleContexts #-}
-module Class ( cleverNamedResolve ) where
-
-data FL p = FL p
-
-class PatchInspect p where
-instance PatchInspect p => PatchInspect (FL p) where
-
-type family PrimOf p
-type instance PrimOf (FL p) = PrimOf p
-
-data WithName prim = WithName prim
-
-instance PatchInspect prim => PatchInspect (WithName prim) where
-
-class (PatchInspect (PrimOf p)) => Conflict p where
- resolveConflicts :: p -> PrimOf p
-
-instance Conflict p => Conflict (FL p) where
- resolveConflicts = undefined
-
-type family OnPrim p
-
-class FromPrims p where
-
-instance FromPrims (FL p) where
-
-joinPatches :: FromPrims p => p -> p
-joinPatches = id
-
-cleverNamedResolve :: (Conflict (OnPrim p)
- ,PrimOf (OnPrim p) ~ WithName (PrimOf p))
- => p -> FL (OnPrim p) -> WithName (PrimOf p)
-cleverNamedResolve x = resolveConflicts . joinPatches
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} +{-# LANGUAGE CPP, TypeFamilies, FlexibleContexts #-} + +module Class ( cleverNamedResolve ) where + +data FL p = FL p + +class PatchInspect p where +instance PatchInspect p => PatchInspect (FL p) where + +type family PrimOf p +type instance PrimOf (FL p) = PrimOf p + +data WithName prim = WithName prim + +instance PatchInspect prim => PatchInspect (WithName prim) where + +class (PatchInspect (PrimOf p)) => Conflict p where + resolveConflicts :: p -> PrimOf p + +instance Conflict p => Conflict (FL p) where + resolveConflicts = undefined + +type family OnPrim p + +class FromPrims p where + +instance FromPrims (FL p) where + +joinPatches :: FromPrims p => p -> p +joinPatches = id + +cleverNamedResolve :: (Conflict (OnPrim p) + ,PrimOf (OnPrim p) ~ WithName (PrimOf p)) + => p -> FL (OnPrim p) -> WithName (PrimOf p) +cleverNamedResolve x = resolveConflicts . joinPatches diff --git a/testsuite/tests/indexed-types/should_compile/T4981-V2.hs b/testsuite/tests/indexed-types/should_compile/T4981-V2.hs index 716f161340..6b1d472cc6 100644 --- a/testsuite/tests/indexed-types/should_compile/T4981-V2.hs +++ b/testsuite/tests/indexed-types/should_compile/T4981-V2.hs @@ -1,31 +1,33 @@ -{-# LANGUAGE CPP, TypeFamilies, FlexibleContexts #-}
-module Class ( cleverNamedResolve ) where
-
-data FL p = FL p
-
-class PatchInspect p where
-instance PatchInspect p => PatchInspect (FL p) where
-
-type family PrimOf p
-type instance PrimOf (FL p) = PrimOf p
-
-data WithName prim = WithName prim
-
-instance PatchInspect prim => PatchInspect (WithName prim) where
-
-class (PatchInspect (PrimOf p)) => Conflict p where
- resolveConflicts :: p -> PrimOf p
-
-instance Conflict p => Conflict (FL p) where
- resolveConflicts = undefined
-
-type family OnPrim p
-
-joinPatches :: FL p -> FL p
-
-joinPatches = id
-
-cleverNamedResolve :: (Conflict (OnPrim p)
- ,PrimOf (OnPrim p) ~ WithName (PrimOf p))
- => p -> FL (OnPrim p) -> WithName (PrimOf p)
-cleverNamedResolve x = resolveConflicts . joinPatches
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} +{-# LANGUAGE CPP, TypeFamilies, FlexibleContexts #-} + +module Class ( cleverNamedResolve ) where + +data FL p = FL p + +class PatchInspect p where +instance PatchInspect p => PatchInspect (FL p) where + +type family PrimOf p +type instance PrimOf (FL p) = PrimOf p + +data WithName prim = WithName prim + +instance PatchInspect prim => PatchInspect (WithName prim) where + +class (PatchInspect (PrimOf p)) => Conflict p where + resolveConflicts :: p -> PrimOf p + +instance Conflict p => Conflict (FL p) where + resolveConflicts = undefined + +type family OnPrim p + +joinPatches :: FL p -> FL p + +joinPatches = id + +cleverNamedResolve :: (Conflict (OnPrim p) + ,PrimOf (OnPrim p) ~ WithName (PrimOf p)) + => p -> FL (OnPrim p) -> WithName (PrimOf p) +cleverNamedResolve x = resolveConflicts . joinPatches diff --git a/testsuite/tests/indexed-types/should_compile/T4981-V3.hs b/testsuite/tests/indexed-types/should_compile/T4981-V3.hs index e6bcd471d9..e0cd7ed8e5 100644 --- a/testsuite/tests/indexed-types/should_compile/T4981-V3.hs +++ b/testsuite/tests/indexed-types/should_compile/T4981-V3.hs @@ -1,4 +1,6 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE CPP, TypeFamilies, FlexibleContexts #-} + module Class ( cleverNamedResolve ) where data FL p = FL p diff --git a/testsuite/tests/indexed-types/should_compile/T5002.hs b/testsuite/tests/indexed-types/should_compile/T5002.hs index cfc82d559e..390c6ae703 100644 --- a/testsuite/tests/indexed-types/should_compile/T5002.hs +++ b/testsuite/tests/indexed-types/should_compile/T5002.hs @@ -1,29 +1,30 @@ -{-# LANGUAGE TypeFamilies, FlexibleInstances, UndecidableInstances, FlexibleContexts #-}
-
-class A a
-class B a where b :: a -> ()
-instance A a => B a where b = undefined
-
-newtype Y a = Y (a -> ())
-
-okIn701 :: B a => Y a
-okIn701 = wrap $ const () . b
-
-okIn702 :: B a => Y a
-okIn702 = wrap $ b
-
-okInBoth :: B a => Y a
-okInBoth = Y $ const () . b
-
-class Wrapper a where
- type Wrapped a
- wrap :: Wrapped a -> a
-instance Wrapper (Y a) where
- type Wrapped (Y a) = a -> ()
- wrap = Y
-
-fromTicket3018 :: Eq [a] => a -> ()
-fromTicket3018 x = let {g :: Int -> Int; g = [x]==[x] `seq` id} in ()
-
-main = undefined
-
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} +{-# LANGUAGE TypeFamilies, FlexibleInstances, UndecidableInstances, FlexibleContexts #-} + +class A a +class B a where b :: a -> () +instance A a => B a where b = undefined + +newtype Y a = Y (a -> ()) + +okIn701 :: B a => Y a +okIn701 = wrap $ const () . b + +okIn702 :: B a => Y a +okIn702 = wrap $ b + +okInBoth :: B a => Y a +okInBoth = Y $ const () . b + +class Wrapper a where + type Wrapped a + wrap :: Wrapped a -> a +instance Wrapper (Y a) where + type Wrapped (Y a) = a -> () + wrap = Y + +fromTicket3018 :: Eq [a] => a -> () +fromTicket3018 x = let {g :: Int -> Int; g = [x]==[x] `seq` id} in () + +main = undefined + diff --git a/testsuite/tests/indexed-types/should_compile/T9090.hs b/testsuite/tests/indexed-types/should_compile/T9090.hs index 6d2b6baba2..b3b639f126 100644 --- a/testsuite/tests/indexed-types/should_compile/T9090.hs +++ b/testsuite/tests/indexed-types/should_compile/T9090.hs @@ -1,4 +1,6 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE RankNTypes, ConstraintKinds, TypeFamilies #-} + module T9090 where import GHC.Exts (Constraint) diff --git a/testsuite/tests/indexed-types/should_compile/T9316.hs b/testsuite/tests/indexed-types/should_compile/T9316.hs index b5dfca6a94..ca7680c063 100644 --- a/testsuite/tests/indexed-types/should_compile/T9316.hs +++ b/testsuite/tests/indexed-types/should_compile/T9316.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE DataKinds #-} diff --git a/testsuite/tests/indexed-types/should_compile/T9747.hs b/testsuite/tests/indexed-types/should_compile/T9747.hs index 05b4397630..0466cbae67 100644 --- a/testsuite/tests/indexed-types/should_compile/T9747.hs +++ b/testsuite/tests/indexed-types/should_compile/T9747.hs @@ -1,4 +1,6 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE ConstraintKinds, DataKinds, GADTs, TypeFamilies, TypeOperators #-} + module T9747 where import Data.List (intercalate) import Data.Proxy diff --git a/testsuite/tests/indexed-types/should_fail/T2239.hs b/testsuite/tests/indexed-types/should_fail/T2239.hs index d84ea17b31..52a8296e48 100644 --- a/testsuite/tests/indexed-types/should_fail/T2239.hs +++ b/testsuite/tests/indexed-types/should_fail/T2239.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE NoMonomorphismRestriction, RankNTypes #-} {-# LANGUAGE FunctionalDependencies, MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances, FlexibleContexts, ScopedTypeVariables #-} diff --git a/testsuite/tests/indexed-types/should_fail/T3330c.stderr b/testsuite/tests/indexed-types/should_fail/T3330c.stderr index afb9902adf..97a54ec5cf 100644 --- a/testsuite/tests/indexed-types/should_fail/T3330c.stderr +++ b/testsuite/tests/indexed-types/should_fail/T3330c.stderr @@ -6,5 +6,9 @@ T3330c.hs:23:43: R :: (* -> *) -> * Expected type: Der ((->) x) (f1 x) Actual type: R f1 + Relevant bindings include + x :: x (bound at T3330c.hs:23:29) + df :: f1 x (bound at T3330c.hs:23:25) + plug' :: R f -> Der f x -> x -> f x (bound at T3330c.hs:23:1) In the first argument of ‘plug’, namely ‘rf’ In the first argument of ‘Inl’, namely ‘(plug rf df x)’ diff --git a/testsuite/tests/indexed-types/should_fail/T7862.hs b/testsuite/tests/indexed-types/should_fail/T7862.hs index 050479b32e..081e0c96f0 100644 --- a/testsuite/tests/indexed-types/should_fail/T7862.hs +++ b/testsuite/tests/indexed-types/should_fail/T7862.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE TypeFamilies, FlexibleContexts #-} -- This used to fail because of the silent-superclass diff --git a/testsuite/tests/indexed-types/should_fail/T7862.stderr b/testsuite/tests/indexed-types/should_fail/T7862.stderr index 3521aea713..5a14fc3480 100644 --- a/testsuite/tests/indexed-types/should_fail/T7862.stderr +++ b/testsuite/tests/indexed-types/should_fail/T7862.stderr @@ -1,5 +1,5 @@ -T7862.hs:22:10: Warning: +T7862.hs:23:10: Warning: No explicit implementation for ‘+’, ‘*’, ‘abs’, ‘signum’, ‘fromInteger’, and (either ‘negate’ or diff --git a/testsuite/tests/module/mod129.hs b/testsuite/tests/module/mod129.hs index 4229e9e88a..caf5c72906 100644 --- a/testsuite/tests/module/mod129.hs +++ b/testsuite/tests/module/mod129.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} + -- !!! hiding class members (but not class.) module M where diff --git a/testsuite/tests/module/mod71.stderr b/testsuite/tests/module/mod71.stderr index 7cf7e0bf7b..12962aa473 100644 --- a/testsuite/tests/module/mod71.stderr +++ b/testsuite/tests/module/mod71.stderr @@ -9,3 +9,12 @@ mod71.hs:4:9: In the first argument of ‘x’, namely ‘_’ In the expression: x _ 1 In an equation for ‘f’: f x = x _ 1 + +mod71.hs:4:11: + No instance for (Num a) arising from the literal ‘1’ + Possible fix: + add (Num a) to the context of + the inferred type of f :: (t1 -> a -> t) -> t + In the second argument of ‘x’, namely ‘1’ + In the expression: x _ 1 + In an equation for ‘f’: f x = x _ 1 diff --git a/testsuite/tests/parser/should_compile/mc15.hs b/testsuite/tests/parser/should_compile/mc15.hs index 2976694803..6197dc4a09 100644 --- a/testsuite/tests/parser/should_compile/mc15.hs +++ b/testsuite/tests/parser/should_compile/mc15.hs @@ -5,7 +5,7 @@ module Foo where import Control.Monad.Zip -foo :: (MonadZip m, Monad m) => m () +foo :: MonadZip m => m () foo = [ () | () <- foo | () <- foo diff --git a/testsuite/tests/parser/should_compile/read002.hs b/testsuite/tests/parser/should_compile/read002.hs index 5b069fe2c6..8d9ea5ea4f 100644 --- a/testsuite/tests/parser/should_compile/read002.hs +++ b/testsuite/tests/parser/should_compile/read002.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} + -- !!! tests fixity reading and printing module ShouldCompile where diff --git a/testsuite/tests/partial-sigs/should_compile/all.T b/testsuite/tests/partial-sigs/should_compile/all.T index 52a532f32f..e83e070dcd 100644 --- a/testsuite/tests/partial-sigs/should_compile/all.T +++ b/testsuite/tests/partial-sigs/should_compile/all.T @@ -29,7 +29,7 @@ test('HigherRank2', normal, compile, ['-ddump-types -fno-warn-partial-type-signa test('LocalDefinitionBug', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures']) test('Meltdown', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures']) # Bug -test('MonoLocalBinds', expect_fail, compile, ['-ddump-types -fno-warn-partial-type-signatures']) +test('MonoLocalBinds', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures']) test('NamedTyVar', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures']) test('ParensAroundContext', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures']) test('PatBind', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures']) diff --git a/testsuite/tests/patsyn/should_compile/T8584-2.hs b/testsuite/tests/patsyn/should_compile/T8584-2.hs index d267d39887..24147a258d 100644 --- a/testsuite/tests/patsyn/should_compile/T8584-2.hs +++ b/testsuite/tests/patsyn/should_compile/T8584-2.hs @@ -1,4 +1,6 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE PatternSynonyms #-} + module ShouldCompile where pattern Single :: () => (Show a) => a -> [a] diff --git a/testsuite/tests/patsyn/should_compile/T8968-1.hs b/testsuite/tests/patsyn/should_compile/T8968-1.hs index f41ed5352b..a0e3285a4b 100644 --- a/testsuite/tests/patsyn/should_compile/T8968-1.hs +++ b/testsuite/tests/patsyn/should_compile/T8968-1.hs @@ -6,3 +6,4 @@ data X :: (* -> *) -> * -> * where pattern C :: a -> X Maybe (Maybe a) pattern C x = Y (Just x) + diff --git a/testsuite/tests/patsyn/should_compile/all.T b/testsuite/tests/patsyn/should_compile/all.T index 91c0012d48..d5d5eed1ce 100644 --- a/testsuite/tests/patsyn/should_compile/all.T +++ b/testsuite/tests/patsyn/should_compile/all.T @@ -15,8 +15,8 @@ test('T9732', normal, compile, ['']) test('T8584-1', normal, compile, ['']) test('T8584-2', normal, compile, ['']) test('T8584-3', normal, compile, ['']) -test('T8968-1', normal, compile, ['']) +test('T8968-1', expect_broken(9953), compile, ['']) test('T8968-2', normal, compile, ['']) -test('T8968-3', normal, compile, ['']) +test('T8968-3', expect_broken(9953), compile, ['']) test('ImpExp_Imp', [extra_clean(['ImpExp_Exp.hi', 'ImpExp_Exp.o'])], multimod_compile, ['ImpExp_Imp', '-v0']) test('T9857', normal, compile, ['']) diff --git a/testsuite/tests/patsyn/should_compile/ex-view.hs b/testsuite/tests/patsyn/should_compile/ex-view.hs index e317274993..699b070b5f 100644 --- a/testsuite/tests/patsyn/should_compile/ex-view.hs +++ b/testsuite/tests/patsyn/should_compile/ex-view.hs @@ -1,6 +1,8 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} +{-# LANGUAGE PatternSynonyms, GADTs, ViewPatterns #-} + -- Pattern synonyms -{-# LANGUAGE PatternSynonyms, GADTs, ViewPatterns #-} module ShouldCompile where data T a where diff --git a/testsuite/tests/perf/compiler/T3064.hs b/testsuite/tests/perf/compiler/T3064.hs index 39a51de8b0..53a87b599b 100644 --- a/testsuite/tests/perf/compiler/T3064.hs +++ b/testsuite/tests/perf/compiler/T3064.hs @@ -1,5 +1,7 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE Rank2Types, TypeSynonymInstances, FlexibleInstances #-} {-# LANGUAGE TypeFamilies, GeneralizedNewtypeDeriving #-} + module T3064 where import Control.Applicative diff --git a/testsuite/tests/perf/compiler/T5030.hs b/testsuite/tests/perf/compiler/T5030.hs index b65e9cdd3c..6bb7478b50 100644 --- a/testsuite/tests/perf/compiler/T5030.hs +++ b/testsuite/tests/perf/compiler/T5030.hs @@ -134,15 +134,15 @@ data Operation cpu resultSize where type CDM cpu a = IO a -($=) :: CPU cpu => Var cpu size -> Operation cpu size -> CDM cpu () +($=) :: Var cpu size -> Operation cpu size -> CDM cpu () var $= op = undefined -tempVar :: CPU cpu => CDM cpu (Var cpu size) +tempVar :: CDM cpu (Var cpu size) tempVar = do cnt <- liftM fst undefined return $ Temp cnt -op :: CPU cpu => Operation cpu size -> CDM cpu (Var cpu size) +op :: Operation cpu size -> CDM cpu (Var cpu size) op operation = do v <- tempVar v $= operation diff --git a/testsuite/tests/polykinds/PolyKinds08.hs b/testsuite/tests/polykinds/PolyKinds08.hs index aa64345801..1e01aaa5a9 100644 --- a/testsuite/tests/polykinds/PolyKinds08.hs +++ b/testsuite/tests/polykinds/PolyKinds08.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE PolyKinds #-} module PolyKinds08 where diff --git a/testsuite/tests/polykinds/T6015a.hs b/testsuite/tests/polykinds/T6015a.hs index f42019cc52..cb6104f8d8 100644 --- a/testsuite/tests/polykinds/T6015a.hs +++ b/testsuite/tests/polykinds/T6015a.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE PolyKinds, KindSignatures, FunctionalDependencies, FlexibleInstances, UndecidableInstances, TypeOperators, DataKinds, FlexibleContexts #-} diff --git a/testsuite/tests/polykinds/T6020a.hs b/testsuite/tests/polykinds/T6020a.hs index 00689786c3..abdee4d4f1 100644 --- a/testsuite/tests/polykinds/T6020a.hs +++ b/testsuite/tests/polykinds/T6020a.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE DataKinds, FunctionalDependencies, FlexibleInstances, UndecidableInstances, PolyKinds, KindSignatures, ConstraintKinds, FlexibleContexts, GADTs #-} diff --git a/testsuite/tests/polykinds/T6068.hs b/testsuite/tests/polykinds/T6068.hs index 9c754bd87e..0b414a87b9 100644 --- a/testsuite/tests/polykinds/T6068.hs +++ b/testsuite/tests/polykinds/T6068.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE PolyKinds, DataKinds, TypeFamilies, GADTs, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, UndecidableInstances, ExistentialQuantification #-} diff --git a/testsuite/tests/polykinds/T7090.hs b/testsuite/tests/polykinds/T7090.hs index 2364b0cd5a..8f0dbd1878 100644 --- a/testsuite/tests/polykinds/T7090.hs +++ b/testsuite/tests/polykinds/T7090.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE GADTs, ConstraintKinds, TypeFamilies, DataKinds, ScopedTypeVariables, TypeOperators #-} diff --git a/testsuite/tests/polykinds/T7332.hs b/testsuite/tests/polykinds/T7332.hs index 647dd9333d..79623e9803 100644 --- a/testsuite/tests/polykinds/T7332.hs +++ b/testsuite/tests/polykinds/T7332.hs @@ -18,7 +18,7 @@ instance IsString (DC String) where class Monoid acc => Build acc r where - type BuildR r :: * -- Result type + type BuildR r :: * -- Result type build :: (acc -> BuildR r) -> acc -> r instance Monoid dc => Build dc (DC dx) where @@ -31,9 +31,25 @@ instance (Build dc r, a ~ dc) => Build dc (a->r) where -- The type is inferred -tspan :: (Monoid d, Build (DC d) r, BuildR r ~ DC d) => r +-- tspan :: (Monoid d, Build (DC d) r, BuildR r ~ DC d) => r +tspan :: (Build (DC d) r, BuildR r ~ DC d) => r tspan = build (id :: DC d -> DC d) mempty +{- Wanted: + Build acc0 r0 + Monid acc0 + acc0 ~ DC d0 + DC d0 ~ BuildR r0 +==> + Build (DC d0) r0 + Monoid (DC d0) --> Monoid d0 + DC d- ~ BuildR r0 + +In fact Monoid (DC d0) is a superclass of (Build (DC do) r0) +But during inference we do not take upserclasses of wanteds +-} + + foo = tspan "aa" foo1 = tspan (tspan "aa") diff --git a/testsuite/tests/polykinds/T8359.hs b/testsuite/tests/polykinds/T8359.hs index d172270b12..00fabf86a9 100644 --- a/testsuite/tests/polykinds/T8359.hs +++ b/testsuite/tests/polykinds/T8359.hs @@ -1,4 +1,6 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE ConstraintKinds, MultiParamTypeClasses #-} + module T8359 where class DifferentTypes a b diff --git a/testsuite/tests/polykinds/T9569.hs b/testsuite/tests/polykinds/T9569.hs index 012d61fc31..0e1fdd596a 100644 --- a/testsuite/tests/polykinds/T9569.hs +++ b/testsuite/tests/polykinds/T9569.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE RankNTypes, ConstraintKinds, KindSignatures, DataKinds, TypeFamilies #-} module T9569 where diff --git a/testsuite/tests/polykinds/T9750.hs b/testsuite/tests/polykinds/T9750.hs index 9d865d08f6..59b8e60a31 100644 --- a/testsuite/tests/polykinds/T9750.hs +++ b/testsuite/tests/polykinds/T9750.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DataKinds #-} diff --git a/testsuite/tests/rebindable/T5821.hs b/testsuite/tests/rebindable/T5821.hs index 7b4f90558f..6adc356897 100644 --- a/testsuite/tests/rebindable/T5821.hs +++ b/testsuite/tests/rebindable/T5821.hs @@ -1,71 +1,72 @@ -{-# LANGUAGE
- ExplicitForAll
- , GADTs
- , RebindableSyntax #-}
-{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
-module T5821a
- ( Writer
- , runWriter
- , execWriter
- , WriterT
- , runWriterT
- , execWriterT
- , tell
- ) where
-
-import Control.Category (Category (id), (>>>))
-
-import Prelude hiding (Monad (..), id)
-import qualified Prelude
-
-newtype Identity a = Identity { runIdentity :: a }
-
-class Monad m where
- (>>=) :: forall e ex x a b . m e ex a -> (a -> m ex x b) -> m e x b
- (>>) :: forall e ex x a b . m e ex a -> m ex x b -> m e x b
- return :: a -> m ex ex a
- fail :: String -> m e x a
-
- {-# INLINE (>>) #-}
- m >> k = m >>= \ _ -> k
- fail = error
-
-type Writer w = WriterT w Identity
-
-runWriter :: Writer w e x a -> (a, w e x)
-runWriter = runIdentity . runWriterT
-
-execWriter :: Writer w e x a -> w e x
-execWriter m = snd (runWriter m)
-
-newtype WriterT w m e x a = WriterT { runWriterT :: m (a, w e x) }
-
-execWriterT :: Prelude.Monad m => WriterT w m e x a -> m (w e x)
-execWriterT m = do
- ~(_, w) <- runWriterT m
- return w
- where
- (>>=) = (Prelude.>>=)
- return = Prelude.return
-
-instance (Category w, Prelude.Monad m) => Monad (WriterT w m) where
- return a = WriterT $ return (a, id)
- where
- return = Prelude.return
- m >>= k = WriterT $ do
- ~(a, w) <- runWriterT m
- ~(b, w') <- runWriterT (k a)
- return (b, w >>> w')
- where
- (>>=) = (Prelude.>>=)
- return = Prelude.return
- fail msg = WriterT $ fail msg
- where
- fail = Prelude.fail
-
-tell :: (Category w, Prelude.Monad m) => w e x -> WriterT w m e x ()
-tell w = WriterT $ return ((), w)
- where
- return = Prelude.return
-
-
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# LANGUAGE + ExplicitForAll + , GADTs + , RebindableSyntax #-} +module T5821a + ( Writer + , runWriter + , execWriter + , WriterT + , runWriterT + , execWriterT + , tell + ) where + +import Control.Category (Category (id), (>>>)) + +import Prelude hiding (Monad (..), id) +import qualified Prelude + +newtype Identity a = Identity { runIdentity :: a } + +class Monad m where + (>>=) :: forall e ex x a b . m e ex a -> (a -> m ex x b) -> m e x b + (>>) :: forall e ex x a b . m e ex a -> m ex x b -> m e x b + return :: a -> m ex ex a + fail :: String -> m e x a + + {-# INLINE (>>) #-} + m >> k = m >>= \ _ -> k + fail = error + +type Writer w = WriterT w Identity + +runWriter :: Writer w e x a -> (a, w e x) +runWriter = runIdentity . runWriterT + +execWriter :: Writer w e x a -> w e x +execWriter m = snd (runWriter m) + +newtype WriterT w m e x a = WriterT { runWriterT :: m (a, w e x) } + +execWriterT :: Prelude.Monad m => WriterT w m e x a -> m (w e x) +execWriterT m = do + ~(_, w) <- runWriterT m + return w + where + (>>=) = (Prelude.>>=) + return = Prelude.return + +instance (Category w, Prelude.Monad m) => Monad (WriterT w m) where + return a = WriterT $ return (a, id) + where + return = Prelude.return + m >>= k = WriterT $ do + ~(a, w) <- runWriterT m + ~(b, w') <- runWriterT (k a) + return (b, w >>> w') + where + (>>=) = (Prelude.>>=) + return = Prelude.return + fail msg = WriterT $ fail msg + where + fail = Prelude.fail + +tell :: (Category w, Prelude.Monad m) => w e x -> WriterT w m e x () +tell w = WriterT $ return ((), w) + where + return = Prelude.return + + diff --git a/testsuite/tests/rebindable/rebindable9.hs b/testsuite/tests/rebindable/rebindable9.hs index 120a93a3a4..cd3c95ab62 100644 --- a/testsuite/tests/rebindable/rebindable9.hs +++ b/testsuite/tests/rebindable/rebindable9.hs @@ -34,8 +34,8 @@ instance Bind Maybe [] [] where Just x >>= f = f x Nothing >>= f = [] -instance Functor a => Bind Identity a a where m >>= f = f (runIdentity m) -instance Functor a => Bind a Identity a where m >>= f = fmap (runIdentity . f) m +instance Bind Identity a a where m >>= f = f (runIdentity m) +instance Functor a => Bind a Identity a where m >>= f = fmap (runIdentity . f) m instance Prelude.Monad m => Bind m m m where (>>=) = (Prelude.>>=) diff --git a/testsuite/tests/rename/should_fail/rnfail020.hs b/testsuite/tests/rename/should_fail/rnfail020.hs index decd2e80ad..c6efc4d5f7 100644 --- a/testsuite/tests/rename/should_fail/rnfail020.hs +++ b/testsuite/tests/rename/should_fail/rnfail020.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE ScopedTypeVariables #-} -- !!! Error messages with scoped type variables diff --git a/testsuite/tests/simplCore/should_compile/T3831.hs b/testsuite/tests/simplCore/should_compile/T3831.hs index 50b1e3567b..9eeb0a20c4 100644 --- a/testsuite/tests/simplCore/should_compile/T3831.hs +++ b/testsuite/tests/simplCore/should_compile/T3831.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE ScopedTypeVariables, FlexibleInstances #-} -- This test has a deep nest of join points, which led to diff --git a/testsuite/tests/simplCore/should_compile/T4398.hs b/testsuite/tests/simplCore/should_compile/T4398.hs index 3cb0647c1c..43463a1885 100644 --- a/testsuite/tests/simplCore/should_compile/T4398.hs +++ b/testsuite/tests/simplCore/should_compile/T4398.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE FlexibleContexts #-} module T4398 where diff --git a/testsuite/tests/simplCore/should_compile/T4398.stderr b/testsuite/tests/simplCore/should_compile/T4398.stderr index 2f1f567d49..e2411e13c7 100644 --- a/testsuite/tests/simplCore/should_compile/T4398.stderr +++ b/testsuite/tests/simplCore/should_compile/T4398.stderr @@ -1,22 +1,22 @@ -
-T4398.hs:5:11: Warning:
- Forall'd constraint ‘Ord a’ is not bound in RULE lhs
- Orig bndrs: [a, $dOrd, x, y]
- Orig lhs: let {
- $dEq :: Eq a
- [LclId, Str=DmdType]
- $dEq = GHC.Classes.$p1Ord @ a $dOrd } in
- f @ a
- ((\ ($dOrd :: Ord a) ->
- let {
- $dEq :: Eq a
- [LclId, Str=DmdType]
- $dEq = GHC.Classes.$p1Ord @ a $dOrd } in
- let {
- $dEq :: Eq a
- [LclId, Str=DmdType]
- $dEq = GHC.Classes.$p1Ord @ a $dOrd } in
- x)
- $dOrd)
- y
- optimised lhs: f @ a x y
+ +T4398.hs:6:11: Warning: + Forall'd constraint ‘Ord a’ is not bound in RULE lhs + Orig bndrs: [a, $dOrd, x, y] + Orig lhs: let { + $dEq :: Eq a + [LclId, Str=DmdType] + $dEq = GHC.Classes.$p1Ord @ a $dOrd } in + f @ a + ((\ ($dOrd :: Ord a) -> + let { + $dEq :: Eq a + [LclId, Str=DmdType] + $dEq = GHC.Classes.$p1Ord @ a $dOrd } in + let { + $dEq :: Eq a + [LclId, Str=DmdType] + $dEq = GHC.Classes.$p1Ord @ a $dOrd } in + x) + $dOrd) + y + optimised lhs: f @ a x y diff --git a/testsuite/tests/simplCore/should_compile/T5329.hs b/testsuite/tests/simplCore/should_compile/T5329.hs index cf659110ca..f681103578 100644 --- a/testsuite/tests/simplCore/should_compile/T5329.hs +++ b/testsuite/tests/simplCore/should_compile/T5329.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE UnicodeSyntax #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE TypeOperators #-} diff --git a/testsuite/tests/simplCore/should_compile/T5342.hs b/testsuite/tests/simplCore/should_compile/T5342.hs index eedd7047f5..c9a3130313 100644 --- a/testsuite/tests/simplCore/should_compile/T5342.hs +++ b/testsuite/tests/simplCore/should_compile/T5342.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} module T5342 (increaseAreas) where import Control.Monad diff --git a/testsuite/tests/simplCore/should_compile/T5359b.hs b/testsuite/tests/simplCore/should_compile/T5359b.hs index f1ce2091a9..bff4b49d87 100644 --- a/testsuite/tests/simplCore/should_compile/T5359b.hs +++ b/testsuite/tests/simplCore/should_compile/T5359b.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} diff --git a/testsuite/tests/simplCore/should_compile/T5359b.stderr b/testsuite/tests/simplCore/should_compile/T5359b.stderr index 2802476a2d..75dde28fcc 100644 --- a/testsuite/tests/simplCore/should_compile/T5359b.stderr +++ b/testsuite/tests/simplCore/should_compile/T5359b.stderr @@ -1,3 +1,3 @@ -T5359b.hs:61:1: Warning: +T5359b.hs:62:1: Warning: SPECIALISE pragma on INLINE function probably won't fire: ‘genum’ diff --git a/testsuite/tests/simplCore/should_compile/T8848.hs b/testsuite/tests/simplCore/should_compile/T8848.hs index 1ddfe94596..d0f48bdbda 100644 --- a/testsuite/tests/simplCore/should_compile/T8848.hs +++ b/testsuite/tests/simplCore/should_compile/T8848.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE KindSignatures, GADTs, DataKinds, FlexibleInstances, FlexibleContexts #-} {-# OPTIONS_GHC -fno-warn-missing-methods #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} +{-# LANGUAGE KindSignatures, GADTs, DataKinds, FlexibleInstances, FlexibleContexts #-} module T8848 where diff --git a/testsuite/tests/simplCore/should_compile/T8848.stderr b/testsuite/tests/simplCore/should_compile/T8848.stderr index 23ada00c16..4cb138537b 100644 --- a/testsuite/tests/simplCore/should_compile/T8848.stderr +++ b/testsuite/tests/simplCore/should_compile/T8848.stderr @@ -1,77 +1,77 @@ -Rule fired: Class op pure
-Rule fired: Class op <*>
-Rule fired: Class op <*>
-Rule fired: SPEC map2
-Rule fired: Class op fmap
-Rule fired: Class op $p1Applicative
-Rule fired: Class op fmap
-Rule fired: Class op <*>
-Rule fired: Class op $p1Applicative
-Rule fired: Class op <$
-Rule fired: Class op <*>
-Rule fired: Class op $p1Applicative
-Rule fired: Class op $p1Applicative
-Rule fired: Class op fmap
-Rule fired: Class op <*>
-Rule fired: SPEC/T8848 liftA2 _ _ _ @ (Shape 'Z)
-Rule fired: Class op $p1Applicative
-Rule fired: Class op $p1Applicative
-Rule fired: Class op <$
-Rule fired: Class op <*>
-Rule fired: Class op $p1Applicative
-Rule fired: Class op <$
-Rule fired: Class op <*>
-Rule fired: Class op $p1Applicative
-Rule fired: Class op fmap
-Rule fired: Class op <*>
-Rule fired: Class op fmap
-Rule fired: Class op fmap
-Rule fired: SPEC $cfmap @ 'Z
-Rule fired: SPEC $c<$ @ 'Z
-Rule fired: SPEC $fFunctorShape @ 'Z
-Rule fired: Class op fmap
-Rule fired: Class op fmap
-Rule fired: SPEC $c<$ @ 'Z
-Rule fired: SPEC $fFunctorShape @ 'Z
-Rule fired: Class op $p1Applicative
-Rule fired: SPEC $fFunctorShape @ 'Z
-Rule fired: SPEC $cp0Applicative @ 'Z
-Rule fired: SPEC $cpure @ 'Z
-Rule fired: SPEC $c<*> @ 'Z
-Rule fired: SPEC $c*> @ 'Z
-Rule fired: SPEC $c<* @ 'Z
-Rule fired: SPEC $fApplicativeShape @ 'Z
-Rule fired: SPEC $fApplicativeShape @ 'Z
-Rule fired: Class op $p1Applicative
-Rule fired: Class op fmap
-Rule fired: Class op <*>
-Rule fired: Class op $p1Applicative
-Rule fired: Class op <$
-Rule fired: Class op <*>
-Rule fired: Class op $p1Applicative
-Rule fired: Class op fmap
-Rule fired: Class op <*>
-Rule fired: Class op $p1Applicative
-Rule fired: Class op <$
-Rule fired: Class op <*>
-Rule fired: SPEC $c<* @ 'Z
-Rule fired: SPEC $c*> @ 'Z
-Rule fired: SPEC $fApplicativeShape @ 'Z
-Rule fired: SPEC $fApplicativeShape @ 'Z
-Rule fired: Class op $p1Applicative
-Rule fired: Class op fmap
-Rule fired: Class op <*>
-Rule fired: SPEC/T8848 liftA2 _ _ _ @ (Shape ('S 'Z))
-Rule fired: Class op $p1Applicative
-Rule fired: Class op fmap
-Rule fired: Class op <*>
-Rule fired: SPEC $fApplicativeShape @ 'Z
-Rule fired: Class op $p1Applicative
-Rule fired: Class op <$
-Rule fired: Class op <*>
-Rule fired: Class op $p1Applicative
-Rule fired: Class op <$
-Rule fired: Class op <*>
-Rule fired: SPEC $fFunctorShape @ 'Z
-Rule fired: Class op fmap
-Rule fired: Class op fmap
+Rule fired: Class op pure +Rule fired: Class op <*> +Rule fired: Class op <*> +Rule fired: SPEC map2 +Rule fired: Class op fmap +Rule fired: Class op $p1Applicative +Rule fired: Class op fmap +Rule fired: Class op <*> +Rule fired: Class op $p1Applicative +Rule fired: Class op <$ +Rule fired: Class op <*> +Rule fired: Class op $p1Applicative +Rule fired: Class op $p1Applicative +Rule fired: Class op fmap +Rule fired: Class op <*> +Rule fired: SPEC/T8848 liftA2 _ _ _ @ (Shape 'Z) +Rule fired: Class op $p1Applicative +Rule fired: Class op $p1Applicative +Rule fired: Class op <$ +Rule fired: Class op <*> +Rule fired: Class op $p1Applicative +Rule fired: Class op <$ +Rule fired: Class op <*> +Rule fired: Class op $p1Applicative +Rule fired: Class op fmap +Rule fired: Class op <*> +Rule fired: Class op fmap +Rule fired: Class op fmap +Rule fired: SPEC $cfmap @ 'Z +Rule fired: SPEC $c<$ @ 'Z +Rule fired: SPEC $fFunctorShape @ 'Z +Rule fired: Class op fmap +Rule fired: Class op fmap +Rule fired: SPEC $c<$ @ 'Z +Rule fired: SPEC $fFunctorShape @ 'Z +Rule fired: Class op $p1Applicative +Rule fired: SPEC $fFunctorShape @ 'Z +Rule fired: SPEC $cp1Applicative @ 'Z +Rule fired: SPEC $cpure @ 'Z +Rule fired: SPEC $c<*> @ 'Z +Rule fired: SPEC $c*> @ 'Z +Rule fired: SPEC $c<* @ 'Z +Rule fired: SPEC $fApplicativeShape @ 'Z +Rule fired: SPEC $fApplicativeShape @ 'Z +Rule fired: Class op $p1Applicative +Rule fired: Class op fmap +Rule fired: Class op <*> +Rule fired: Class op $p1Applicative +Rule fired: Class op <$ +Rule fired: Class op <*> +Rule fired: Class op $p1Applicative +Rule fired: Class op fmap +Rule fired: Class op <*> +Rule fired: Class op $p1Applicative +Rule fired: Class op <$ +Rule fired: Class op <*> +Rule fired: SPEC $c<* @ 'Z +Rule fired: SPEC $c*> @ 'Z +Rule fired: SPEC $fApplicativeShape @ 'Z +Rule fired: SPEC $fApplicativeShape @ 'Z +Rule fired: Class op $p1Applicative +Rule fired: Class op fmap +Rule fired: Class op <*> +Rule fired: SPEC/T8848 liftA2 _ _ _ @ (Shape ('S 'Z)) +Rule fired: Class op $p1Applicative +Rule fired: Class op fmap +Rule fired: Class op <*> +Rule fired: SPEC $fApplicativeShape @ 'Z +Rule fired: Class op $p1Applicative +Rule fired: Class op <$ +Rule fired: Class op <*> +Rule fired: Class op $p1Applicative +Rule fired: Class op <$ +Rule fired: Class op <*> +Rule fired: SPEC $fFunctorShape @ 'Z +Rule fired: Class op fmap +Rule fired: Class op fmap diff --git a/testsuite/tests/simplCore/should_compile/T8848a.hs b/testsuite/tests/simplCore/should_compile/T8848a.hs index 81e757f8c2..9df4c5be84 100644 --- a/testsuite/tests/simplCore/should_compile/T8848a.hs +++ b/testsuite/tests/simplCore/should_compile/T8848a.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} module T8848a where f :: Ord a => b -> a -> a diff --git a/testsuite/tests/simplCore/should_compile/simpl002.hs b/testsuite/tests/simplCore/should_compile/simpl002.hs index b262f47d38..acb0a146e7 100644 --- a/testsuite/tests/simplCore/should_compile/simpl002.hs +++ b/testsuite/tests/simplCore/should_compile/simpl002.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} + -- !!! class/instance mumble that failed Lint at one time -- module ShouldCompile where diff --git a/testsuite/tests/simplCore/should_compile/simpl007.hs b/testsuite/tests/simplCore/should_compile/simpl007.hs index c7277b7f66..0b22564e68 100644 --- a/testsuite/tests/simplCore/should_compile/simpl007.hs +++ b/testsuite/tests/simplCore/should_compile/simpl007.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE UndecidableInstances, ExistentialQuantification, FlexibleInstances #-} diff --git a/testsuite/tests/simplCore/should_compile/simpl014.hs b/testsuite/tests/simplCore/should_compile/simpl014.hs index 2f2e78fa76..fe603dd666 100644 --- a/testsuite/tests/simplCore/should_compile/simpl014.hs +++ b/testsuite/tests/simplCore/should_compile/simpl014.hs @@ -1,4 +1,5 @@ {-# LANGUAGE RankNTypes, GADTs, FlexibleContexts #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# OPTIONS_GHC -O2 #-} -- This one make SpecConstr generate bogus code (hence -O2), diff --git a/testsuite/tests/simplCore/should_compile/simpl016.hs b/testsuite/tests/simplCore/should_compile/simpl016.hs index 6ba088e6fa..4f371a78f0 100644 --- a/testsuite/tests/simplCore/should_compile/simpl016.hs +++ b/testsuite/tests/simplCore/should_compile/simpl016.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} + -- Test for trac ticket #1287; ghc 6.6 and 6.6.1 panicked on this module ShouldCompile where diff --git a/testsuite/tests/simplCore/should_compile/simpl016.stderr b/testsuite/tests/simplCore/should_compile/simpl016.stderr index e08b16db8d..b59faae1fd 100644 --- a/testsuite/tests/simplCore/should_compile/simpl016.stderr +++ b/testsuite/tests/simplCore/should_compile/simpl016.stderr @@ -1,10 +1,10 @@ -
-simpl016.hs:5:1: Warning:
- Forall'd constraint ‘Num b’ is not bound in RULE lhs
- Orig bndrs: [b, $dNum]
- Orig lhs: let {
- $dEq :: Eq Int
- [LclId, Str=DmdType]
- $dEq = GHC.Classes.$fEqInt } in
- delta' @ Int @ b $dEq
- optimised lhs: delta' @ Int @ b $dEq
+ +simpl016.hs:7:1: Warning: + Forall'd constraint ‘Num b’ is not bound in RULE lhs + Orig bndrs: [b, $dNum] + Orig lhs: let { + $dEq :: Eq Int + [LclId, Str=DmdType] + $dEq = GHC.Classes.$fEqInt } in + delta' @ Int @ b $dEq + optimised lhs: delta' @ Int @ b $dEq diff --git a/testsuite/tests/simplCore/should_compile/spec003.hs b/testsuite/tests/simplCore/should_compile/spec003.hs index 7ebb901106..5ea6d33283 100644 --- a/testsuite/tests/simplCore/should_compile/spec003.hs +++ b/testsuite/tests/simplCore/should_compile/spec003.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} + -- Trac #1402 -- Broke the specialiser diff --git a/testsuite/tests/th/T3100.hs b/testsuite/tests/th/T3100.hs index edb943933a..9e529f13db 100644 --- a/testsuite/tests/th/T3100.hs +++ b/testsuite/tests/th/T3100.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE RankNTypes, FlexibleContexts, ImplicitParams, TemplateHaskell #-} -- This test makes sure TH understands types where diff --git a/testsuite/tests/th/T7021a.hs b/testsuite/tests/th/T7021a.hs index 0eadecf4c6..b07ef55196 100644 --- a/testsuite/tests/th/T7021a.hs +++ b/testsuite/tests/th/T7021a.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE ConstraintKinds, TemplateHaskell, PolyKinds, TypeFamilies, RankNTypes #-} module T7021a where diff --git a/testsuite/tests/th/T8807.hs b/testsuite/tests/th/T8807.hs index 7d21796298..17157bfbd2 100644 --- a/testsuite/tests/th/T8807.hs +++ b/testsuite/tests/th/T8807.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE ConstraintKinds, RankNTypes #-} module T8807 where diff --git a/testsuite/tests/th/TH_tf3.hs b/testsuite/tests/th/TH_tf3.hs index 08e089fdf1..a45cb30799 100644 --- a/testsuite/tests/th/TH_tf3.hs +++ b/testsuite/tests/th/TH_tf3.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE TypeFamilies, FlexibleInstances, UndecidableInstances #-} module TH_tf3 where diff --git a/testsuite/tests/typecheck/should_compile/GivenOverlapping.hs b/testsuite/tests/typecheck/should_compile/GivenOverlapping.hs index 35f4b07962..68d0dd4714 100644 --- a/testsuite/tests/typecheck/should_compile/GivenOverlapping.hs +++ b/testsuite/tests/typecheck/should_compile/GivenOverlapping.hs @@ -1,21 +1,22 @@ -{-# LANGUAGE FunctionalDependencies, FlexibleContexts #-}
-
-class C a where
-
-class D a where
- dop :: a -> a
-
-instance C a => D [a] where
- dop = undefined
-
-class J a b | a -> b
- where j :: a -> b -> ()
-
-instance J Bool Int where
- j = undefined
-
-foo :: D [Int] => ()
-foo = j True (head (dop [undefined]))
-
-main = return ()
-
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} +{-# LANGUAGE FunctionalDependencies, FlexibleContexts #-} + +class C a where + +class D a where + dop :: a -> a + +instance C a => D [a] where + dop = undefined + +class J a b | a -> b + where j :: a -> b -> () + +instance J Bool Int where + j = undefined + +foo :: D [Int] => () +foo = j True (head (dop [undefined])) + +main = return () + diff --git a/testsuite/tests/typecheck/should_compile/LoopOfTheDay1.hs b/testsuite/tests/typecheck/should_compile/LoopOfTheDay1.hs index e3b656a66e..860b9ede24 100644 --- a/testsuite/tests/typecheck/should_compile/LoopOfTheDay1.hs +++ b/testsuite/tests/typecheck/should_compile/LoopOfTheDay1.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, UndecidableInstances #-} -- Compiles fine. diff --git a/testsuite/tests/typecheck/should_compile/LoopOfTheDay2.hs b/testsuite/tests/typecheck/should_compile/LoopOfTheDay2.hs index 0996e7c2f2..356fc728e0 100644 --- a/testsuite/tests/typecheck/should_compile/LoopOfTheDay2.hs +++ b/testsuite/tests/typecheck/should_compile/LoopOfTheDay2.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, UndecidableInstances #-} -- Compilation loops in GHC 6.2! diff --git a/testsuite/tests/typecheck/should_compile/LoopOfTheDay3.hs b/testsuite/tests/typecheck/should_compile/LoopOfTheDay3.hs index f1c1b49839..f83b151cb1 100644 --- a/testsuite/tests/typecheck/should_compile/LoopOfTheDay3.hs +++ b/testsuite/tests/typecheck/should_compile/LoopOfTheDay3.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, UndecidableInstances #-} diff --git a/testsuite/tests/typecheck/should_compile/T1470.hs b/testsuite/tests/typecheck/should_compile/T1470.hs index 2482696452..3206fa8a95 100644 --- a/testsuite/tests/typecheck/should_compile/T1470.hs +++ b/testsuite/tests/typecheck/should_compile/T1470.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, UndecidableInstances, KindSignatures #-} -- Trac #1470 diff --git a/testsuite/tests/typecheck/should_compile/T2683.hs b/testsuite/tests/typecheck/should_compile/T2683.hs index 07fad170c6..9f3591af46 100644 --- a/testsuite/tests/typecheck/should_compile/T2683.hs +++ b/testsuite/tests/typecheck/should_compile/T2683.hs @@ -1,31 +1,32 @@ -{-# LANGUAGE ExistentialQuantification, MultiParamTypeClasses,
- FunctionalDependencies, RankNTypes #-}
-
-module Q where
-
-class Transformer t a | t -> a where
- transform :: t -> l a -> (forall l'. l' a -> b) -> b
-
-data EL a = forall l. EL (l a)
-
-unEL :: EL a -> (forall l. l a -> b) -> b
-unEL = error "unEL"
-
-transform' :: (Transformer t a) => t -> EL a -> EL a
-transform' = error "transform'"
-
-data MultiToggleS ts a = MultiToggleS ts
-
-data MultiToggle = MultiToggle
-
-expand :: HList ts a => MultiToggleS ts a -> MultiToggle
-expand (MultiToggleS ts) =
- resolve ts
- (\x mt ->
- let g = transform' x in
- mt
- )
- MultiToggle
-
-class HList c a | c -> a where
- resolve :: c -> (forall t. (Transformer t a) => t -> b) -> b
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} +{-# LANGUAGE ExistentialQuantification, MultiParamTypeClasses, + FunctionalDependencies, RankNTypes #-} + +module Q where + +class Transformer t a | t -> a where + transform :: t -> l a -> (forall l'. l' a -> b) -> b + +data EL a = forall l. EL (l a) + +unEL :: EL a -> (forall l. l a -> b) -> b +unEL = error "unEL" + +transform' :: (Transformer t a) => t -> EL a -> EL a +transform' = error "transform'" + +data MultiToggleS ts a = MultiToggleS ts + +data MultiToggle = MultiToggle + +expand :: HList ts a => MultiToggleS ts a -> MultiToggle +expand (MultiToggleS ts) = + resolve ts + (\x mt -> + let g = transform' x in + mt + ) + MultiToggle + +class HList c a | c -> a where + resolve :: c -> (forall t. (Transformer t a) => t -> b) -> b diff --git a/testsuite/tests/typecheck/should_compile/T3018.hs b/testsuite/tests/typecheck/should_compile/T3018.hs index 296185de30..bf178e0898 100644 --- a/testsuite/tests/typecheck/should_compile/T3018.hs +++ b/testsuite/tests/typecheck/should_compile/T3018.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -w #-} {-# LANGUAGE UndecidableInstances, EmptyDataDecls #-} {-# LANGUAGE RankNTypes, KindSignatures, MultiParamTypeClasses, FlexibleInstances #-} diff --git a/testsuite/tests/typecheck/should_compile/T3108.hs b/testsuite/tests/typecheck/should_compile/T3108.hs index 2adaa1aef7..f2ac8d536e 100644 --- a/testsuite/tests/typecheck/should_compile/T3108.hs +++ b/testsuite/tests/typecheck/should_compile/T3108.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE UndecidableInstances, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-} diff --git a/testsuite/tests/typecheck/should_compile/T3692.hs b/testsuite/tests/typecheck/should_compile/T3692.hs index 9fccb0a52f..5be093f55f 100644 --- a/testsuite/tests/typecheck/should_compile/T3692.hs +++ b/testsuite/tests/typecheck/should_compile/T3692.hs @@ -1,10 +1,11 @@ -{-# LANGUAGE RankNTypes #-}
-
-module T3692 where
-
-type Foo a b = () -> (Bar a => a)
-
-class Bar a where {}
-
-foo :: Foo a b
-foo = id (undefined :: Foo p q)
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} +{-# LANGUAGE RankNTypes #-} + +module T3692 where + +type Foo a b = () -> (Bar a => a) + +class Bar a where {} + +foo :: Foo a b +foo = id (undefined :: Foo p q) diff --git a/testsuite/tests/typecheck/should_compile/T3743.hs b/testsuite/tests/typecheck/should_compile/T3743.hs index cc8c6cca23..fd1b1d14b4 100644 --- a/testsuite/tests/typecheck/should_compile/T3743.hs +++ b/testsuite/tests/typecheck/should_compile/T3743.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE ImplicitParams, GADTs #-} module T3743 where diff --git a/testsuite/tests/typecheck/should_compile/T4361.hs b/testsuite/tests/typecheck/should_compile/T4361.hs index 725d12088e..ee5a9cc3cb 100644 --- a/testsuite/tests/typecheck/should_compile/T4361.hs +++ b/testsuite/tests/typecheck/should_compile/T4361.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE FlexibleContexts #-} -- This test comes from Sergei Mechveliani's DoCon system diff --git a/testsuite/tests/typecheck/should_compile/T4401.hs b/testsuite/tests/typecheck/should_compile/T4401.hs index 81fcf71a96..23ee12cadb 100644 --- a/testsuite/tests/typecheck/should_compile/T4401.hs +++ b/testsuite/tests/typecheck/should_compile/T4401.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE FlexibleInstances, UndecidableInstances, MultiParamTypeClasses, FunctionalDependencies #-} module T4401 where diff --git a/testsuite/tests/typecheck/should_compile/T4524.hs b/testsuite/tests/typecheck/should_compile/T4524.hs index 27cbb1f7e0..669c4b268a 100644 --- a/testsuite/tests/typecheck/should_compile/T4524.hs +++ b/testsuite/tests/typecheck/should_compile/T4524.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE GADTs, TypeOperators, diff --git a/testsuite/tests/typecheck/should_compile/T4952.hs b/testsuite/tests/typecheck/should_compile/T4952.hs index 42d6258c2f..0788ad148a 100644 --- a/testsuite/tests/typecheck/should_compile/T4952.hs +++ b/testsuite/tests/typecheck/should_compile/T4952.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE UndecidableInstances, MultiParamTypeClasses, KindSignatures, diff --git a/testsuite/tests/typecheck/should_compile/T4969.hs b/testsuite/tests/typecheck/should_compile/T4969.hs index e35b37eb27..6a087974c7 100644 --- a/testsuite/tests/typecheck/should_compile/T4969.hs +++ b/testsuite/tests/typecheck/should_compile/T4969.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -w #-} +{-# OPTIONS_GHC -w -fno-warn-redundant-constraints #-} {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts, FlexibleInstances, OverlappingInstances, UndecidableInstances, diff --git a/testsuite/tests/typecheck/should_compile/T5514.hs b/testsuite/tests/typecheck/should_compile/T5514.hs index 71a01bad39..9b8821ecd4 100644 --- a/testsuite/tests/typecheck/should_compile/T5514.hs +++ b/testsuite/tests/typecheck/should_compile/T5514.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} module T5514 where class Foo a where diff --git a/testsuite/tests/typecheck/should_compile/T5581.hs b/testsuite/tests/typecheck/should_compile/T5581.hs index 0e957285f8..074a2babcd 100644 --- a/testsuite/tests/typecheck/should_compile/T5581.hs +++ b/testsuite/tests/typecheck/should_compile/T5581.hs @@ -1,4 +1,6 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE ConstraintKinds, FlexibleContexts, FlexibleInstances, KindSignatures #-} + module TcShouldTerminate where import GHC.Prim (Constraint) diff --git a/testsuite/tests/typecheck/should_compile/T5676.hs b/testsuite/tests/typecheck/should_compile/T5676.hs index 9fa8404b0b..c35fc2688d 100644 --- a/testsuite/tests/typecheck/should_compile/T5676.hs +++ b/testsuite/tests/typecheck/should_compile/T5676.hs @@ -1,19 +1,20 @@ -{-# LANGUAGE ScopedTypeVariables, InstanceSigs #-}
-module Foo where
-
-data T a = T a
-
-class C a where
- foo :: b -> a -> (a, [b])
-
-instance C a => C (T a) where
- foo :: forall b. b -> T a -> (T a, [b])
- foo x (T y) = (T y, xs)
- where
- xs :: [b]
- xs = [x,x,x]
-
-instance Functor T where
- fmap :: (a -> b) -> T a -> T b
- fmap f (T x) = T (f x)
-
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} +{-# LANGUAGE ScopedTypeVariables, InstanceSigs #-} +module Foo where + +data T a = T a + +class C a where + foo :: b -> a -> (a, [b]) + +instance C a => C (T a) where + foo :: forall b. b -> T a -> (T a, [b]) + foo x (T y) = (T y, xs) + where + xs :: [b] + xs = [x,x,x] + +instance Functor T where + fmap :: (a -> b) -> T a -> T b + fmap f (T x) = T (f x) + diff --git a/testsuite/tests/typecheck/should_compile/T6055.hs b/testsuite/tests/typecheck/should_compile/T6055.hs index dcc39d1618..f5fc354af2 100644 --- a/testsuite/tests/typecheck/should_compile/T6055.hs +++ b/testsuite/tests/typecheck/should_compile/T6055.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} diff --git a/testsuite/tests/typecheck/should_compile/T6134.hs b/testsuite/tests/typecheck/should_compile/T6134.hs index 90f1504a48..1421a13b89 100644 --- a/testsuite/tests/typecheck/should_compile/T6134.hs +++ b/testsuite/tests/typecheck/should_compile/T6134.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, FunctionalDependencies #-} module T6134 where diff --git a/testsuite/tests/typecheck/should_compile/T7171a.hs b/testsuite/tests/typecheck/should_compile/T7171a.hs index c2d7ec9bca..a25c31b9e1 100644 --- a/testsuite/tests/typecheck/should_compile/T7171a.hs +++ b/testsuite/tests/typecheck/should_compile/T7171a.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FlexibleInstances #-} module T7171a where diff --git a/testsuite/tests/typecheck/should_compile/T7196.hs b/testsuite/tests/typecheck/should_compile/T7196.hs index 29242b27fd..f4c54c5119 100644 --- a/testsuite/tests/typecheck/should_compile/T7196.hs +++ b/testsuite/tests/typecheck/should_compile/T7196.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} diff --git a/testsuite/tests/typecheck/should_compile/T7220.hs b/testsuite/tests/typecheck/should_compile/T7220.hs index bf4df871f5..99e9a970c3 100644 --- a/testsuite/tests/typecheck/should_compile/T7220.hs +++ b/testsuite/tests/typecheck/should_compile/T7220.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MultiParamTypeClasses #-} diff --git a/testsuite/tests/typecheck/should_compile/T7541.hs b/testsuite/tests/typecheck/should_compile/T7541.hs index e0ae55a50d..6292858bd8 100644 --- a/testsuite/tests/typecheck/should_compile/T7541.hs +++ b/testsuite/tests/typecheck/should_compile/T7541.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -fno-warn-duplicate-constraints #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE FlexibleContexts, Rank2Types #-} module Test where diff --git a/testsuite/tests/typecheck/should_compile/T7875.hs b/testsuite/tests/typecheck/should_compile/T7875.hs index 9a8bf460cd..471a2e2d7d 100644 --- a/testsuite/tests/typecheck/should_compile/T7875.hs +++ b/testsuite/tests/typecheck/should_compile/T7875.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE FlexibleContexts , FlexibleInstances diff --git a/testsuite/tests/typecheck/should_compile/T7903.hs b/testsuite/tests/typecheck/should_compile/T7903.hs index 662af0c854..e631677806 100644 --- a/testsuite/tests/typecheck/should_compile/T7903.hs +++ b/testsuite/tests/typecheck/should_compile/T7903.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE KindSignatures #-} module T7903 where diff --git a/testsuite/tests/typecheck/should_compile/T7903.stderr-ghc b/testsuite/tests/typecheck/should_compile/T7903.stderr-ghc index 2214c3531f..7020e1c0e5 100644 --- a/testsuite/tests/typecheck/should_compile/T7903.stderr-ghc +++ b/testsuite/tests/typecheck/should_compile/T7903.stderr-ghc @@ -1,10 +1,10 @@ -T7903.hs:5:10: Warning: +T7903.hs:6:10: Warning: No explicit implementation for either ‘==’ or ‘/=’ In the instance declaration for ‘Eq (a -> b)’ -T7903.hs:6:10: Warning: +T7903.hs:7:10: Warning: No explicit implementation for either ‘compare’ or ‘<=’ In the instance declaration for ‘Ord (a -> b)’ diff --git a/testsuite/tests/typecheck/should_compile/Tc170_Aux.hs b/testsuite/tests/typecheck/should_compile/Tc170_Aux.hs index c7cd186f13..da9b773f28 100644 --- a/testsuite/tests/typecheck/should_compile/Tc170_Aux.hs +++ b/testsuite/tests/typecheck/should_compile/Tc170_Aux.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} module Tc170_Aux where diff --git a/testsuite/tests/typecheck/should_compile/Tc173a.hs b/testsuite/tests/typecheck/should_compile/Tc173a.hs index f3704ccd9a..99e8471ae0 100644 --- a/testsuite/tests/typecheck/should_compile/Tc173a.hs +++ b/testsuite/tests/typecheck/should_compile/Tc173a.hs @@ -1,4 +1,6 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE FlexibleInstances, TypeSynonymInstances, UndecidableInstances #-} + module Tc173a where class FormValue value where diff --git a/testsuite/tests/typecheck/should_compile/tc045.hs b/testsuite/tests/typecheck/should_compile/tc045.hs index 4ff3766673..acaad96b36 100644 --- a/testsuite/tests/typecheck/should_compile/tc045.hs +++ b/testsuite/tests/typecheck/should_compile/tc045.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} module ShouldSucceed where class C a where diff --git a/testsuite/tests/typecheck/should_compile/tc051.hs b/testsuite/tests/typecheck/should_compile/tc051.hs index 7f14282fb8..e02143a5f1 100644 --- a/testsuite/tests/typecheck/should_compile/tc051.hs +++ b/testsuite/tests/typecheck/should_compile/tc051.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} + module ShouldSucceed where class Eq' a where diff --git a/testsuite/tests/typecheck/should_compile/tc056.stderr b/testsuite/tests/typecheck/should_compile/tc056.stderr index 0c8f669b30..11641ff186 100644 --- a/testsuite/tests/typecheck/should_compile/tc056.stderr +++ b/testsuite/tests/typecheck/should_compile/tc056.stderr @@ -1,6 +1,4 @@ -tc056.hs:16:10: Warning: - Duplicate constraint(s): Eq' a - In the context: (Eq' a, Eq' a) - While checking an instance declaration +tc056.hs:16:10: + Redundant constraints: (Eq' a, Eq' a) In the instance declaration for ‘Eq' [a]’ diff --git a/testsuite/tests/typecheck/should_compile/tc058.hs b/testsuite/tests/typecheck/should_compile/tc058.hs index 7df1f3bc6d..1bd10feb93 100644 --- a/testsuite/tests/typecheck/should_compile/tc058.hs +++ b/testsuite/tests/typecheck/should_compile/tc058.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} + module ShouldSucceed where class Eq2 a where diff --git a/testsuite/tests/typecheck/should_compile/tc065.hs b/testsuite/tests/typecheck/should_compile/tc065.hs index 1d47cf35c4..510eca6103 100644 --- a/testsuite/tests/typecheck/should_compile/tc065.hs +++ b/testsuite/tests/typecheck/should_compile/tc065.hs @@ -68,7 +68,7 @@ type FlattenedDependencyInfo vertex name code mkVertices :: FlattenedDependencyInfo vertex name code -> [vertex] mkVertices info = [ vertex | (vertex,_,_,_) <- info] -mkEdges :: (Eq vertex, Ord name) => +mkEdges :: (Ord name) => [vertex] -> FlattenedDependencyInfo vertex name code -> [Edge vertex] @@ -85,7 +85,7 @@ mkEdges vertices flat_info name `Set.member` names_defined ] -lookupVertex :: (Eq vertex, Ord name) => +lookupVertex :: (Eq vertex) => FlattenedDependencyInfo vertex name code -> vertex -> code diff --git a/testsuite/tests/typecheck/should_compile/tc078.hs b/testsuite/tests/typecheck/should_compile/tc078.hs index de5e748d20..2bd1ebd062 100644 --- a/testsuite/tests/typecheck/should_compile/tc078.hs +++ b/testsuite/tests/typecheck/should_compile/tc078.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} + -- !!! instance decls with no binds -- module ShouldFail where diff --git a/testsuite/tests/typecheck/should_compile/tc078.stderr-ghc b/testsuite/tests/typecheck/should_compile/tc078.stderr-ghc index bb5d9f566e..fa9d3acd2e 100644 --- a/testsuite/tests/typecheck/should_compile/tc078.stderr-ghc +++ b/testsuite/tests/typecheck/should_compile/tc078.stderr-ghc @@ -1,10 +1,10 @@ -tc078.hs:7:10: Warning: +tc078.hs:9:10: Warning: No explicit implementation for either ‘==’ or ‘/=’ In the instance declaration for ‘Eq (Bar a)’ -tc078.hs:8:10: Warning: +tc078.hs:10:10: Warning: No explicit implementation for either ‘compare’ or ‘<=’ In the instance declaration for ‘Ord (Bar a)’ diff --git a/testsuite/tests/typecheck/should_compile/tc079.hs b/testsuite/tests/typecheck/should_compile/tc079.hs index db07ad1325..6784df6024 100644 --- a/testsuite/tests/typecheck/should_compile/tc079.hs +++ b/testsuite/tests/typecheck/should_compile/tc079.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} + -- !!! small class decl with local polymorphism; -- !!! "easy" to check default methods and such... -- !!! (this is the example given in TcClassDcl) diff --git a/testsuite/tests/typecheck/should_compile/tc088.hs b/testsuite/tests/typecheck/should_compile/tc088.hs index b6bf497050..147909e432 100644 --- a/testsuite/tests/typecheck/should_compile/tc088.hs +++ b/testsuite/tests/typecheck/should_compile/tc088.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} + -- Check that "->" is an instance of Eval module ShouldSucceed where diff --git a/testsuite/tests/typecheck/should_compile/tc091.hs b/testsuite/tests/typecheck/should_compile/tc091.hs index 628b571c61..05937f5164 100644 --- a/testsuite/tests/typecheck/should_compile/tc091.hs +++ b/testsuite/tests/typecheck/should_compile/tc091.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} + -- !!! Test polymorphic recursion diff --git a/testsuite/tests/typecheck/should_compile/tc092.hs b/testsuite/tests/typecheck/should_compile/tc092.hs index 58493c6715..4a6c893e7d 100644 --- a/testsuite/tests/typecheck/should_compile/tc092.hs +++ b/testsuite/tests/typecheck/should_compile/tc092.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE RankNTypes #-} module ShouldSucceed where diff --git a/testsuite/tests/typecheck/should_compile/tc109.hs b/testsuite/tests/typecheck/should_compile/tc109.hs index 0d9fdc051c..2a08caea08 100644 --- a/testsuite/tests/typecheck/should_compile/tc109.hs +++ b/testsuite/tests/typecheck/should_compile/tc109.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances #-} -- UndecidableInstances because 'b' appears in the context but not the head diff --git a/testsuite/tests/typecheck/should_compile/tc113.hs b/testsuite/tests/typecheck/should_compile/tc113.hs index 38e79743e4..2ead3c2798 100644 --- a/testsuite/tests/typecheck/should_compile/tc113.hs +++ b/testsuite/tests/typecheck/should_compile/tc113.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} + -- !!! Monomorphism restriction module ShouldCompile where diff --git a/testsuite/tests/typecheck/should_compile/tc115.hs b/testsuite/tests/typecheck/should_compile/tc115.hs index 139b3a5323..0054a24ebc 100644 --- a/testsuite/tests/typecheck/should_compile/tc115.hs +++ b/testsuite/tests/typecheck/should_compile/tc115.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-} -- !!! Functional dependencies diff --git a/testsuite/tests/typecheck/should_compile/tc115.stderr-ghc b/testsuite/tests/typecheck/should_compile/tc115.stderr-ghc index e90ef21e12..4f7981ac56 100644 --- a/testsuite/tests/typecheck/should_compile/tc115.stderr-ghc +++ b/testsuite/tests/typecheck/should_compile/tc115.stderr-ghc @@ -1,5 +1,5 @@ -tc115.hs:12:10: Warning: +tc115.hs:13:10: Warning: No explicit implementation for ‘foo’ In the instance declaration for ‘Foo [m a] (m a)’ diff --git a/testsuite/tests/typecheck/should_compile/tc116.hs b/testsuite/tests/typecheck/should_compile/tc116.hs index eb93410bed..58b9ead731 100644 --- a/testsuite/tests/typecheck/should_compile/tc116.hs +++ b/testsuite/tests/typecheck/should_compile/tc116.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-} -- !!! Functional dependencies diff --git a/testsuite/tests/typecheck/should_compile/tc116.stderr-ghc b/testsuite/tests/typecheck/should_compile/tc116.stderr-ghc index 91fa0a1130..074a795956 100644 --- a/testsuite/tests/typecheck/should_compile/tc116.stderr-ghc +++ b/testsuite/tests/typecheck/should_compile/tc116.stderr-ghc @@ -1,5 +1,5 @@ -tc116.hs:12:10: Warning: +tc116.hs:13:10: Warning: No explicit implementation for ‘foo’ In the instance declaration for ‘Foo [m a] (m a)’ diff --git a/testsuite/tests/typecheck/should_compile/tc125.hs b/testsuite/tests/typecheck/should_compile/tc125.hs index 8d820ba209..75602edac2 100644 --- a/testsuite/tests/typecheck/should_compile/tc125.hs +++ b/testsuite/tests/typecheck/should_compile/tc125.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, UndecidableInstances #-} -- UndecidableInstances now needed because the Coverage Condition fails diff --git a/testsuite/tests/typecheck/should_compile/tc125.stderr-ghc b/testsuite/tests/typecheck/should_compile/tc125.stderr-ghc index 5631c08a1c..d57cda2b19 100644 --- a/testsuite/tests/typecheck/should_compile/tc125.stderr-ghc +++ b/testsuite/tests/typecheck/should_compile/tc125.stderr-ghc @@ -1,25 +1,25 @@ -tc125.hs:16:10: Warning: +tc125.hs:17:10: Warning: No explicit implementation for ‘add’ In the instance declaration for ‘Add Z a a’ -tc125.hs:17:10: Warning: +tc125.hs:18:10: Warning: No explicit implementation for ‘add’ In the instance declaration for ‘Add (S a) b (S c)’ -tc125.hs:21:10: Warning: +tc125.hs:22:10: Warning: No explicit implementation for ‘mul’ In the instance declaration for ‘Mul Z a Z’ -tc125.hs:22:10: Warning: +tc125.hs:23:10: Warning: No explicit implementation for ‘mul’ In the instance declaration for ‘Mul (S a) b d’ -tc125.hs:29:10: Warning: +tc125.hs:30:10: Warning: No explicit implementation for ‘add’ In the instance declaration for ‘Add (Q a b) (Q c d) (Q ad_bc bd)’ diff --git a/testsuite/tests/typecheck/should_compile/tc126.hs b/testsuite/tests/typecheck/should_compile/tc126.hs index 2680ea6290..87d63dd771 100644 --- a/testsuite/tests/typecheck/should_compile/tc126.hs +++ b/testsuite/tests/typecheck/should_compile/tc126.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, UndecidableInstances #-} -- UndecidableInstances now needed because the Coverage Condition fails diff --git a/testsuite/tests/typecheck/should_compile/tc126.stderr-ghc b/testsuite/tests/typecheck/should_compile/tc126.stderr-ghc index 4adc2a29f4..3c766d813e 100644 --- a/testsuite/tests/typecheck/should_compile/tc126.stderr-ghc +++ b/testsuite/tests/typecheck/should_compile/tc126.stderr-ghc @@ -1,10 +1,10 @@ -tc126.hs:15:25: Warning: +tc126.hs:16:25: Warning: No explicit implementation for ‘bug’ In the instance declaration for ‘Bug (Int -> r) Int r’ -tc126.hs:16:10: Warning: +tc126.hs:17:10: Warning: No explicit implementation for ‘bug’ In the instance declaration for ‘Bug f (c a) (c r)’ diff --git a/testsuite/tests/typecheck/should_compile/tc145.hs b/testsuite/tests/typecheck/should_compile/tc145.hs index 04910a3ce5..31e45cd9e9 100644 --- a/testsuite/tests/typecheck/should_compile/tc145.hs +++ b/testsuite/tests/typecheck/should_compile/tc145.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE RankNTypes, ImplicitParams, UnboxedTuples #-} -- Test two slightly exotic things about type signatures diff --git a/testsuite/tests/typecheck/should_compile/tc152.hs b/testsuite/tests/typecheck/should_compile/tc152.hs index 43f107365d..4e618be958 100644 --- a/testsuite/tests/typecheck/should_compile/tc152.hs +++ b/testsuite/tests/typecheck/should_compile/tc152.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances #-} -- -XUndecidableInstances now needed because the Coverage Condition fails diff --git a/testsuite/tests/typecheck/should_compile/tc176.hs b/testsuite/tests/typecheck/should_compile/tc176.hs index 94fdcb2227..d41cbb564e 100644 --- a/testsuite/tests/typecheck/should_compile/tc176.hs +++ b/testsuite/tests/typecheck/should_compile/tc176.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE FlexibleInstances #-} {- With "hugs -98 +o test.hs" gives me: diff --git a/testsuite/tests/typecheck/should_compile/tc178.hs b/testsuite/tests/typecheck/should_compile/tc178.hs index 2a181208d4..d8904c12db 100644 --- a/testsuite/tests/typecheck/should_compile/tc178.hs +++ b/testsuite/tests/typecheck/should_compile/tc178.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE FlexibleInstances #-} -- This one tickled the kind-check in TcType.matchTys, diff --git a/testsuite/tests/typecheck/should_compile/tc180.hs b/testsuite/tests/typecheck/should_compile/tc180.hs index 1a404ad5de..6a6af407ce 100644 --- a/testsuite/tests/typecheck/should_compile/tc180.hs +++ b/testsuite/tests/typecheck/should_compile/tc180.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, UndecidableInstances #-} diff --git a/testsuite/tests/typecheck/should_compile/tc181.hs b/testsuite/tests/typecheck/should_compile/tc181.hs index 6ccf6b90de..b3ae86651c 100644 --- a/testsuite/tests/typecheck/should_compile/tc181.hs +++ b/testsuite/tests/typecheck/should_compile/tc181.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, UndecidableInstances #-} diff --git a/testsuite/tests/typecheck/should_compile/tc183.hs b/testsuite/tests/typecheck/should_compile/tc183.hs index a565ab04ab..c001dc9b5c 100644 --- a/testsuite/tests/typecheck/should_compile/tc183.hs +++ b/testsuite/tests/typecheck/should_compile/tc183.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE ExistentialQuantification, RankNTypes #-} -- An interesting interaction of universals and existentials, prompted by diff --git a/testsuite/tests/typecheck/should_compile/tc187.hs b/testsuite/tests/typecheck/should_compile/tc187.hs index 15946f8a50..17ced8677a 100644 --- a/testsuite/tests/typecheck/should_compile/tc187.hs +++ b/testsuite/tests/typecheck/should_compile/tc187.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE UndecidableInstances, FlexibleInstances, MultiParamTypeClasses, FunctionalDependencies #-} -- UndecidableInstances now needed because the Coverage Condition fails diff --git a/testsuite/tests/typecheck/should_compile/tc192.hs b/testsuite/tests/typecheck/should_compile/tc192.hs index 5af64f344d..f015ede301 100644 --- a/testsuite/tests/typecheck/should_compile/tc192.hs +++ b/testsuite/tests/typecheck/should_compile/tc192.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE Arrows, CPP, TypeOperators #-} -- Test infix type notation and arrow notation diff --git a/testsuite/tests/typecheck/should_compile/tc203.hs b/testsuite/tests/typecheck/should_compile/tc203.hs index a2a361514a..adb9eed236 100644 --- a/testsuite/tests/typecheck/should_compile/tc203.hs +++ b/testsuite/tests/typecheck/should_compile/tc203.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE RankNTypes #-} -- Check that we can have a forall after a forall diff --git a/testsuite/tests/typecheck/should_compile/tc204.hs b/testsuite/tests/typecheck/should_compile/tc204.hs index d95fe86480..c7c5aa3787 100644 --- a/testsuite/tests/typecheck/should_compile/tc204.hs +++ b/testsuite/tests/typecheck/should_compile/tc204.hs @@ -1,19 +1,20 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} +{-# OPTIONS_GHC -dcore-lint #-} {-# LANGUAGE ImplicitParams #-} -{-# OPTIONS -dcore-lint #-}
-
--- The dict-bindings attached to an IPBinds
--- need not be in recursive order. This is
--- a long-standing bug, which lasted up to
--- and including GHC 6.4.2
-
-module Bug795(foo) where
-
-data Arg = E Integer | T Bool deriving (Eq, Show)
-
-foo :: Integer -> [Arg] -> IO String
-foo 1 as = do { let ?err = "my custom error"
- ; let ws = (show (firstE as))
- ; return (show (firstE as)) }
-
-firstE :: (?err :: String) => [Arg] -> Integer
-firstE = error "urk"
+ +-- The dict-bindings attached to an IPBinds +-- need not be in recursive order. This is +-- a long-standing bug, which lasted up to +-- and including GHC 6.4.2 + +module Bug795(foo) where + +data Arg = E Integer | T Bool deriving (Eq, Show) + +foo :: Integer -> [Arg] -> IO String +foo 1 as = do { let ?err = "my custom error" + ; let ws = (show (firstE as)) + ; return (show (firstE as)) } + +firstE :: (?err :: String) => [Arg] -> Integer +firstE = error "urk" diff --git a/testsuite/tests/typecheck/should_compile/tc206.hs b/testsuite/tests/typecheck/should_compile/tc206.hs index 68e751c0de..8764c24277 100644 --- a/testsuite/tests/typecheck/should_compile/tc206.hs +++ b/testsuite/tests/typecheck/should_compile/tc206.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE RankNTypes #-} -- This one showed up a bug in pre-subsumption diff --git a/testsuite/tests/typecheck/should_compile/tc208.hs b/testsuite/tests/typecheck/should_compile/tc208.hs index 0874d0249b..6fad1b21f4 100644 --- a/testsuite/tests/typecheck/should_compile/tc208.hs +++ b/testsuite/tests/typecheck/should_compile/tc208.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE ImplicitParams, RankNTypes #-} -- This program failed to typecheck in an early version of diff --git a/testsuite/tests/typecheck/should_compile/tc229.hs b/testsuite/tests/typecheck/should_compile/tc229.hs index 5c879fd89b..12b4a98060 100644 --- a/testsuite/tests/typecheck/should_compile/tc229.hs +++ b/testsuite/tests/typecheck/should_compile/tc229.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} -- trac #1406: Constraint doesn't reduce in the presence of quantified -- type variables diff --git a/testsuite/tests/typecheck/should_compile/tc230.hs b/testsuite/tests/typecheck/should_compile/tc230.hs index 22cb6e9621..0371ec904f 100644 --- a/testsuite/tests/typecheck/should_compile/tc230.hs +++ b/testsuite/tests/typecheck/should_compile/tc230.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE ImplicitParams, RankNTypes #-} -- Trac #1445 diff --git a/testsuite/tests/typecheck/should_compile/tc235.hs b/testsuite/tests/typecheck/should_compile/tc235.hs index 53822b3418..55a1a5855d 100644 --- a/testsuite/tests/typecheck/should_compile/tc235.hs +++ b/testsuite/tests/typecheck/should_compile/tc235.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE FlexibleInstances, UndecidableInstances, MultiParamTypeClasses, FunctionalDependencies #-} diff --git a/testsuite/tests/typecheck/should_compile/tc237.hs b/testsuite/tests/typecheck/should_compile/tc237.hs index 0eacf2e854..70fcce7bf5 100644 --- a/testsuite/tests/typecheck/should_compile/tc237.hs +++ b/testsuite/tests/typecheck/should_compile/tc237.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE RankNTypes, MultiParamTypeClasses, FunctionalDependencies #-} -- This one caught a bug in the implementation of functional diff --git a/testsuite/tests/typecheck/should_compile/tc239.hs b/testsuite/tests/typecheck/should_compile/tc239.hs index 81c39b790a..f3941d3427 100644 --- a/testsuite/tests/typecheck/should_compile/tc239.hs +++ b/testsuite/tests/typecheck/should_compile/tc239.hs @@ -1,11 +1,12 @@ --- Trac #1072
-
-module ShouldCompile where
-
-import Tc239_Help
-
-f1 :: Show a => WrapIO e a
-f1 = return undefined
-
-f2 :: Show a => WrapIO2 a
-f2 = f1
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} +-- Trac #1072 + +module ShouldCompile where + +import Tc239_Help + +f1 :: Show a => WrapIO e a +f1 = return undefined + +f2 :: Show a => WrapIO2 a +f2 = f1 diff --git a/testsuite/tests/typecheck/should_compile/twins.hs b/testsuite/tests/typecheck/should_compile/twins.hs index 6e46f860db..f87b5a5ea3 100644 --- a/testsuite/tests/typecheck/should_compile/twins.hs +++ b/testsuite/tests/typecheck/should_compile/twins.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE RankNTypes, LiberalTypeSynonyms #-} -- This test checks that deep skolemisation and deep diff --git a/testsuite/tests/typecheck/should_fail/T6161.stderr b/testsuite/tests/typecheck/should_fail/T6161.stderr index 78e16262c8..1293880281 100644 --- a/testsuite/tests/typecheck/should_fail/T6161.stderr +++ b/testsuite/tests/typecheck/should_fail/T6161.stderr @@ -1,5 +1,7 @@ -
-T6161.hs:19:10:
- No instance for (Super (Fam a))
- arising from the superclasses of an instance declaration
- In the instance declaration for ‘Duper (Fam a)’
+ +T6161.hs:19:10: + Could not deduce (Super (Fam a)) + arising from the superclasses of an instance declaration + from the context: Foo a + bound by the instance declaration at T6161.hs:19:10-31 + In the instance declaration for ‘Duper (Fam a)’ diff --git a/testsuite/tests/typecheck/should_fail/tcfail017.stderr b/testsuite/tests/typecheck/should_fail/tcfail017.stderr index ce7613a29e..f09fc92eba 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail017.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail017.stderr @@ -1,5 +1,7 @@ -
-tcfail017.hs:10:10:
- No instance for (C [a])
- arising from the superclasses of an instance declaration
- In the instance declaration for ‘B [a]’
+ +tcfail017.hs:10:10: + Could not deduce (C [a]) + arising from the superclasses of an instance declaration + from the context: B a + bound by the instance declaration at tcfail017.hs:10:10-23 + In the instance declaration for ‘B [a]’ diff --git a/testsuite/tests/typecheck/should_fail/tcfail020.stderr b/testsuite/tests/typecheck/should_fail/tcfail020.stderr index c55d1b5e88..d4163b1eaa 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail020.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail020.stderr @@ -1,5 +1,7 @@ -
-tcfail020.hs:10:10:
- No instance for (A [a])
- arising from the superclasses of an instance declaration
- In the instance declaration for ‘B [a]’
+ +tcfail020.hs:10:10: + Could not deduce (A [a]) + arising from the superclasses of an instance declaration + from the context: A a + bound by the instance declaration at tcfail020.hs:10:10-23 + In the instance declaration for ‘B [a]’ diff --git a/testsuite/tests/typecheck/should_fail/tcfail071.hs b/testsuite/tests/typecheck/should_fail/tcfail071.hs index cbbd25070f..a4c63fac93 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail071.hs +++ b/testsuite/tests/typecheck/should_fail/tcfail071.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} + -- !!! Mis-matched contexts in a mutually recursive group {- # LANGUAGE NoRelaxedPolyRec #-} diff --git a/testsuite/tests/typecheck/should_fail/tcfail138.hs b/testsuite/tests/typecheck/should_fail/tcfail138.hs index cf91a023f4..bc9992dc17 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail138.hs +++ b/testsuite/tests/typecheck/should_fail/tcfail138.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, UndecidableInstances #-} -- UndecidableInstances because (L a b) is no smaller than (C a b) diff --git a/testsuite/tests/typecheck/should_fail/tcfail143.stderr b/testsuite/tests/typecheck/should_fail/tcfail143.stderr index 04e7ec8d14..b36d7a8b37 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail143.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail143.stderr @@ -1,8 +1,8 @@ -
-tcfail143.hs:29:9:
- Couldn't match type ‘Z’ with ‘S Z’
- arising from a functional dependency between:
- constraint ‘MinMax (S Z) Z Z Z’ arising from a use of ‘extend’
- instance ‘MinMax Z b Z b’ at tcfail143.hs:12:10-23
- In the expression: n1 `extend` n0
- In an equation for ‘t2’: t2 = n1 `extend` n0
+ +tcfail143.hs:29:9: + Couldn't match type ‘S Z’ with ‘Z’ + arising from a functional dependency between: + constraint ‘MinMax (S Z) Z Z Z’ arising from a use of ‘extend’ + instance ‘MinMax a Z Z a’ at tcfail143.hs:11:10-23 + In the expression: n1 `extend` n0 + In an equation for ‘t2’: t2 = n1 `extend` n0 |