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

@@ -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

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 }

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 

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

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

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]
    ~~~~~~~~~~~~~~~~~~

docs/users_guide/using.xml

@@ -2179,7 +2179,9 @@ f "2"    = 2
             <para>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 <option>-fno-max-relevant-bindings</option> 
-                   gives an unlimited number. 
+                   gives an unlimited number. Syntactically top-level bindings are also 
+                   usually excluded (since they may be numerous), but 
+                   <option>-fno-max-relevant-bindings</option> includes them too.
             </para>
           </listitem>
         </varlistentry>