diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/GHC/Hs/Utils.hs | 330 | ||||
| -rw-r--r-- | compiler/GHC/HsToCore/Arrows.hs | 109 | ||||
| -rw-r--r-- | compiler/GHC/HsToCore/Coverage.hs | 18 | ||||
| -rw-r--r-- | compiler/GHC/HsToCore/Docs.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/HsToCore/Match.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/HsToCore/Quote.hs | 14 | ||||
| -rw-r--r-- | compiler/GHC/HsToCore/Utils.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/Rename/Bind.hs | 8 | ||||
| -rw-r--r-- | compiler/GHC/Rename/Expr.hs | 18 | ||||
| -rw-r--r-- | compiler/GHC/Rename/Module.hs | 5 | ||||
| -rw-r--r-- | compiler/GHC/Rename/Names.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/Rename/Pat.hs | 4 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Gen/Bind.hs | 14 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Gen/Match.hs | 4 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Gen/Splice.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Module.hs | 8 | ||||
| -rw-r--r-- | compiler/GHC/Tc/TyCl/Instance.hs | 4 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Utils/Zonk.hs | 4 |
18 files changed, 284 insertions, 266 deletions
diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs index e414269413..e538549265 100644 --- a/compiler/GHC/Hs/Utils.hs +++ b/compiler/GHC/Hs/Utils.hs @@ -28,6 +28,8 @@ just attach noSrcSpan to everything. {-# LANGUAGE TypeApplications #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE GADTs #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -90,10 +92,11 @@ module GHC.Hs.Utils( collectLocalBinders, collectHsValBinders, collectHsBindListBinders, collectHsIdBinders, collectHsBindsBinders, collectHsBindBinders, collectMethodBinders, + collectPatBinders, collectPatsBinders, collectLStmtsBinders, collectStmtsBinders, collectLStmtBinders, collectStmtBinders, - CollectPass(..), + CollectPass(..), CollectFlag(..), hsLTyClDeclBinders, hsTyClForeignBinders, hsPatSynSelectors, getPatSynBinds, @@ -907,7 +910,7 @@ isUnliftedHsBind bind -- binding might not be: e.g. forall a. Num a => (# a, a #) | otherwise - = any is_unlifted_id (collectHsBindBinders bind) + = any is_unlifted_id (collectHsBindBinders CollNoDictBinders bind) where is_unlifted_id id = isUnliftedType (idType id) @@ -925,80 +928,91 @@ isBangedHsBind _ = False collectLocalBinders :: CollectPass (GhcPass idL) - => HsLocalBindsLR (GhcPass idL) (GhcPass idR) + => CollectFlag (GhcPass idL) + -> HsLocalBindsLR (GhcPass idL) (GhcPass idR) -> [IdP (GhcPass idL)] -collectLocalBinders (HsValBinds _ binds) = collectHsIdBinders binds - -- No pattern synonyms here -collectLocalBinders (HsIPBinds {}) = [] -collectLocalBinders (EmptyLocalBinds _) = [] +collectLocalBinders flag = \case + HsValBinds _ binds -> collectHsIdBinders flag binds + -- No pattern synonyms here + HsIPBinds {} -> [] + EmptyLocalBinds _ -> [] collectHsIdBinders :: CollectPass (GhcPass idL) - => HsValBindsLR (GhcPass idL) (GhcPass idR) + => CollectFlag (GhcPass idL) + -> HsValBindsLR (GhcPass idL) (GhcPass idR) -> [IdP (GhcPass idL)] -- ^ Collect 'Id' binders only, or 'Id's + pattern synonyms, respectively -collectHsIdBinders = collect_hs_val_binders True +collectHsIdBinders flag = collect_hs_val_binders True flag collectHsValBinders :: CollectPass (GhcPass idL) - => HsValBindsLR (GhcPass idL) (GhcPass idR) + => CollectFlag (GhcPass idL) + -> HsValBindsLR (GhcPass idL) (GhcPass idR) -> [IdP (GhcPass idL)] -collectHsValBinders = collect_hs_val_binders False +collectHsValBinders flag = collect_hs_val_binders False flag collectHsBindBinders :: CollectPass p - => HsBindLR p idR + => CollectFlag p + -> HsBindLR p idR -> [IdP p] -- ^ Collect both 'Id's and pattern-synonym binders -collectHsBindBinders b = collect_bind False b [] +collectHsBindBinders flag b = collect_bind False flag b [] collectHsBindsBinders :: CollectPass p - => LHsBindsLR p idR + => CollectFlag p + -> LHsBindsLR p idR -> [IdP p] -collectHsBindsBinders binds = collect_binds False binds [] +collectHsBindsBinders flag binds = collect_binds False flag binds [] collectHsBindListBinders :: forall p idR. CollectPass p - => [LHsBindLR p idR] + => CollectFlag p + -> [LHsBindLR p idR] -> [IdP p] -- ^ Same as 'collectHsBindsBinders', but works over a list of bindings -collectHsBindListBinders = foldr (collect_bind False . unXRec @p) [] +collectHsBindListBinders flag = foldr (collect_bind False flag . unXRec @p) [] collect_hs_val_binders :: CollectPass (GhcPass idL) => Bool + -> CollectFlag (GhcPass idL) -> HsValBindsLR (GhcPass idL) (GhcPass idR) -> [IdP (GhcPass idL)] -collect_hs_val_binders ps (ValBinds _ binds _) = collect_binds ps binds [] -collect_hs_val_binders ps (XValBindsLR (NValBinds binds _)) - = collect_out_binds ps binds +collect_hs_val_binders ps flag = \case + ValBinds _ binds _ -> collect_binds ps flag binds [] + XValBindsLR (NValBinds binds _) -> collect_out_binds ps flag binds collect_out_binds :: forall p. CollectPass p => Bool + -> CollectFlag p -> [(RecFlag, LHsBinds p)] -> [IdP p] -collect_out_binds ps = foldr (collect_binds ps . snd) [] +collect_out_binds ps flag = foldr (collect_binds ps flag . snd) [] collect_binds :: forall p idR. CollectPass p => Bool + -> CollectFlag p -> LHsBindsLR p idR -> [IdP p] -> [IdP p] -- ^ Collect 'Id's, or 'Id's + pattern synonyms, depending on boolean flag -collect_binds ps binds acc = foldr (collect_bind ps . unXRec @p) acc binds +collect_binds ps flag binds acc = foldr (collect_bind ps flag . unXRec @p) acc binds collect_bind :: forall p idR. CollectPass p => Bool + -> CollectFlag p -> HsBindLR p idR -> [IdP p] -> [IdP p] -collect_bind _ (PatBind { pat_lhs = p }) acc = collect_lpat p acc -collect_bind _ (FunBind { fun_id = f }) acc = unXRec @p f : acc -collect_bind _ (VarBind { var_id = f }) acc = f : acc -collect_bind _ (AbsBinds { abs_exports = dbinds }) acc = map abe_poly dbinds ++ acc +collect_bind _ flag (PatBind { pat_lhs = p }) acc = collect_lpat flag p acc +collect_bind _ _ (FunBind { fun_id = f }) acc = unXRec @p f : acc +collect_bind _ _ (VarBind { var_id = f }) acc = f : acc +collect_bind _ _ (AbsBinds { abs_exports = dbinds }) acc = map abe_poly dbinds ++ acc -- I don't think we want the binders from the abe_binds -- binding (hence see AbsBinds) is in zonking in GHC.Tc.Utils.Zonk -collect_bind omitPatSyn (PatSynBind _ (PSB { psb_id = ps })) acc +collect_bind omitPatSyn _ (PatSynBind _ (PSB { psb_id = ps })) acc | omitPatSyn = acc | otherwise = unXRec @p ps : acc -collect_bind _ (PatSynBind _ (XPatSynBind _)) acc = acc -collect_bind _ (XHsBindsLR _) acc = acc +collect_bind _ _ (PatSynBind _ (XPatSynBind _)) acc = acc +collect_bind _ _ (XHsBindsLR _) acc = acc collectMethodBinders :: forall idL idR. UnXRec idL => LHsBindsLR idL idR -> [LIdP idL] -- ^ Used exclusively for the bindings of an instance decl which are all @@ -1010,77 +1024,127 @@ collectMethodBinders binds = foldr (get . unXRec @idL) [] binds -- Someone else complains about non-FunBinds ----------------- Statements -------------------------- -collectLStmtsBinders :: (CollectPass (GhcPass idL)) - => [LStmtLR (GhcPass idL) (GhcPass idR) body] - -> [IdP (GhcPass idL)] -collectLStmtsBinders = concatMap collectLStmtBinders - -collectStmtsBinders :: (CollectPass (GhcPass idL)) - => [StmtLR (GhcPass idL) (GhcPass idR) body] - -> [IdP (GhcPass idL)] -collectStmtsBinders = concatMap collectStmtBinders - -collectLStmtBinders :: (CollectPass (GhcPass idL)) - => LStmtLR (GhcPass idL) (GhcPass idR) body - -> [IdP (GhcPass idL)] -collectLStmtBinders = collectStmtBinders . unLoc - -collectStmtBinders :: (CollectPass (GhcPass idL)) - => StmtLR (GhcPass idL) (GhcPass idR) body - -> [IdP (GhcPass idL)] +-- +collectLStmtsBinders + :: CollectPass (GhcPass idL) + => CollectFlag (GhcPass idL) + -> [LStmtLR (GhcPass idL) (GhcPass idR) body] + -> [IdP (GhcPass idL)] +collectLStmtsBinders flag = concatMap (collectLStmtBinders flag) + +collectStmtsBinders + :: (CollectPass (GhcPass idL)) + => CollectFlag (GhcPass idL) + -> [StmtLR (GhcPass idL) (GhcPass idR) body] + -> [IdP (GhcPass idL)] +collectStmtsBinders flag = concatMap (collectStmtBinders flag) + +collectLStmtBinders + :: (CollectPass (GhcPass idL)) + => CollectFlag (GhcPass idL) + -> LStmtLR (GhcPass idL) (GhcPass idR) body + -> [IdP (GhcPass idL)] +collectLStmtBinders flag = collectStmtBinders flag . unLoc + +collectStmtBinders + :: CollectPass (GhcPass idL) + => CollectFlag (GhcPass idL) + -> StmtLR (GhcPass idL) (GhcPass idR) body + -> [IdP (GhcPass idL)] -- Id Binders for a Stmt... [but what about pattern-sig type vars]? -collectStmtBinders (BindStmt _ pat _) = collectPatBinders pat -collectStmtBinders (LetStmt _ binds) = collectLocalBinders (unLoc binds) -collectStmtBinders (BodyStmt {}) = [] -collectStmtBinders (LastStmt {}) = [] -collectStmtBinders (ParStmt _ xs _ _) = collectLStmtsBinders - $ [s | ParStmtBlock _ ss _ _ <- xs, s <- ss] -collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts -collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss -collectStmtBinders (ApplicativeStmt _ args _) = concatMap collectArgBinders args - where - collectArgBinders (_, ApplicativeArgOne { app_arg_pattern = pat }) = collectPatBinders pat - collectArgBinders (_, ApplicativeArgMany { bv_pattern = pat }) = collectPatBinders pat - collectArgBinders (_, XApplicativeArg {}) = [] +collectStmtBinders flag = \case + BindStmt _ pat _ -> collectPatBinders flag pat + LetStmt _ binds -> collectLocalBinders flag (unLoc binds) + BodyStmt {} -> [] + LastStmt {} -> [] + ParStmt _ xs _ _ -> collectLStmtsBinders flag [s | ParStmtBlock _ ss _ _ <- xs, s <- ss] + TransStmt { trS_stmts = stmts } -> collectLStmtsBinders flag stmts + RecStmt { recS_stmts = ss } -> collectLStmtsBinders flag ss + ApplicativeStmt _ args _ -> concatMap collectArgBinders args + where + collectArgBinders = \case + (_, ApplicativeArgOne { app_arg_pattern = pat }) -> collectPatBinders flag pat + (_, ApplicativeArgMany { bv_pattern = pat }) -> collectPatBinders flag pat ----------------- Patterns -------------------------- -collectPatBinders :: CollectPass p => LPat p -> [IdP p] -collectPatBinders pat = collect_lpat pat [] -collectPatsBinders :: CollectPass p => [LPat p] -> [IdP p] -collectPatsBinders pats = foldr collect_lpat [] pats +collectPatBinders + :: CollectPass p + => CollectFlag p + -> LPat p + -> [IdP p] +collectPatBinders flag pat = collect_lpat flag pat [] + +collectPatsBinders + :: CollectPass p + => CollectFlag p + -> [LPat p] + -> [IdP p] +collectPatsBinders flag pats = foldr (collect_lpat flag) [] pats + ------------- -collect_lpat :: forall pass. (CollectPass pass) - => LPat pass -> [IdP pass] -> [IdP pass] -collect_lpat p bndrs = collect_pat (unXRec @pass p) bndrs + +-- | Indicate if evidence binders have to be collected. +-- +-- This type is used as a boolean (should we collect evidence binders or not?) +-- but also to pass an evidence that the AST has been typechecked when we do +-- want to collect evidence binders, otherwise these binders are not available. +-- +-- See Note [Dictionary binders in ConPatOut] +data CollectFlag p where + -- | Don't collect evidence binders + CollNoDictBinders :: CollectFlag p + -- | Collect evidence binders + CollWithDictBinders :: CollectFlag GhcTc + +collect_lpat :: forall p. (CollectPass p) + => CollectFlag p + -> LPat p + -> [IdP p] + -> [IdP p] +collect_lpat flag pat bndrs = collect_pat flag (unXRec @p pat) bndrs collect_pat :: forall p. CollectPass p - => Pat p + => CollectFlag p + -> Pat p -> [IdP p] -> [IdP p] -collect_pat pat bndrs = case pat of - (VarPat _ var) -> unXRec @p var : bndrs - (WildPat _) -> bndrs - (LazyPat _ pat) -> collect_lpat pat bndrs - (BangPat _ pat) -> collect_lpat pat bndrs - (AsPat _ a pat) -> unXRec @p a : collect_lpat pat bndrs - (ViewPat _ _ pat) -> collect_lpat pat bndrs - (ParPat _ pat) -> collect_lpat pat bndrs - (ListPat _ pats) -> foldr collect_lpat bndrs pats - (TuplePat _ pats _) -> foldr collect_lpat bndrs pats - (SumPat _ pat _ _) -> collect_lpat pat bndrs - (ConPat {pat_args=ps}) -> foldr collect_lpat bndrs (hsConPatArgs ps) +collect_pat flag pat bndrs = case pat of + VarPat _ var -> unXRec @p var : bndrs + WildPat _ -> bndrs + LazyPat _ pat -> collect_lpat flag pat bndrs + BangPat _ pat -> collect_lpat flag pat bndrs + AsPat _ a pat -> unXRec @p a : collect_lpat flag pat bndrs + ViewPat _ _ pat -> collect_lpat flag pat bndrs + ParPat _ pat -> collect_lpat flag pat bndrs + ListPat _ pats -> foldr (collect_lpat flag) bndrs pats + TuplePat _ pats _ -> foldr (collect_lpat flag) bndrs pats + SumPat _ pat _ _ -> collect_lpat flag pat bndrs + LitPat _ _ -> bndrs + NPat {} -> bndrs + NPlusKPat _ n _ _ _ _ -> unXRec @p n : bndrs + SigPat _ pat _ -> collect_lpat flag pat bndrs + XPat ext -> collectXXPat (Proxy @p) flag ext bndrs + SplicePat _ (HsSpliced _ _ (HsSplicedPat pat)) + -> collect_pat flag pat bndrs + SplicePat _ _ -> bndrs -- See Note [Dictionary binders in ConPatOut] - (LitPat _ _) -> bndrs - (NPat {}) -> bndrs - (NPlusKPat _ n _ _ _ _) -> unXRec @p n : bndrs - (SigPat _ pat _) -> collect_lpat pat bndrs - (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat))) - -> collect_pat pat bndrs - (SplicePat _ _) -> bndrs - (XPat ext) -> collectXXPat (Proxy @p) ext bndrs + ConPat {pat_args=ps} -> case flag of + CollNoDictBinders -> foldr (collect_lpat flag) bndrs (hsConPatArgs ps) + CollWithDictBinders -> foldr (collect_lpat flag) bndrs (hsConPatArgs ps) + ++ collectEvBinders (cpt_binds (pat_con_ext pat)) + +collectEvBinders :: TcEvBinds -> [Id] +collectEvBinders (EvBinds bs) = foldr add_ev_bndr [] bs +collectEvBinders (TcEvBinds {}) = panic "ToDo: collectEvBinders" + +add_ev_bndr :: EvBind -> [Id] -> [Id] +add_ev_bndr (EvBind { eb_lhs = b }) bs | isId b = b:bs + | otherwise = bs + -- A worry: what about coercion variable binders?? + -- | This class specifies how to collect variable identifiers from extension patterns in the given pass. -- Consumers of the GHC API that define their own passes should feel free to implement instances in order @@ -1089,47 +1153,89 @@ collect_pat pat bndrs = case pat of -- In particular, Haddock already makes use of this, with an instance for its 'DocNameI' pass so that -- it can reuse the code in GHC for collecting binders. class UnXRec p => CollectPass p where - collectXXPat :: Proxy p -> XXPat p -> [IdP p] -> [IdP p] + collectXXPat :: Proxy p -> CollectFlag p -> XXPat p -> [IdP p] -> [IdP p] instance IsPass p => CollectPass (GhcPass p) where - collectXXPat _ ext = + collectXXPat _ flag ext = case ghcPass @p of - GhcTc -> let CoPat _ pat _ = ext in collect_pat pat + GhcTc -> let CoPat _ pat _ = ext in collect_pat flag pat GhcRn -> noExtCon ext GhcPs -> noExtCon ext {- -Note [Dictionary binders in ConPatOut] See also same Note in GHC.HsToCore.Arrows +Note [Dictionary binders in ConPatOut] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Do *not* gather (a) dictionary and (b) dictionary bindings as binders -of a ConPatOut pattern. For most calls it doesn't matter, because -it's pre-typechecker and there are no ConPatOuts. But it does matter -more in the desugarer; for example, GHC.HsToCore.Utils.mkSelectorBinds uses -collectPatBinders. In a lazy pattern, for example f ~(C x y) = ..., -we want to generate bindings for x,y but not for dictionaries bound by -C. (The type checker ensures they would not be used.) -Desugaring of arrow case expressions needs these bindings (see GHC.HsToCore.Arrows -and arrowcase1), but SPJ (Jan 2007) says it's safer for it to use its -own pat-binder-collector: +Should we collect dictionary binders in ConPatOut? It depends! Use CollectFlag +to choose. + +1. Pre-typechecker there are no ConPatOuts. Use CollNoDictBinders flag. + +2. In the desugarer, most of the time we don't want to collect evidence binders, + so we also use CollNoDictBinders flag. + + Example of why it matters: + + In a lazy pattern, for example f ~(C x y) = ..., we want to generate bindings + for x,y but not for dictionaries bound by C. + (The type checker ensures they would not be used.) + + Here's the problem. Consider + + data T a where + C :: Num a => a -> Int -> T a + + f ~(C (n+1) m) = (n,m) + + Here, the pattern (C (n+1)) binds a hidden dictionary (d::Num a), + and *also* uses that dictionary to match the (n+1) pattern. Yet, the + variables bound by the lazy pattern are n,m, *not* the dictionary d. + So in mkSelectorBinds in GHC.HsToCore.Utils, we want just m,n as the + variables bound. + + So in this case, we do *not* gather (a) dictionary and (b) dictionary + bindings as binders of a ConPatOut pattern. + + +3. On the other hand, desugaring of arrows needs evidence bindings and uses + CollWithDictBinders flag. + + Consider + + h :: (ArrowChoice a, Arrow a) => Int -> a (Int,Int) Int + h x = proc (y,z) -> case compare x y of + GT -> returnA -< z+x + + The type checker turns the case into + + case compare x y of + GT { $dNum_123 = $dNum_Int } -> returnA -< (+) $dNum_123 z x + + That is, it attaches the $dNum_123 binding to a ConPatOut in scope. + + During desugaring, evidence binders must be collected because their sets are + intersected with free variable sets of subsequent commands to create + (minimal) command environments. Failing to do it properly leads to bugs + (e.g., #18950). -Here's the problem. Consider + Note: attaching evidence binders to existing ConPatOut may be suboptimal for + arrows. In the example above we would prefer to generate: -data T a where - C :: Num a => a -> Int -> T a + case compare x y of + GT -> returnA -< let $dNum_123 = $dNum_Int in (+) $dNum_123 z x -f ~(C (n+1) m) = (n,m) + So that the evidence isn't passed into the command environment. This issue + doesn't arise with desugaring of non-arrow code because the simplifier can + freely float and inline let-expressions created for evidence binders. But + with arrow desugaring, the simplifier would have to see through the command + environment tuple which is more complicated. -Here, the pattern (C (n+1)) binds a hidden dictionary (d::Num a), -and *also* uses that dictionary to match the (n+1) pattern. Yet, the -variables bound by the lazy pattern are n,m, *not* the dictionary d. -So in mkSelectorBinds in GHC.HsToCore.Utils, we want just m,n as the variables bound. -} hsGroupBinders :: HsGroup GhcRn -> [Name] hsGroupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls, hs_fords = foreign_decls }) - = collectHsValBinders val_decls + = collectHsValBinders CollNoDictBinders val_decls ++ hsTyClForeignBinders tycl_decls foreign_decls hsTyClForeignBinders :: [TyClGroup GhcRn] @@ -1398,7 +1504,7 @@ lPatImplicits = hs_lpat details :: Located Name -> HsConPatDetails GhcRn -> [(SrcSpan, [Name])] details _ (PrefixCon _ ps) = hs_lpats ps details n (RecCon fs) = - [(err_loc, collectPatsBinders implicit_pats) | Just{} <- [rec_dotdot fs] ] + [(err_loc, collectPatsBinders CollNoDictBinders implicit_pats) | Just{} <- [rec_dotdot fs] ] ++ hs_lpats explicit_pats where implicit_pats = map (hsRecFieldArg . unLoc) implicit diff --git a/compiler/GHC/HsToCore/Arrows.hs b/compiler/GHC/HsToCore/Arrows.hs index 60e3346ee7..6ebbcc9fd1 100644 --- a/compiler/GHC/HsToCore/Arrows.hs +++ b/compiler/GHC/HsToCore/Arrows.hs @@ -21,9 +21,7 @@ import GHC.HsToCore.Match import GHC.HsToCore.Utils import GHC.HsToCore.Monad -import GHC.Hs hiding (collectPatBinders, collectPatsBinders, - collectLStmtsBinders, collectLStmtBinders, - collectStmtBinders ) +import GHC.Hs import GHC.Tc.Utils.Zonk -- NB: The desugarer, which straddles the source and Core worlds, sometimes @@ -319,7 +317,7 @@ dsProcExpr -> DsM CoreExpr dsProcExpr pat (L _ (HsCmdTop (CmdTopTc _unitTy cmd_ty ids) cmd)) = do (meth_binds, meth_ids) <- mkCmdEnv ids - let locals = mkVarSet (collectPatBinders pat) + let locals = mkVarSet (collectPatBinders CollWithDictBinders pat) (core_cmd, _free_vars, env_ids) <- dsfixCmd meth_ids locals unitTy cmd_ty cmd let env_ty = mkBigCoreVarTupTy env_ids @@ -608,7 +606,7 @@ dsCmd ids local_vars stack_ty res_ty dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ lbinds@(L _ binds) body) env_ids = do let - defined_vars = mkVarSet (collectLocalBinders binds) + defined_vars = mkVarSet (collectLocalBinders CollWithDictBinders binds) local_vars' = defined_vars `unionVarSet` local_vars (core_body, _free_vars, env_ids') @@ -745,7 +743,7 @@ dsCmdLam :: DsCmdEnv -- arrow combinators -> DsM (CoreExpr, -- desugared expression DIdSet) -- subset of local vars that occur free dsCmdLam ids local_vars stack_ty res_ty pats body env_ids = do - let pat_vars = mkVarSet (collectPatsBinders pats) + let pat_vars = mkVarSet (collectPatsBinders CollWithDictBinders pats) let local_vars' = pat_vars `unionVarSet` local_vars (pat_tys, stack_ty') = splitTypeAt (length pats) stack_ty (core_body, free_vars, env_ids') @@ -812,7 +810,7 @@ dsCmdDo ids local_vars res_ty [L loc (LastStmt _ body _ _)] env_ids = do env_ids') dsCmdDo ids local_vars res_ty (stmt:stmts) env_ids = do - let bound_vars = mkVarSet (collectLStmtBinders stmt) + let bound_vars = mkVarSet (collectLStmtBinders CollWithDictBinders stmt) let local_vars' = bound_vars `unionVarSet` local_vars (core_stmts, _, env_ids') <- trimInput (dsCmdDo ids local_vars' res_ty stmts) (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids @@ -888,7 +886,7 @@ dsCmdStmt ids local_vars out_ids (BodyStmt c_ty cmd _ _) env_ids = do dsCmdStmt ids local_vars out_ids (BindStmt _ pat cmd) env_ids = do let pat_ty = hsLPatType pat (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy pat_ty cmd - let pat_vars = mkVarSet (collectPatBinders pat) + let pat_vars = mkVarSet (collectPatBinders CollWithDictBinders pat) let env_ids2 = filterOut (`elemVarSet` pat_vars) out_ids env_ty2 = mkBigCoreVarTupTy env_ids2 @@ -1125,7 +1123,7 @@ dsCmdStmts ids local_vars out_ids [stmt] env_ids = dsCmdLStmt ids local_vars out_ids stmt env_ids dsCmdStmts ids local_vars out_ids (stmt:stmts) env_ids = do - let bound_vars = mkVarSet (collectLStmtBinders stmt) + let bound_vars = mkVarSet (collectLStmtBinders CollWithDictBinders stmt) let local_vars' = bound_vars `unionVarSet` local_vars (core_stmts, _fv_stmts, env_ids') <- dsfixCmdStmts ids local_vars' out_ids stmts (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids @@ -1160,12 +1158,12 @@ leavesMatch :: LMatch GhcTc (Located (body GhcTc)) leavesMatch (L _ (Match { m_pats = pats , m_grhss = GRHSs _ grhss (L _ binds) })) = let - defined_vars = mkVarSet (collectPatsBinders pats) + defined_vars = mkVarSet (collectPatsBinders CollWithDictBinders pats) `unionVarSet` - mkVarSet (collectLocalBinders binds) + mkVarSet (collectLocalBinders CollWithDictBinders binds) in [(body, - mkVarSet (collectLStmtsBinders stmts) + mkVarSet (collectLStmtsBinders CollWithDictBinders stmts) `unionVarSet` defined_vars) | L _ (GRHS _ stmts body) <- grhss] @@ -1204,90 +1202,3 @@ foldb f xs = foldb f (fold_pairs xs) fold_pairs [] = [] fold_pairs [x] = [x] fold_pairs (x1:x2:xs) = f x1 x2:fold_pairs xs - -{- -Note [Dictionary binders in ConPatOut] See also same Note in GHC.Hs.Utils -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The following functions to collect value variables from patterns are -copied from GHC.Hs.Utils, with one change: we also collect the dictionary -bindings (cpt_binds) from ConPatOut. We need them for cases like - -h :: Arrow a => Int -> a (Int,Int) Int -h x = proc (y,z) -> case compare x y of - GT -> returnA -< z+x - -The type checker turns the case into - - case compare x y of - GT { p77 = plusInt } -> returnA -< p77 z x - -Here p77 is a local binding for the (+) operation. - -See comments in GHC.Hs.Utils for why the other version does not include -these bindings. --} - -collectPatBinders :: LPat GhcTc -> [Id] -collectPatBinders pat = collectl pat [] - -collectPatsBinders :: [LPat GhcTc] -> [Id] -collectPatsBinders pats = foldr collectl [] pats - ---------------------- -collectl :: LPat GhcTc -> [Id] -> [Id] --- See Note [Dictionary binders in ConPatOut] -collectl (L _ pat) bndrs - = go pat - where - go (VarPat _ (L _ var)) = var : bndrs - go (WildPat _) = bndrs - go (LazyPat _ pat) = collectl pat bndrs - go (BangPat _ pat) = collectl pat bndrs - go (AsPat _ (L _ a) pat) = a : collectl pat bndrs - go (ParPat _ pat) = collectl pat bndrs - - go (ListPat _ pats) = foldr collectl bndrs pats - go (TuplePat _ pats _) = foldr collectl bndrs pats - go (SumPat _ pat _ _) = collectl pat bndrs - - go (ConPat { pat_args = ps - , pat_con_ext = ConPatTc { cpt_binds = ds }}) = - collectEvBinders ds - ++ foldr collectl bndrs (hsConPatArgs ps) - go (LitPat _ _) = bndrs - go (NPat {}) = bndrs - go (NPlusKPat _ (L _ n) _ _ _ _) = n : bndrs - - go (SigPat _ pat _) = collectl pat bndrs - go (XPat (CoPat _ pat _)) = collectl (noLoc pat) bndrs - go (ViewPat _ _ pat) = collectl pat bndrs - go p@(SplicePat {}) = pprPanic "collectl/go" (ppr p) - -collectEvBinders :: TcEvBinds -> [Id] -collectEvBinders (EvBinds bs) = foldr add_ev_bndr [] bs -collectEvBinders (TcEvBinds {}) = panic "ToDo: collectEvBinders" - -add_ev_bndr :: EvBind -> [Id] -> [Id] -add_ev_bndr (EvBind { eb_lhs = b }) bs | isId b = b:bs - | otherwise = bs - -- A worry: what about coercion variable binders?? - -collectLStmtsBinders :: [LStmt GhcTc body] -> [Id] -collectLStmtsBinders = concatMap collectLStmtBinders - -collectLStmtBinders :: LStmt GhcTc body -> [Id] -collectLStmtBinders = collectStmtBinders . unLoc - -collectStmtBinders :: Stmt GhcTc body -> [Id] -collectStmtBinders (BindStmt _ pat _) = collectPatBinders pat -collectStmtBinders (LetStmt _ binds) = collectLocalBinders (unLoc binds) -collectStmtBinders (BodyStmt {}) = [] -collectStmtBinders (LastStmt {}) = [] -collectStmtBinders (ParStmt _ xs _ _) = collectLStmtsBinders - $ [s | ParStmtBlock _ ss _ _ <- xs, s <- ss] -collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts -collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss -collectStmtBinders (ApplicativeStmt _ args _) = concatMap collectArgBinders args - where - collectArgBinders (_, ApplicativeArgOne { app_arg_pattern = pat }) = collectPatBinders pat - collectArgBinders (_, ApplicativeArgMany { bv_pattern = pat }) = collectPatBinders pat diff --git a/compiler/GHC/HsToCore/Coverage.hs b/compiler/GHC/HsToCore/Coverage.hs index db0d72bc9d..09f3165b26 100644 --- a/compiler/GHC/HsToCore/Coverage.hs +++ b/compiler/GHC/HsToCore/Coverage.hs @@ -370,7 +370,7 @@ addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs patvar_tickss <- case simplePatId of Just{} -> return initial_patvar_tickss Nothing -> do - let patvars = map getOccString (collectPatBinders lhs) + let patvars = map getOccString (collectPatBinders CollNoDictBinders lhs) patvar_ticks <- mapM (\v -> bindTick density v pos fvs) patvars return (zipWith mbCons patvar_ticks @@ -572,7 +572,7 @@ addTickHsExpr (HsMultiIf ty alts) ; alts' <- mapM (liftL $ addTickGRHS isOneOfMany False) alts ; return $ HsMultiIf ty alts' } addTickHsExpr (HsLet x (L l binds) e) = - bindLocals (collectLocalBinders binds) $ + bindLocals (collectLocalBinders CollNoDictBinders binds) $ liftM2 (HsLet x . L l) (addTickHsLocalBinds binds) -- to think about: !patterns. (addTickLHsExprLetBody e) @@ -662,7 +662,7 @@ addTickMatch :: Bool -> Bool -> Match GhcTc (LHsExpr GhcTc) -> TM (Match GhcTc (LHsExpr GhcTc)) addTickMatch isOneOfMany isLambda match@(Match { m_pats = pats , m_grhss = gRHSs }) = - bindLocals (collectPatsBinders pats) $ do + bindLocals (collectPatsBinders CollNoDictBinders pats) $ do gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs return $ match { m_grhss = gRHSs' } @@ -674,7 +674,7 @@ addTickGRHSs isOneOfMany isLambda (GRHSs x guarded (L l local_binds)) = guarded' <- mapM (liftL (addTickGRHS isOneOfMany isLambda)) guarded return $ GRHSs x guarded' (L l local_binds') where - binders = collectLocalBinders local_binds + binders = collectLocalBinders CollNoDictBinders local_binds addTickGRHS :: Bool -> Bool -> GRHS GhcTc (LHsExpr GhcTc) -> TM (GRHS GhcTc (LHsExpr GhcTc)) @@ -704,7 +704,7 @@ addTickLStmts isGuard stmts = do addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc] -> TM a -> TM ([ExprLStmt GhcTc], a) addTickLStmts' isGuard lstmts res - = bindLocals (collectLStmtsBinders lstmts) $ + = bindLocals (collectLStmtsBinders CollNoDictBinders lstmts) $ do { lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts ; a <- res ; return (lstmts', a) } @@ -878,7 +878,7 @@ addTickHsCmd (HsCmdIf x cnd e1 c2 c3) = (addTickLHsCmd c2) (addTickLHsCmd c3) addTickHsCmd (HsCmdLet x (L l binds) c) = - bindLocals (collectLocalBinders binds) $ + bindLocals (collectLocalBinders CollNoDictBinders binds) $ liftM2 (HsCmdLet x . L l) (addTickHsLocalBinds binds) -- to think about: !patterns. (addTickLHsCmd c) @@ -915,7 +915,7 @@ addTickCmdMatchGroup mg@(MG { mg_alts = (L l matches) }) = do addTickCmdMatch :: Match GhcTc (LHsCmd GhcTc) -> TM (Match GhcTc (LHsCmd GhcTc)) addTickCmdMatch match@(Match { m_pats = pats, m_grhss = gRHSs }) = - bindLocals (collectPatsBinders pats) $ do + bindLocals (collectPatsBinders CollNoDictBinders pats) $ do gRHSs' <- addTickCmdGRHSs gRHSs return $ match { m_grhss = gRHSs' } @@ -926,7 +926,7 @@ addTickCmdGRHSs (GRHSs x guarded (L l local_binds)) = guarded' <- mapM (liftL addTickCmdGRHS) guarded return $ GRHSs x guarded' (L l local_binds') where - binders = collectLocalBinders local_binds + binders = collectLocalBinders CollNoDictBinders local_binds addTickCmdGRHS :: GRHS GhcTc (LHsCmd GhcTc) -> TM (GRHS GhcTc (LHsCmd GhcTc)) -- The *guards* are *not* Cmds, although the body is @@ -950,7 +950,7 @@ addTickLCmdStmts' lstmts res a <- res return (lstmts', a) where - binders = collectLStmtsBinders lstmts + binders = collectLStmtsBinders CollNoDictBinders lstmts addTickCmdStmt :: Stmt GhcTc (LHsCmd GhcTc) -> TM (Stmt GhcTc (LHsCmd GhcTc)) addTickCmdStmt (BindStmt x pat c) = diff --git a/compiler/GHC/HsToCore/Docs.hs b/compiler/GHC/HsToCore/Docs.hs index 0f80c61d65..21da052de6 100644 --- a/compiler/GHC/HsToCore/Docs.hs +++ b/compiler/GHC/HsToCore/Docs.hs @@ -118,7 +118,7 @@ user-written. This lets us relate Names (from ClsInsts) to comments getMainDeclBinder :: CollectPass (GhcPass p) => HsDecl (GhcPass p) -> [IdP (GhcPass p)] getMainDeclBinder (TyClD _ d) = [tcdName d] getMainDeclBinder (ValD _ d) = - case collectHsBindBinders d of + case collectHsBindBinders CollNoDictBinders d of [] -> [] (name:_) -> [name] getMainDeclBinder (SigD _ d) = sigNameNoLoc d diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs index bd48a19024..8007f36f02 100644 --- a/compiler/GHC/HsToCore/Match.hs +++ b/compiler/GHC/HsToCore/Match.hs @@ -453,7 +453,7 @@ tidy1 v _ (LazyPat _ pat) -- This is a convenient place to check for unlifted types under a lazy pattern. -- Doing this check during type-checking is unsatisfactory because we may -- not fully know the zonked types yet. We sure do here. - = do { let unlifted_bndrs = filter (isUnliftedType . idType) (collectPatBinders pat) + = do { let unlifted_bndrs = filter (isUnliftedType . idType) (collectPatBinders CollNoDictBinders pat) ; unless (null unlifted_bndrs) $ putSrcSpanDs (getLoc pat) $ errDs (hang (text "A lazy (~) pattern cannot bind variables of unlifted type." $$ diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs index d39a6d716a..629b082f6e 100644 --- a/compiler/GHC/HsToCore/Quote.hs +++ b/compiler/GHC/HsToCore/Quote.hs @@ -265,7 +265,7 @@ first generate a polymorphic definition and then just apply the wrapper at the e data M a repTopP :: LPat GhcRn -> MetaM (Core (M TH.Pat)) -repTopP pat = do { ss <- mkGenSyms (collectPatBinders pat) +repTopP pat = do { ss <- mkGenSyms (collectPatBinders CollNoDictBinders pat) ; pat' <- addBinds ss (repLP pat) ; wrapGenSyms ss pat' } @@ -1618,7 +1618,7 @@ repE e = notHandled "Expression form" (ppr e) repMatchTup :: LMatch GhcRn (LHsExpr GhcRn) -> MetaM (Core (M TH.Match)) repMatchTup (L _ (Match { m_pats = [p] , m_grhss = GRHSs _ guards (L _ wheres) })) = - do { ss1 <- mkGenSyms (collectPatBinders p) + do { ss1 <- mkGenSyms (collectPatBinders CollNoDictBinders p) ; addBinds ss1 $ do { ; p1 <- repLP p ; (ss2,ds) <- repBinds wheres @@ -1631,7 +1631,7 @@ repMatchTup _ = panic "repMatchTup: case alt with more than one arg" repClauseTup :: LMatch GhcRn (LHsExpr GhcRn) -> MetaM (Core (M TH.Clause)) repClauseTup (L _ (Match { m_pats = ps , m_grhss = GRHSs _ guards (L _ wheres) })) = - do { ss1 <- mkGenSyms (collectPatsBinders ps) + do { ss1 <- mkGenSyms (collectPatsBinders CollNoDictBinders ps) ; addBinds ss1 $ do { ps1 <- repLPs ps ; (ss2,ds) <- repBinds wheres @@ -1714,7 +1714,7 @@ repLSts stmts = repSts (map unLoc stmts) repSts :: [Stmt GhcRn (LHsExpr GhcRn)] -> MetaM ([GenSymBind], [Core (M TH.Stmt)]) repSts (BindStmt _ p e : ss) = do { e2 <- repLE e - ; ss1 <- mkGenSyms (collectPatBinders p) + ; ss1 <- mkGenSyms (collectPatBinders CollNoDictBinders p) ; addBinds ss1 $ do { ; p1 <- repLP p; ; (ss2,zs) <- repSts ss @@ -1749,7 +1749,7 @@ repSts [LastStmt _ e _ _] ; z <- repNoBindSt e2 ; return ([], [z]) } repSts (stmt@RecStmt{} : ss) - = do { let binders = collectLStmtsBinders (recS_stmts stmt) + = do { let binders = collectLStmtsBinders CollNoDictBinders (recS_stmts stmt) ; ss1 <- mkGenSyms binders -- Bring all of binders in the recursive group into scope for the -- whole group. @@ -1779,7 +1779,7 @@ repBinds (HsIPBinds _ (IPBinds _ decs)) } repBinds (HsValBinds _ decs) - = do { let { bndrs = hsScopedTvBinders decs ++ collectHsValBinders decs } + = do { let { bndrs = hsScopedTvBinders decs ++ collectHsValBinders CollNoDictBinders decs } -- No need to worry about detailed scopes within -- the binding group, because we are talking Names -- here, so we can safely treat it as a mutually @@ -1971,7 +1971,7 @@ repLambda :: LMatch GhcRn (LHsExpr GhcRn) -> MetaM (Core (M TH.Exp)) repLambda (L _ (Match { m_pats = ps , m_grhss = GRHSs _ [L _ (GRHS _ [] e)] (L _ (EmptyLocalBinds _)) } )) - = do { let bndrs = collectPatsBinders ps ; + = do { let bndrs = collectPatsBinders CollNoDictBinders ps ; ; ss <- mkGenSyms bndrs ; lam <- addBinds ss ( do { xs <- repLPs ps; body <- repLE e; repLam xs body }) diff --git a/compiler/GHC/HsToCore/Utils.hs b/compiler/GHC/HsToCore/Utils.hs index 6384867a93..493324cf97 100644 --- a/compiler/GHC/HsToCore/Utils.hs +++ b/compiler/GHC/HsToCore/Utils.hs @@ -722,7 +722,7 @@ mkSelectorBinds ticks pat val_expr -- Strip the bangs before looking for case (A) or (B) -- The incoming pattern may well have a bang on it - binders = collectPatBinders pat' + binders = collectPatBinders CollNoDictBinders pat' ticks' = ticks ++ repeat [] local_binders = map localiseId binders -- See Note [Localise pattern binders] diff --git a/compiler/GHC/Rename/Bind.hs b/compiler/GHC/Rename/Bind.hs index ea76feea82..fdcf89104f 100644 --- a/compiler/GHC/Rename/Bind.hs +++ b/compiler/GHC/Rename/Bind.hs @@ -266,7 +266,7 @@ rnLocalValBindsLHS fix_env binds -- import A(f) -- g = let f = ... in f -- should. - ; let bound_names = collectHsValBinders binds' + ; let bound_names = collectHsValBinders CollNoDictBinders binds' -- There should be only Ids, but if there are any bogus -- pattern synonyms, we'll collect them anyway, so that -- we don't generate subsequent out-of-scope messages @@ -285,7 +285,7 @@ rnValBindsLHS topP (ValBinds x mbinds sigs) = do { mbinds' <- mapBagM (wrapLocM (rnBindLHS topP doc)) mbinds ; return $ ValBinds x mbinds' sigs } where - bndrs = collectHsBindsBinders mbinds + bndrs = collectHsBindsBinders CollNoDictBinders mbinds doc = text "In the binding group for:" <+> pprWithCommas ppr bndrs rnValBindsLHS _ b = pprPanic "rnValBindsLHSFromDoc" (ppr b) @@ -472,7 +472,7 @@ rnBind _ bind@(PatBind { pat_lhs = pat -- Keep locally-defined Names -- As well as dependency analysis, we need these for the -- MonoLocalBinds test in GHC.Tc.Gen.Bind.decideGeneralisationPlan - bndrs = collectPatBinders pat + bndrs = collectPatBinders CollNoDictBinders pat bind' = bind { pat_rhs = grhss' , pat_ext = fvs' } @@ -864,7 +864,7 @@ rnMethodBinds is_cls_decl cls ktv_names binds sigs -- (==) :: a -> a -> a -- {-# SPECIALISE instance Eq a => Eq (T [a]) #-} ; let (spec_inst_prags, other_sigs) = partition isSpecInstLSig sigs - bound_nms = mkNameSet (collectHsBindsBinders binds') + bound_nms = mkNameSet (collectHsBindsBinders CollNoDictBinders binds') sig_ctxt | is_cls_decl = ClsDeclCtxt cls | otherwise = InstDeclCtxt bound_nms ; (spec_inst_prags', sip_fvs) <- renameSigs sig_ctxt spec_inst_prags diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs index b38b4679b1..bfa773ed9f 100644 --- a/compiler/GHC/Rename/Expr.hs +++ b/compiler/GHC/Rename/Expr.hs @@ -838,7 +838,7 @@ rnStmt ctxt rnBody (L loc (BindStmt _ pat body)) thing_inside ; (fail_op, fvs2) <- monadFailOp pat ctxt ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do - { (thing, fvs3) <- thing_inside (collectPatBinders pat') + { (thing, fvs3) <- thing_inside (collectPatBinders CollNoDictBinders pat') ; let xbsrn = XBindStmtRn { xbsrn_bindOp = bind_op, xbsrn_failOp = fail_op } ; return (( [( L loc (BindStmt xbsrn pat' body'), fv_expr )] , thing), @@ -848,7 +848,7 @@ rnStmt ctxt rnBody (L loc (BindStmt _ pat body)) thing_inside rnStmt _ _ (L loc (LetStmt _ (L l binds))) thing_inside = rnLocalBindsAndThen binds $ \binds' bind_fvs -> do - { (thing, fvs) <- thing_inside (collectLocalBinders binds') + { (thing, fvs) <- thing_inside (collectLocalBinders CollNoDictBinders binds') ; return ( ([(L loc (LetStmt noExtField (L l binds')), bind_fvs)], thing) , fvs) } @@ -1064,7 +1064,7 @@ rnRecStmtsAndThen ctxt rnBody s cont ; new_lhs_and_fv <- rn_rec_stmts_lhs fix_env s -- ...bring them and their fixities into scope - ; let bound_names = collectLStmtsBinders (map fst new_lhs_and_fv) + ; let bound_names = collectLStmtsBinders CollNoDictBinders (map fst new_lhs_and_fv) -- Fake uses of variables introduced implicitly (warning suppression, see #4404) rec_uses = lStmtsImplicits (map fst new_lhs_and_fv) implicit_uses = mkNameSet $ concatMap snd $ rec_uses @@ -1141,7 +1141,7 @@ rn_rec_stmts_lhs :: Outputable body => MiniFixityEnv -> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)] rn_rec_stmts_lhs fix_env stmts = do { ls <- concatMapM (rn_rec_stmt_lhs fix_env) stmts - ; let boundNames = collectLStmtsBinders (map fst ls) + ; let boundNames = collectLStmtsBinders CollNoDictBinders (map fst ls) -- First do error checking: we need to check for dups here because we -- don't bind all of the variables from the Stmt at once -- with bindLocatedLocals. @@ -1178,7 +1178,7 @@ rn_rec_stmt ctxt rnBody _ (L loc (BindStmt _ pat' body), fv_pat) ; (fail_op, fvs2) <- getMonadFailOp ctxt - ; let bndrs = mkNameSet (collectPatBinders pat') + ; let bndrs = mkNameSet (collectPatBinders CollNoDictBinders pat') fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2 ; let xbsrn = XBindStmtRn { xbsrn_bindOp = bind_op, xbsrn_failOp = fail_op } ; return [(bndrs, fvs, bndrs `intersectNameSet` fvs, @@ -1734,7 +1734,7 @@ stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do }, emptyFVs) stmtTreeArg ctxt tail_fvs tree = do let stmts = flattenStmtTree tree - pvarset = mkNameSet (concatMap (collectStmtBinders.unLoc.fst) stmts) + pvarset = mkNameSet (concatMap (collectStmtBinders CollNoDictBinders . unLoc . fst) stmts) `intersectNameSet` tail_fvs pvars = nameSetElemsStable pvarset -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring] @@ -1765,7 +1765,7 @@ segments -> [[(ExprLStmt GhcRn, FreeVars)]] segments stmts = map fst $ merge $ reverse $ map reverse $ walk (reverse stmts) where - allvars = mkNameSet (concatMap (collectStmtBinders.unLoc.fst) stmts) + allvars = mkNameSet (concatMap (collectStmtBinders CollNoDictBinders . unLoc . fst) stmts) -- We would rather not have a segment that just has LetStmts in -- it, so combine those with an adjacent segment where possible. @@ -1805,7 +1805,7 @@ segments stmts = map fst $ merge $ reverse $ map reverse $ walk (reverse stmts) | isLetStmt stmt = (pvars, fvs' `minusNameSet` pvars) | otherwise = (pvars, fvs') where fvs' = fvs `intersectNameSet` allvars - pvars = mkNameSet (collectStmtBinders (unLoc stmt)) + pvars = mkNameSet (collectStmtBinders CollNoDictBinders (unLoc stmt)) isStrictPatternBind :: ExprLStmt GhcRn -> Bool isStrictPatternBind (L _ (BindStmt _ pat _)) = isStrictPattern pat @@ -1912,7 +1912,7 @@ slurpIndependentStmts stmts = go [] [] emptyNameSet stmts | disjointNameSet bndrs fvs && not (isStrictPattern pat) = go lets ((L loc (BindStmt xbs pat body), fvs) : indep) bndrs' rest - where bndrs' = bndrs `unionNameSet` mkNameSet (collectPatBinders pat) + where bndrs' = bndrs `unionNameSet` mkNameSet (collectPatBinders CollNoDictBinders pat) -- If we encounter a LetStmt that doesn't depend on a BindStmt in this -- group, then move it to the beginning, so that it doesn't interfere with -- grouping more BindStmts. diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs index e098156d1d..7fd73855ba 100644 --- a/compiler/GHC/Rename/Module.hs +++ b/compiler/GHC/Rename/Module.hs @@ -141,8 +141,9 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls, new_lhs <- rnTopBindsLHS local_fix_env val_decls ; -- Bind the LHSes (and their fixities) in the global rdr environment - let { id_bndrs = collectHsIdBinders new_lhs } ; -- Excludes pattern-synonym binders - -- They are already in scope + let { id_bndrs = collectHsIdBinders CollNoDictBinders new_lhs } ; + -- Excludes pattern-synonym binders + -- They are already in scope traceRn "rnSrcDecls" (ppr id_bndrs) ; tc_envs <- extendGlobalRdrEnvRn (map avail id_bndrs) local_fix_env ; setEnvs tc_envs $ do { diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs index a52f7bca3c..0f6e4e1cce 100644 --- a/compiler/GHC/Rename/Names.hs +++ b/compiler/GHC/Rename/Names.hs @@ -1432,7 +1432,7 @@ warnMissingSignatures gbl_env = do { let exports = availsToNameSet (tcg_exports gbl_env) sig_ns = tcg_sigs gbl_env -- We use sig_ns to exclude top-level bindings that are generated by GHC - binds = collectHsBindsBinders $ tcg_binds gbl_env + binds = collectHsBindsBinders CollNoDictBinders $ tcg_binds gbl_env pat_syns = tcg_patsyns gbl_env -- Warn about missing signatures diff --git a/compiler/GHC/Rename/Pat.hs b/compiler/GHC/Rename/Pat.hs index 80ab505ee5..80341b27ac 100644 --- a/compiler/GHC/Rename/Pat.hs +++ b/compiler/GHC/Rename/Pat.hs @@ -341,7 +341,7 @@ rnPats ctxt pats thing_inside -- complain *twice* about duplicates e.g. f (x,x) = ... -- -- See note [Don't report shadowing for pattern synonyms] - ; let bndrs = collectPatsBinders pats' + ; let bndrs = collectPatsBinders CollNoDictBinders pats' ; addErrCtxt doc_pat $ if isPatSynCtxt ctxt then checkDupNames bndrs @@ -596,7 +596,7 @@ rnHsRecPatsAndThen mk (L _ con) loc = maybe noSrcSpan getLoc dd -- Get the arguments of the implicit binders - implicit_binders fs (unLoc -> n) = collectPatsBinders implicit_pats + implicit_binders fs (unLoc -> n) = collectPatsBinders CollNoDictBinders implicit_pats where implicit_pats = map (hsRecFieldArg . unLoc) (drop n fs) diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs index 4528bb5f1b..b61d265583 100644 --- a/compiler/GHC/Tc/Gen/Bind.hs +++ b/compiler/GHC/Tc/Gen/Bind.hs @@ -438,7 +438,7 @@ recursivePatSynErr loc binds 2 (vcat $ map pprLBind . bagToList $ binds) where pprLoc loc = parens (text "defined at" <+> ppr loc) - pprLBind (L loc bind) = pprWithCommas ppr (collectHsBindBinders bind) + pprLBind (L loc bind) = pprWithCommas ppr (collectHsBindBinders CollNoDictBinders bind) <+> pprLoc loc tc_single :: forall thing. @@ -488,7 +488,7 @@ mkEdges sig_fn binds key_map :: NameEnv BKey -- Which binding it comes from key_map = mkNameEnv [(bndr, key) | (L _ bind, key) <- keyd_binds - , bndr <- collectHsBindBinders bind ] + , bndr <- collectHsBindBinders CollNoDictBinders bind ] ------------------------ tcPolyBinds :: TcSigFun -> TcPragEnv @@ -531,7 +531,7 @@ tcPolyBinds sig_fn prag_fn rec_group rec_tc closed bind_list ; return result } where - binder_names = collectHsBindListBinders bind_list + binder_names = collectHsBindListBinders CollNoDictBinders bind_list loc = foldr1 combineSrcSpans (map getLoc bind_list) -- The mbinds have been dependency analysed and -- may no longer be adjacent; so find the narrowest @@ -1245,7 +1245,7 @@ tcMonoBinds is_rec sig_fn no_gen , mbis ) } where - bndrs = collectPatBinders pat + bndrs = collectPatBinders CollNoDictBinders pat -- GENERAL CASE tcMonoBinds _ sig_fn no_gen binds @@ -1407,7 +1407,7 @@ tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss }) ; return (TcPatBind mbis pat' grhss pat_ty) } where - bndr_names = collectPatBinders pat + bndr_names = collectPatBinders CollNoDictBinders pat (nosig_names, sig_names) = partitionWith find_sig bndr_names find_sig :: Name -> Either Name (Name, TcIdSigInfo) @@ -1672,7 +1672,7 @@ decideGeneralisationPlan dflags lbinds closed sig_fn partial_sig_mrs = [ null theta | TcIdSig (PartialSig { psig_hs_ty = hs_ty }) - <- mapMaybe sig_fn (collectHsBindListBinders lbinds) + <- mapMaybe sig_fn (collectHsBindListBinders CollNoDictBinders lbinds) , let (L _ theta, _) = splitLHsQualTy (hsSigWcType hs_ty) ] has_partial_sigs = not (null partial_sig_mrs) @@ -1724,7 +1724,7 @@ isClosedBndrGroup type_env binds in [(f, open_fvs)] bindFvs (PatBind { pat_lhs = pat, pat_ext = fvs }) = let open_fvs = get_open_fvs fvs - in [(b, open_fvs) | b <- collectPatBinders pat] + in [(b, open_fvs) | b <- collectPatBinders CollNoDictBinders pat] bindFvs _ = [] diff --git a/compiler/GHC/Tc/Gen/Match.hs b/compiler/GHC/Tc/Gen/Match.hs index 3d20305c88..fb8d58c520 100644 --- a/compiler/GHC/Tc/Gen/Match.hs +++ b/compiler/GHC/Tc/Gen/Match.hs @@ -1062,8 +1062,8 @@ tcApplicativeStmts ctxt pairs rhs_ty thing_inside ; return (ApplicativeArgMany x stmts' ret' pat' ctxt) } get_arg_bndrs :: ApplicativeArg GhcTc -> [Id] - get_arg_bndrs (ApplicativeArgOne { app_arg_pattern = pat }) = collectPatBinders pat - get_arg_bndrs (ApplicativeArgMany { bv_pattern = pat }) = collectPatBinders pat + get_arg_bndrs (ApplicativeArgOne { app_arg_pattern = pat }) = collectPatBinders CollNoDictBinders pat + get_arg_bndrs (ApplicativeArgMany { bv_pattern = pat }) = collectPatBinders CollNoDictBinders pat {- Note [ApplicativeDo and constraints] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs index dfb6e4fe3e..2e55974f90 100644 --- a/compiler/GHC/Tc/Gen/Splice.hs +++ b/compiler/GHC/Tc/Gen/Splice.hs @@ -1153,7 +1153,7 @@ instance TH.Quasi TcM where where checkTopDecl :: HsDecl GhcPs -> TcM () checkTopDecl (ValD _ binds) - = mapM_ bindName (collectHsBindBinders binds) + = mapM_ bindName (collectHsBindBinders CollNoDictBinders binds) checkTopDecl (SigD _ _) = return () checkTopDecl (AnnD _ _) diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs index a77f9fe71a..e8073d763e 100644 --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -1493,7 +1493,7 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls, ; fo_fvs = foldr (\gre fvs -> fvs `addOneFV` greMangledName gre) emptyFVs fo_gres - ; sig_names = mkNameSet (collectHsValBinders hs_val_binds) + ; sig_names = mkNameSet (collectHsValBinders CollNoDictBinders hs_val_binds) `minusNameSet` getTypeSigNames val_sigs -- Extend the GblEnv with the (as yet un-zonked) @@ -2363,8 +2363,8 @@ tcUserStmt rdr_stmt@(L loc _) ; opt_pr_flag <- goptM Opt_PrintBindResult ; let print_result_plan | opt_pr_flag -- The flag says "print result" - , [v] <- collectLStmtBinders gi_stmt -- One binder - = [mk_print_result_plan gi_stmt v] + , [v] <- collectLStmtBinders CollNoDictBinders gi_stmt -- One binder + = [mk_print_result_plan gi_stmt v] | otherwise = [] -- The plans are: @@ -2414,7 +2414,7 @@ tcGhciStmts stmts io_ret_ty = mkTyConApp ioTyCon [ret_ty] tc_io_stmts = tcStmtsAndThen GhciStmtCtxt tcDoStmt stmts (mkCheckExpType io_ret_ty) - names = collectLStmtsBinders stmts + names = collectLStmtsBinders CollNoDictBinders stmts -- OK, we're ready to typecheck the stmts ; traceTc "GHC.Tc.Module.tcGhciStmts: tc stmts" empty diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs index 69656b41da..d4e8827d3d 100644 --- a/compiler/GHC/Tc/TyCl/Instance.hs +++ b/compiler/GHC/Tc/TyCl/Instance.hs @@ -1153,9 +1153,9 @@ tcInstDecls2 tycl_decls inst_decls ; let dm_binds = unionManyBags dm_binds_s -- (b) instance declarations - ; let dm_ids = collectHsBindsBinders dm_binds + ; let dm_ids = collectHsBindsBinders CollNoDictBinders dm_binds -- Add the default method Ids (again) - -- (they were arready added in GHC.Tc.TyCl.Utils.tcAddImplicits) + -- (they were already added in GHC.Tc.TyCl.Utils.tcAddImplicits) -- See Note [Default methods in the type environment] ; inst_binds_s <- tcExtendGlobalValEnv dm_ids $ mapM tcInstDecl2 inst_decls diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs index 9e2908fff8..b34e3269a1 100644 --- a/compiler/GHC/Tc/Utils/Zonk.hs +++ b/compiler/GHC/Tc/Utils/Zonk.hs @@ -531,7 +531,7 @@ zonkLocalBinds env (HsIPBinds x (IPBinds dict_binds binds )) = do zonkRecMonoBinds :: ZonkEnv -> LHsBinds GhcTc -> TcM (ZonkEnv, LHsBinds GhcTc) zonkRecMonoBinds env binds = fixM (\ ~(_, new_binds) -> do - { let env1 = extendIdZonkEnvRec env (collectHsBindsBinders new_binds) + { let env1 = extendIdZonkEnvRec env (collectHsBindsBinders CollNoDictBinders new_binds) ; binds' <- zonkMonoBinds env1 binds ; return (env1, binds') }) @@ -580,7 +580,7 @@ zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs ; (env2, new_ev_binds) <- zonkTcEvBinds_s env1 ev_binds ; (new_val_bind, new_exports) <- fixM $ \ ~(new_val_binds, _) -> do { let env3 = extendIdZonkEnvRec env2 $ - collectHsBindsBinders new_val_binds + collectHsBindsBinders CollNoDictBinders new_val_binds ; new_val_binds <- mapBagM (zonk_val_bind env3) val_binds ; new_exports <- mapM (zonk_export env3) exports ; return (new_val_binds, new_exports) } |