From 9039108b2d9ad746d47f3917cdfb7a44a4a41ccf Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones Date: Tue, 10 Sep 2013 17:55:59 +0100 Subject: [PATCH] Improve error reporting for "relevant bindings" again (Trac #8233) This patch makes a number of related improvements: * Displays relevant bindings in innermost-first order. The inner ones are closer to the error. * Does not display syntactically top-level bindings, unless you say -fno-max-relevant-bindings. This is what Trac #8233 was mainly about * Makes the TopLevelFlag in a TcIdBinder really mean "syntactically top level". It was a bit vague before. There was some associated simplification, because we no longer need to pas a TopLevelFlag to tcMonoBinds and friends. --- compiler/typecheck/TcBinds.lhs | 57 ++++++++++++++++--------------- compiler/typecheck/TcClassDcl.lhs | 2 +- compiler/typecheck/TcEnv.lhs | 6 ++-- compiler/typecheck/TcErrors.lhs | 19 ++++++++--- compiler/typecheck/TcInstDcls.lhs | 2 +- compiler/typecheck/TcRnTypes.lhs | 8 ++++- docs/users_guide/using.xml | 4 ++- 7 files changed, 59 insertions(+), 39 deletions(-) diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index 2a33955148..532e6efd10 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -321,7 +321,7 @@ tc_group top_lvl sig_fn prag_fn (NonRecursive, binds) thing_inside = do { (binds1, ids, closed) <- tcPolyBinds top_lvl sig_fn prag_fn NonRecursive NonRecursive (bagToList binds) - ; thing <- tcExtendLetEnv closed ids thing_inside + ; thing <- tcExtendLetEnv top_lvl closed ids thing_inside ; return ( [(NonRecursive, binds1)], thing) } tc_group top_lvl sig_fn prag_fn (Recursive, binds) thing_inside @@ -341,7 +341,7 @@ tc_group top_lvl sig_fn prag_fn (Recursive, binds) thing_inside go :: [SCC (LHsBind Name)] -> TcM (LHsBinds TcId, [TcId], thing) go (scc:sccs) = do { (binds1, ids1, closed) <- tc_scc scc - ; (binds2, ids2, thing) <- tcExtendLetEnv closed ids1 $ + ; (binds2, ids2, thing) <- tcExtendLetEnv top_lvl closed ids1 $ go sccs ; return (binds1 `unionBags` binds2, ids1 ++ ids2, thing) } go [] = do { thing <- thing_inside; return (emptyBag, [], thing) } @@ -409,9 +409,9 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc bind_list binder_names bind_list sig_fn ; traceTc "Generalisation plan" (ppr plan) ; result@(tc_binds, poly_ids, _) <- case plan of - NoGen -> tcPolyNoGen top_lvl rec_tc prag_fn sig_fn bind_list - InferGen mn cl -> tcPolyInfer top_lvl rec_tc prag_fn sig_fn mn cl bind_list - CheckGen sig -> tcPolyCheck top_lvl rec_tc prag_fn sig bind_list + NoGen -> tcPolyNoGen rec_tc prag_fn sig_fn bind_list + InferGen mn cl -> tcPolyInfer rec_tc prag_fn sig_fn mn cl bind_list + CheckGen sig -> tcPolyCheck rec_tc prag_fn sig bind_list -- Check whether strict bindings are ok -- These must be non-recursive etc, and are not generalised @@ -431,15 +431,14 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc bind_list ------------------ tcPolyNoGen -- No generalisation whatsoever - :: TopLevelFlag - -> RecFlag -- Whether it's recursive after breaking + :: RecFlag -- Whether it's recursive after breaking -- dependencies based on type signatures -> PragFun -> TcSigFun -> [LHsBind Name] -> TcM (LHsBinds TcId, [TcId], TopLevelFlag) -tcPolyNoGen top_lvl rec_tc prag_fn tc_sig_fn bind_list - = do { (binds', mono_infos) <- tcMonoBinds top_lvl rec_tc tc_sig_fn +tcPolyNoGen rec_tc prag_fn tc_sig_fn bind_list + = do { (binds', mono_infos) <- tcMonoBinds rec_tc tc_sig_fn (LetGblBndr prag_fn) bind_list ; mono_ids' <- mapM tc_mono_info mono_infos @@ -457,8 +456,7 @@ tcPolyNoGen top_lvl rec_tc prag_fn tc_sig_fn bind_list -- So we can safely ignore _specs ------------------ -tcPolyCheck :: TopLevelFlag - -> RecFlag -- Whether it's recursive after breaking +tcPolyCheck :: RecFlag -- Whether it's recursive after breaking -- dependencies based on type signatures -> PragFun -> TcSigInfo -> [LHsBind Name] @@ -466,7 +464,7 @@ tcPolyCheck :: TopLevelFlag -- There is just one binding, -- it binds a single variable, -- it has a signature, -tcPolyCheck top_lvl rec_tc prag_fn +tcPolyCheck rec_tc prag_fn sig@(TcSigInfo { sig_id = poly_id, sig_tvs = tvs_w_scoped , sig_theta = theta, sig_tau = tau, sig_loc = loc }) bind_list @@ -478,7 +476,7 @@ tcPolyCheck top_lvl rec_tc prag_fn <- setSrcSpan loc $ checkConstraints skol_info tvs ev_vars $ tcExtendTyVarEnv2 [(n,tv) | (Just n, tv) <- tvs_w_scoped] $ - tcMonoBinds top_lvl rec_tc (\_ -> Just sig) LetLclBndr bind_list + tcMonoBinds rec_tc (\_ -> Just sig) LetLclBndr bind_list ; spec_prags <- tcSpecPrags poly_id prag_sigs ; poly_id <- addInlinePrags poly_id prag_sigs @@ -498,18 +496,17 @@ tcPolyCheck top_lvl rec_tc prag_fn ------------------ tcPolyInfer - :: TopLevelFlag - -> RecFlag -- Whether it's recursive after breaking + :: RecFlag -- Whether it's recursive after breaking -- dependencies based on type signatures -> PragFun -> TcSigFun -> Bool -- True <=> apply the monomorphism restriction -> Bool -- True <=> free vars have closed types -> [LHsBind Name] -> TcM (LHsBinds TcId, [TcId], TopLevelFlag) -tcPolyInfer top_lvl rec_tc prag_fn tc_sig_fn mono closed bind_list +tcPolyInfer rec_tc prag_fn tc_sig_fn mono closed bind_list = do { ((binds', mono_infos), wanted) <- captureConstraints $ - tcMonoBinds top_lvl rec_tc tc_sig_fn LetLclBndr bind_list + tcMonoBinds rec_tc tc_sig_fn LetLclBndr bind_list ; let name_taus = [(name, idType mono_id) | (name, _, mono_id) <- mono_infos] ; traceTc "simplifyInfer call" (ppr name_taus $$ ppr wanted) @@ -937,15 +934,14 @@ should not typecheck because will not typecheck. \begin{code} -tcMonoBinds :: TopLevelFlag - -> RecFlag -- Whether the binding is recursive for typechecking purposes +tcMonoBinds :: RecFlag -- Whether the binding is recursive for typechecking purposes -- i.e. the binders are mentioned in their RHSs, and -- we are not rescued by a type signature -> TcSigFun -> LetBndrSpec -> [LHsBind Name] -> TcM (LHsBinds TcId, [MonoBindInfo]) -tcMonoBinds top_lvl is_rec sig_fn no_gen +tcMonoBinds is_rec sig_fn no_gen [ L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf, fun_matches = matches, bind_fvs = fvs })] -- Single function binding, @@ -959,7 +955,10 @@ tcMonoBinds top_lvl is_rec sig_fn no_gen setSrcSpan b_loc $ do { rhs_ty <- newFlexiTyVarTy openTypeKind ; mono_id <- newNoSigLetBndr no_gen name rhs_ty - ; (co_fn, matches') <- tcExtendIdBndrs [TcIdBndr mono_id top_lvl] $ + ; (co_fn, matches') <- tcExtendIdBndrs [TcIdBndr mono_id NotTopLevel] $ + -- We extend the error context even for a non-recursive + -- function so that in type error messages we show the + -- type of the thing whose rhs we are type checking tcMatchesFun name inf matches rhs_ty ; return (unitBag (L b_loc (FunBind { fun_id = L nm_loc mono_id, fun_infix = inf, @@ -967,7 +966,7 @@ tcMonoBinds top_lvl is_rec sig_fn no_gen fun_co_fn = co_fn, fun_tick = Nothing })), [(name, Nothing, mono_id)]) } -tcMonoBinds top_lvl _ sig_fn no_gen binds +tcMonoBinds _ sig_fn no_gen binds = do { tc_binds <- mapM (wrapLocM (tcLhs sig_fn no_gen)) binds -- Bring the monomorphic Ids, into scope for the RHSs @@ -979,7 +978,7 @@ tcMonoBinds top_lvl _ sig_fn no_gen binds ; traceTc "tcMonoBinds" $ vcat [ ppr n <+> ppr id <+> ppr (idType id) | (n,id) <- rhs_id_env] ; binds' <- tcExtendIdEnv2 rhs_id_env $ - mapM (wrapLocM (tcRhs top_lvl)) tc_binds + mapM (wrapLocM tcRhs) tc_binds ; return (listToBag binds', mono_info) } ------------------------ @@ -1040,13 +1039,14 @@ tcLhs _ _ other_bind = pprPanic "tcLhs" (ppr other_bind) -- AbsBind, VarBind impossible ------------------- -tcRhs :: TopLevelFlag -> TcMonoBind -> TcM (HsBind TcId) +tcRhs :: TcMonoBind -> TcM (HsBind TcId) -- When we are doing pattern bindings, or multiple function bindings at a time -- we *don't* bring any scoped type variables into scope -- Wny not? They are not completely rigid. -- That's why we have the special case for a single FunBind in tcMonoBinds -tcRhs top_lvl (TcFunBind (_,_,mono_id) loc inf matches) - = tcExtendIdBndrs [TcIdBndr mono_id top_lvl] $ +tcRhs (TcFunBind (_,_,mono_id) loc inf matches) + = tcExtendIdBndrs [TcIdBndr mono_id NotTopLevel] $ + -- NotTopLevel: it's a monomorphic binding do { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id)) ; (co_fn, matches') <- tcMatchesFun (idName mono_id) inf matches (idType mono_id) @@ -1055,8 +1055,9 @@ tcRhs top_lvl (TcFunBind (_,_,mono_id) loc inf matches) , fun_co_fn = co_fn , bind_fvs = placeHolderNames, fun_tick = Nothing }) } -tcRhs top_lvl (TcPatBind infos pat' grhss pat_ty) - = tcExtendIdBndrs [ TcIdBndr mono_id top_lvl | (_,_,mono_id) <- infos ] $ +tcRhs (TcPatBind infos pat' grhss pat_ty) + = tcExtendIdBndrs [ TcIdBndr mono_id NotTopLevel | (_,_,mono_id) <- infos ] $ + -- NotTopLevel: it's a monomorphic binding do { traceTc "tcRhs: pat bind" (ppr pat' $$ ppr pat_ty) ; grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $ tcGRHSsPat grhss pat_ty diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs index 0579fcb865..06ddc4ef1d 100644 --- a/compiler/typecheck/TcClassDcl.lhs +++ b/compiler/typecheck/TcClassDcl.lhs @@ -247,7 +247,7 @@ tcInstanceMethodBody skol_info tyvars dfun_ev_vars -- NB: the binding is always a FunBind ; (ev_binds, (tc_bind, _, _)) <- checkConstraints skol_info tyvars dfun_ev_vars $ - tcPolyCheck NotTopLevel NonRecursive no_prag_fn local_meth_sig [lm_bind] + tcPolyCheck NonRecursive no_prag_fn local_meth_sig [lm_bind] ; let export = ABE { abe_wrap = idHsWrapper, abe_poly = meth_id , abe_mono = local_meth_id, abe_prags = specs } diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index dde9797845..26ade08044 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -377,14 +377,14 @@ getScopedTyVarBinds \begin{code} -tcExtendLetEnv :: TopLevelFlag -> [TcId] -> TcM a -> TcM a -tcExtendLetEnv closed ids thing_inside +tcExtendLetEnv :: TopLevelFlag -> TopLevelFlag -> [TcId] -> TcM a -> TcM a +tcExtendLetEnv top_lvl closed ids thing_inside = do { stage <- getStage ; tc_extend_local_env [ (idName id, ATcId { tct_id = id , tct_closed = closed , tct_level = thLevel stage }) | id <- ids] $ - tcExtendIdBndrs [TcIdBndr id closed | id <- ids] thing_inside } + tcExtendIdBndrs [TcIdBndr id top_lvl | id <- ids] thing_inside } tcExtendIdEnv :: [TcId] -> TcM a -> TcM a tcExtendIdEnv ids thing_inside diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs index 307e922633..3851c7ef02 100644 --- a/compiler/typecheck/TcErrors.lhs +++ b/compiler/typecheck/TcErrors.lhs @@ -1171,6 +1171,9 @@ getSkolemInfo (implic:implics) tv -- types mention any of the offending type variables. It has to be -- careful to zonk the Id's type first, so it has to be in the monad. -- We must be careful to pass it a zonked type variable, too. +-- +-- We always remove closed top-level bindings, though, +-- since they are never relevant (cf Trac #8233) relevantBindings :: Bool -- True <=> filter by tyvar; False <=> no filtering -- See Trac #8191 @@ -1181,8 +1184,9 @@ relevantBindings want_filtering ctxt ct ; (tidy_env', docs, discards) <- go (cec_tidy ctxt) (maxRelevantBinds dflags) emptyVarSet [] False - (reverse (tcl_bndrs lcl_env)) - -- The 'reverse' makes us work from outside in + (tcl_bndrs lcl_env) + -- tcl_bndrs has the innermost bindings first, + -- which are probably the most relevant ones ; traceTc "relevantBindings" (ppr [id | TcIdBndr id _ <- tcl_bndrs lcl_env]) ; let doc = hang (ptext (sLit "Relevant bindings include")) @@ -1206,13 +1210,14 @@ relevantBindings want_filtering ctxt ct dec_max :: Maybe Int -> Maybe Int dec_max = fmap (\n -> n - 1) - go :: TidyEnv -> Maybe Int -> TcTyVarSet -> [SDoc] -> Bool + go :: TidyEnv -> 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 [] = return (tidy_env, reverse docs, discards) - go tidy_env n_left tvs_seen docs discards (TcIdBndr id _ : tc_bndrs) + go tidy_env n_left tvs_seen docs discards (TcIdBndr id top_lvl : tc_bndrs) = do { (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env (idType id) ; let id_tvs = tyVarsOfType tidy_ty doc = sep [ pprPrefixOcc id <+> dcolon <+> ppr tidy_ty @@ -1222,6 +1227,12 @@ relevantBindings want_filtering ctxt ct ; if (want_filtering && 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 + + 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 else if run_out n_left && id_tvs `subVarSet` tvs_seen diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index dee9055cf1..2c6bd8c1a7 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -776,7 +776,7 @@ tcInstDecls2 tycl_decls inst_decls ; let dm_ids = collectHsBindsBinders dm_binds -- Add the default method Ids (again) -- See Note [Default methods and instances] - ; inst_binds_s <- tcExtendLetEnv TopLevel dm_ids $ + ; inst_binds_s <- tcExtendLetEnv TopLevel TopLevel dm_ids $ mapM tcInstDecl2 inst_decls -- Done diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index 94787eb39b..4305f2b9b4 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -460,7 +460,13 @@ data TcLclEnv -- Changes as we move inside an expression } type TcTypeEnv = NameEnv TcTyThing -data TcIdBinder = TcIdBndr TcId TopLevelFlag + +data TcIdBinder + = TcIdBndr + TcId + TopLevelFlag -- Tells whether the bindind is syntactically top-level + -- (The monomorphic Ids for a recursive group count + -- as not-top-level for this purpose.) {- Note [Given Insts] ~~~~~~~~~~~~~~~~~~ diff --git a/docs/users_guide/using.xml b/docs/users_guide/using.xml index 1a03f2c5c0..f03335862b 100644 --- a/docs/users_guide/using.xml +++ b/docs/users_guide/using.xml @@ -2179,7 +2179,9 @@ f "2" = 2 The type checker sometimes displays a fragment of the type environment in error messages, but only up to some maximum number, set by this flag. The default is 6. Turning it off with - gives an unlimited number. + gives an unlimited number. Syntactically top-level bindings are also + usually excluded (since they may be numerous), but + includes them too. -- GitLab