diff options
author | Sylvain Henry <sylvain@haskus.fr> | 2020-11-26 15:34:46 +0100 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-01-22 14:58:53 -0500 |
commit | 29173f888892f18f3461880ef81ee7ba5fd539db (patch) | |
tree | 53c5cd78554d732c891a670954b22df178fb97ec /compiler/GHC/Rename | |
parent | 01ea56a22d7cf55f5285b130b357d3112c92de5b (diff) | |
download | haskell-29173f888892f18f3461880ef81ee7ba5fd539db.tar.gz |
Factorize and document binder collect functions
Parameterize collect*Binders functions with a flag indicating if
evidence binders should be collected.
The related note in GHC.Hs.Utils has been updated.
Bump haddock submodule
Diffstat (limited to 'compiler/GHC/Rename')
-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 |
5 files changed, 19 insertions, 18 deletions
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) |