diff options
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 |