Commit ac79dfe9 authored by Richard Lupton's avatar Richard Lupton Committed by Marge Bot

Remove Bag fold specialisations (#16969)

parent 2a394246
...@@ -482,7 +482,7 @@ calcUnfoldingGuidance dflags is_top_bottoming expr ...@@ -482,7 +482,7 @@ calcUnfoldingGuidance dflags is_top_bottoming expr
n_val_bndrs = length val_bndrs n_val_bndrs = length val_bndrs
mk_discount :: Bag (Id,Int) -> Id -> Int mk_discount :: Bag (Id,Int) -> Id -> Int
mk_discount cbs bndr = foldlBag combine 0 cbs mk_discount cbs bndr = foldl' combine 0 cbs
where where
combine acc (bndr', disc) combine acc (bndr', disc)
| bndr == bndr' = acc `plus_disc` disc | bndr == bndr' = acc `plus_disc` disc
......
...@@ -121,7 +121,7 @@ guessSourceFile :: LHsBinds GhcTc -> FilePath -> FilePath ...@@ -121,7 +121,7 @@ guessSourceFile :: LHsBinds GhcTc -> FilePath -> FilePath
guessSourceFile binds orig_file = guessSourceFile binds orig_file =
-- Try look for a file generated from a .hsc file to a -- Try look for a file generated from a .hsc file to a
-- .hs file, by peeking ahead. -- .hs file, by peeking ahead.
let top_pos = catMaybes $ foldrBag (\ (dL->L pos _) rest -> let top_pos = catMaybes $ foldr (\ (dL->L pos _) rest ->
srcSpanFileName_maybe pos : rest) [] binds srcSpanFileName_maybe pos : rest) [] binds
in in
case top_pos of case top_pos of
......
...@@ -50,7 +50,6 @@ import TysWiredIn ...@@ -50,7 +50,6 @@ import TysWiredIn
import BasicTypes import BasicTypes
import PrelNames import PrelNames
import Outputable import Outputable
import Bag
import VarSet import VarSet
import SrcLoc import SrcLoc
import ListSetOps( assocMaybe ) import ListSetOps( assocMaybe )
...@@ -1251,7 +1250,7 @@ collectl (dL->L _ pat) bndrs ...@@ -1251,7 +1250,7 @@ collectl (dL->L _ pat) bndrs
go p@(XPat {}) = pprPanic "collectl/go" (ppr p) go p@(XPat {}) = pprPanic "collectl/go" (ppr p)
collectEvBinders :: TcEvBinds -> [Id] collectEvBinders :: TcEvBinds -> [Id]
collectEvBinders (EvBinds bs) = foldrBag add_ev_bndr [] bs collectEvBinders (EvBinds bs) = foldr add_ev_bndr [] bs
collectEvBinders (TcEvBinds {}) = panic "ToDo: collectEvBinders" collectEvBinders (TcEvBinds {}) = panic "ToDo: collectEvBinders"
add_ev_bndr :: EvBind -> [Id] -> [Id] add_ev_bndr :: EvBind -> [Id] -> [Id]
......
...@@ -1164,7 +1164,7 @@ mk_ev_binds ds_binds ...@@ -1164,7 +1164,7 @@ mk_ev_binds ds_binds
= map ds_scc (stronglyConnCompFromEdgedVerticesUniq edges) = map ds_scc (stronglyConnCompFromEdgedVerticesUniq edges)
where where
edges :: [ Node EvVar (EvVar,CoreExpr) ] edges :: [ Node EvVar (EvVar,CoreExpr) ]
edges = foldrBag ((:) . mk_node) [] ds_binds edges = foldr ((:) . mk_node) [] ds_binds
mk_node :: (Id, CoreExpr) -> Node EvVar (EvVar,CoreExpr) mk_node :: (Id, CoreExpr) -> Node EvVar (EvVar,CoreExpr)
mk_node b@(var, rhs) mk_node b@(var, rhs)
......
...@@ -187,7 +187,7 @@ dsUnliftedBind (AbsBinds { abs_tvs = [], abs_ev_vars = [] ...@@ -187,7 +187,7 @@ dsUnliftedBind (AbsBinds { abs_tvs = [], abs_ev_vars = []
, abs_binds = lbinds }) body , abs_binds = lbinds }) body
= do { let body1 = foldr bind_export body exports = do { let body1 = foldr bind_export body exports
bind_export export b = bindNonRec (abe_poly export) (Var (abe_mono export)) b bind_export export b = bindNonRec (abe_poly export) (Var (abe_mono export)) b
; body2 <- foldlBagM (\body lbind -> dsUnliftedBind (unLoc lbind) body) ; body2 <- foldlM (\body lbind -> dsUnliftedBind (unLoc lbind) body)
body1 lbinds body1 lbinds
; ds_binds <- dsTcEvBinds_s ev_binds ; ds_binds <- dsTcEvBinds_s ev_binds
; return (mkCoreLets ds_binds body2) } ; return (mkCoreLets ds_binds body2) }
......
...@@ -1000,7 +1000,7 @@ collect_out_binds ps = foldr (collect_binds ps . snd) [] ...@@ -1000,7 +1000,7 @@ collect_out_binds ps = foldr (collect_binds ps . snd) []
collect_binds :: Bool -> LHsBindsLR (GhcPass p) idR -> collect_binds :: Bool -> LHsBindsLR (GhcPass p) idR ->
[IdP (GhcPass p)] -> [IdP (GhcPass p)] [IdP (GhcPass p)] -> [IdP (GhcPass p)]
-- Collect Ids, or Ids + pattern synonyms, depending on boolean flag -- Collect Ids, or Ids + pattern synonyms, depending on boolean flag
collect_binds ps binds acc = foldrBag (collect_bind ps . unLoc) acc binds collect_binds ps binds acc = foldr (collect_bind ps . unLoc) acc binds
collect_bind :: (SrcSpanLess (LPat p) ~ Pat p , HasSrcSpan (LPat p)) => collect_bind :: (SrcSpanLess (LPat p) ~ Pat p , HasSrcSpan (LPat p)) =>
Bool -> HsBindLR p idR -> [IdP p] -> [IdP p] Bool -> HsBindLR p idR -> [IdP p] -> [IdP p]
...@@ -1019,7 +1019,7 @@ collect_bind _ (XHsBindsLR _) acc = acc ...@@ -1019,7 +1019,7 @@ collect_bind _ (XHsBindsLR _) acc = acc
collectMethodBinders :: LHsBindsLR idL idR -> [Located (IdP idL)] collectMethodBinders :: LHsBindsLR idL idR -> [Located (IdP idL)]
-- Used exclusively for the bindings of an instance decl which are all FunBinds -- Used exclusively for the bindings of an instance decl which are all FunBinds
collectMethodBinders binds = foldrBag (get . unLoc) [] binds collectMethodBinders binds = foldr (get . unLoc) [] binds
where where
get (FunBind { fun_id = f }) fs = f : fs get (FunBind { fun_id = f }) fs = f : fs
get _ fs = fs get _ fs = fs
...@@ -1201,7 +1201,7 @@ hsPatSynSelectors :: HsValBinds (GhcPass p) -> [IdP (GhcPass p)] ...@@ -1201,7 +1201,7 @@ hsPatSynSelectors :: HsValBinds (GhcPass p) -> [IdP (GhcPass p)]
-- names are collected by collectHsValBinders. -- names are collected by collectHsValBinders.
hsPatSynSelectors (ValBinds _ _ _) = panic "hsPatSynSelectors" hsPatSynSelectors (ValBinds _ _ _) = panic "hsPatSynSelectors"
hsPatSynSelectors (XValBindsLR (NValBinds binds _)) hsPatSynSelectors (XValBindsLR (NValBinds binds _))
= foldrBag addPatSynSelector [] . unionManyBags $ map snd binds = foldr addPatSynSelector [] . unionManyBags $ map snd binds
addPatSynSelector:: LHsBind p -> [IdP p] -> [IdP p] addPatSynSelector:: LHsBind p -> [IdP p] -> [IdP p]
addPatSynSelector bind sels addPatSynSelector bind sels
......
...@@ -310,7 +310,7 @@ buildGraph code ...@@ -310,7 +310,7 @@ buildGraph code
-- Add the reg-reg conflicts to the graph. -- Add the reg-reg conflicts to the graph.
let conflictBag = unionManyBags conflictList let conflictBag = unionManyBags conflictList
let graph_conflict let graph_conflict
= foldrBag graphAddConflictSet Color.initGraph conflictBag = foldr graphAddConflictSet Color.initGraph conflictBag
-- Add the coalescences edges to the graph. -- Add the coalescences edges to the graph.
let moveBag let moveBag
...@@ -318,7 +318,7 @@ buildGraph code ...@@ -318,7 +318,7 @@ buildGraph code
(unionManyBags moveList) (unionManyBags moveList)
let graph_coalesce let graph_coalesce
= foldrBag graphAddCoalesce graph_conflict moveBag = foldr graphAddCoalesce graph_conflict moveBag
return graph_coalesce return graph_coalesce
......
...@@ -853,7 +853,7 @@ rnMethodBinds is_cls_decl cls ktv_names binds sigs ...@@ -853,7 +853,7 @@ rnMethodBinds is_cls_decl cls ktv_names binds sigs
-- for instance decls too -- for instance decls too
-- Rename the bindings LHSs -- Rename the bindings LHSs
; binds' <- foldrBagM (rnMethodBindLHS is_cls_decl cls) emptyBag binds ; binds' <- foldrM (rnMethodBindLHS is_cls_decl cls) emptyBag binds
-- Rename the pragmas and signatures -- Rename the pragmas and signatures
-- Annoyingly the type variables /are/ in scope for signatures, but -- Annoyingly the type variables /are/ in scope for signatures, but
...@@ -875,7 +875,7 @@ rnMethodBinds is_cls_decl cls ktv_names binds sigs ...@@ -875,7 +875,7 @@ rnMethodBinds is_cls_decl cls ktv_names binds sigs
; scoped_tvs <- xoptM LangExt.ScopedTypeVariables ; scoped_tvs <- xoptM LangExt.ScopedTypeVariables
; (binds'', bind_fvs) <- maybe_extend_tyvar_env scoped_tvs $ ; (binds'', bind_fvs) <- maybe_extend_tyvar_env scoped_tvs $
do { binds_w_dus <- mapBagM (rnLBind (mkScopedTvFn other_sigs')) binds' do { binds_w_dus <- mapBagM (rnLBind (mkScopedTvFn other_sigs')) binds'
; let bind_fvs = foldrBag (\(_,_,fv1) fv2 -> fv1 `plusFV` fv2) ; let bind_fvs = foldr (\(_,_,fv1) fv2 -> fv1 `plusFV` fv2)
emptyFVs binds_w_dus emptyFVs binds_w_dus
; return (mapBag fstOf3 binds_w_dus, bind_fvs) } ; return (mapBag fstOf3 binds_w_dus, bind_fvs) }
......
...@@ -2135,7 +2135,7 @@ extendPatSynEnv val_decls local_fix_env thing = do { ...@@ -2135,7 +2135,7 @@ extendPatSynEnv val_decls local_fix_env thing = do {
; setEnvs (final_gbl_env, lcl_env) (thing pat_syn_bndrs) } ; setEnvs (final_gbl_env, lcl_env) (thing pat_syn_bndrs) }
where where
new_ps :: HsValBinds GhcPs -> TcM [(Name, [FieldLabel])] new_ps :: HsValBinds GhcPs -> TcM [(Name, [FieldLabel])]
new_ps (ValBinds _ binds _) = foldrBagM new_ps' [] binds new_ps (ValBinds _ binds _) = foldrM new_ps' [] binds
new_ps _ = panic "new_ps" new_ps _ = panic "new_ps"
new_ps' :: LHsBindLR GhcPs GhcPs new_ps' :: LHsBindLR GhcPs GhcPs
......
...@@ -629,7 +629,7 @@ flattenTopFloats (FB tops ceils defs) ...@@ -629,7 +629,7 @@ flattenTopFloats (FB tops ceils defs)
addTopFloatPairs :: Bag CoreBind -> [(Id,CoreExpr)] -> [(Id,CoreExpr)] addTopFloatPairs :: Bag CoreBind -> [(Id,CoreExpr)] -> [(Id,CoreExpr)]
addTopFloatPairs float_bag prs addTopFloatPairs float_bag prs
= foldrBag add prs float_bag = foldr add prs float_bag
where where
add (NonRec b r) prs = (b,r):prs add (NonRec b r) prs = (b,r):prs
add (Rec prs1) prs2 = prs1 ++ prs2 add (Rec prs1) prs2 = prs1 ++ prs2
...@@ -673,7 +673,7 @@ plusMinor = M.unionWith unionBags ...@@ -673,7 +673,7 @@ plusMinor = M.unionWith unionBags
install :: Bag FloatBind -> CoreExpr -> CoreExpr install :: Bag FloatBind -> CoreExpr -> CoreExpr
install defn_groups expr install defn_groups expr
= foldrBag wrapFloat expr defn_groups = foldr wrapFloat expr defn_groups
partitionByLevel partitionByLevel
:: Level -- Partitioning level :: Level -- Partitioning level
......
...@@ -2181,7 +2181,7 @@ callDetailsFVs calls = ...@@ -2181,7 +2181,7 @@ callDetailsFVs calls =
callInfoFVs :: CallInfoSet -> VarSet callInfoFVs :: CallInfoSet -> VarSet
callInfoFVs (CIS _ call_info) = callInfoFVs (CIS _ call_info) =
foldrBag (\(CI { ci_fvs = fv }) vs -> unionVarSet fv vs) emptyVarSet call_info foldr (\(CI { ci_fvs = fv }) vs -> unionVarSet fv vs) emptyVarSet call_info
computeArity :: [SpecArg] -> Int computeArity :: [SpecArg] -> Int
computeArity = length . filter isValueArg . dropWhileEndLE isUnspecArg computeArity = length . filter isValueArg . dropWhileEndLE isUnspecArg
...@@ -2350,7 +2350,7 @@ plusUDs (MkUD {ud_binds = db1, ud_calls = calls1}) ...@@ -2350,7 +2350,7 @@ plusUDs (MkUD {ud_binds = db1, ud_calls = calls1})
----------------------------- -----------------------------
_dictBindBndrs :: Bag DictBind -> [Id] _dictBindBndrs :: Bag DictBind -> [Id]
_dictBindBndrs dbs = foldrBag ((++) . bindersOf . fst) [] dbs _dictBindBndrs dbs = foldr ((++) . bindersOf . fst) [] dbs
-- | Construct a 'DictBind' from a 'CoreBind' -- | Construct a 'DictBind' from a 'CoreBind'
mkDB :: CoreBind -> DictBind mkDB :: CoreBind -> DictBind
...@@ -2389,7 +2389,7 @@ recWithDumpedDicts :: [(Id,CoreExpr)] -> Bag DictBind ->DictBind ...@@ -2389,7 +2389,7 @@ recWithDumpedDicts :: [(Id,CoreExpr)] -> Bag DictBind ->DictBind
recWithDumpedDicts pairs dbs recWithDumpedDicts pairs dbs
= (Rec bindings, fvs) = (Rec bindings, fvs)
where where
(bindings, fvs) = foldrBag add (bindings, fvs) = foldr add
([], emptyVarSet) ([], emptyVarSet)
(dbs `snocBag` mkDB (Rec pairs)) (dbs `snocBag` mkDB (Rec pairs))
add (NonRec b r, fvs') (pairs, fvs) = add (NonRec b r, fvs') (pairs, fvs) =
...@@ -2413,13 +2413,13 @@ snocDictBind uds bind = uds { ud_binds = ud_binds uds `snocBag` bind } ...@@ -2413,13 +2413,13 @@ snocDictBind uds bind = uds { ud_binds = ud_binds uds `snocBag` bind }
wrapDictBinds :: Bag DictBind -> [CoreBind] -> [CoreBind] wrapDictBinds :: Bag DictBind -> [CoreBind] -> [CoreBind]
wrapDictBinds dbs binds wrapDictBinds dbs binds
= foldrBag add binds dbs = foldr add binds dbs
where where
add (bind,_) binds = bind : binds add (bind,_) binds = bind : binds
wrapDictBindsE :: Bag DictBind -> CoreExpr -> CoreExpr wrapDictBindsE :: Bag DictBind -> CoreExpr -> CoreExpr
wrapDictBindsE dbs expr wrapDictBindsE dbs expr
= foldrBag add expr dbs = foldr add expr dbs
where where
add (bind,_) expr = Let bind expr add (bind,_) expr = Let bind expr
...@@ -2478,7 +2478,7 @@ filterCalls :: CallInfoSet -> Bag DictBind -> [CallInfo] ...@@ -2478,7 +2478,7 @@ filterCalls :: CallInfoSet -> Bag DictBind -> [CallInfo]
filterCalls (CIS fn call_bag) dbs filterCalls (CIS fn call_bag) dbs
= filter ok_call (bagToList call_bag) = filter ok_call (bagToList call_bag)
where where
dump_set = foldlBag go (unitVarSet fn) dbs dump_set = foldl' go (unitVarSet fn) dbs
-- This dump-set could also be computed by splitDictBinds -- This dump-set could also be computed by splitDictBinds
-- (_,_,dump_set) = splitDictBinds dbs {fn} -- (_,_,dump_set) = splitDictBinds dbs {fn}
-- But this variant is shorter -- But this variant is shorter
...@@ -2498,8 +2498,8 @@ splitDictBinds :: Bag DictBind -> IdSet -> (Bag DictBind, Bag DictBind, IdSet) ...@@ -2498,8 +2498,8 @@ splitDictBinds :: Bag DictBind -> IdSet -> (Bag DictBind, Bag DictBind, IdSet)
-- * free_dbs does not depend on bndrs -- * free_dbs does not depend on bndrs
-- * dump_set = bndrs `union` bndrs(dump_dbs) -- * dump_set = bndrs `union` bndrs(dump_dbs)
splitDictBinds dbs bndr_set splitDictBinds dbs bndr_set
= foldlBag split_db (emptyBag, emptyBag, bndr_set) dbs = foldl' split_db (emptyBag, emptyBag, bndr_set) dbs
-- Important that it's foldl not foldr; -- Important that it's foldl' not foldr;
-- we're accumulating the set of dumped ids in dump_set -- we're accumulating the set of dumped ids in dump_set
where where
split_db (free_dbs, dump_dbs, dump_idset) db@(bind, fvs) split_db (free_dbs, dump_dbs, dump_idset) db@(bind, fvs)
......
...@@ -369,7 +369,7 @@ findMethodBind :: Name -- Selector ...@@ -369,7 +369,7 @@ findMethodBind :: Name -- Selector
-- site of the method binder, and any inline or -- site of the method binder, and any inline or
-- specialisation pragmas -- specialisation pragmas
findMethodBind sel_name binds prag_fn findMethodBind sel_name binds prag_fn
= foldlBag mplus Nothing (mapBag f binds) = foldl' mplus Nothing (mapBag f binds)
where where
prags = lookupPragEnv prag_fn sel_name prags = lookupPragEnv prag_fn sel_name
......
...@@ -29,6 +29,7 @@ import Util ...@@ -29,6 +29,7 @@ import Util
import Bag import Bag
import Control.Monad import Control.Monad
import MonadUtils ( zipWith3M ) import MonadUtils ( zipWith3M )
import Data.Foldable ( foldrM )
import Control.Arrow ( first ) import Control.Arrow ( first )
...@@ -1690,11 +1691,11 @@ unflattenWanteds tv_eqs funeqs ...@@ -1690,11 +1691,11 @@ unflattenWanteds tv_eqs funeqs
-- ==> (flatten) [W] F alpha ~ fmv, [W] alpha ~ [fmv] -- ==> (flatten) [W] F alpha ~ fmv, [W] alpha ~ [fmv]
-- ==> (unify) [W] F [fmv] ~ fmv -- ==> (unify) [W] F [fmv] ~ fmv
-- See Note [Unflatten using funeqs first] -- See Note [Unflatten using funeqs first]
; funeqs <- foldrBagM unflatten_funeq emptyCts funeqs ; funeqs <- foldrM unflatten_funeq emptyCts funeqs
; traceTcS "Unflattening 1" $ braces (pprCts funeqs) ; traceTcS "Unflattening 1" $ braces (pprCts funeqs)
-- Step 2: unify the tv_eqs, if possible -- Step 2: unify the tv_eqs, if possible
; tv_eqs <- foldrBagM (unflatten_eq tclvl) emptyCts tv_eqs ; tv_eqs <- foldrM (unflatten_eq tclvl) emptyCts tv_eqs
; traceTcS "Unflattening 2" $ braces (pprCts tv_eqs) ; traceTcS "Unflattening 2" $ braces (pprCts tv_eqs)
-- Step 3: fill any remaining fmvs with fresh unification variables -- Step 3: fill any remaining fmvs with fresh unification variables
...@@ -1702,7 +1703,7 @@ unflattenWanteds tv_eqs funeqs ...@@ -1702,7 +1703,7 @@ unflattenWanteds tv_eqs funeqs
; traceTcS "Unflattening 3" $ braces (pprCts funeqs) ; traceTcS "Unflattening 3" $ braces (pprCts funeqs)
-- Step 4: remove any tv_eqs that look like ty ~ ty -- Step 4: remove any tv_eqs that look like ty ~ ty
; tv_eqs <- foldrBagM finalise_eq emptyCts tv_eqs ; tv_eqs <- foldrM finalise_eq emptyCts tv_eqs
; let all_flat = tv_eqs `andCts` funeqs ; let all_flat = tv_eqs `andCts` funeqs
; traceTcS "Unflattening done" $ braces (pprCts all_flat) ; traceTcS "Unflattening done" $ braces (pprCts all_flat)
......
...@@ -1973,11 +1973,11 @@ genAuxBinds dflags loc b = genAuxBinds' b2 where ...@@ -1973,11 +1973,11 @@ genAuxBinds dflags loc b = genAuxBinds' b2 where
splitDerivAuxBind (DerivAuxBind x) = Left x splitDerivAuxBind (DerivAuxBind x) = Left x
splitDerivAuxBind x = Right x splitDerivAuxBind x = Right x
rm_dups = foldrBag dup_check emptyBag rm_dups = foldr dup_check emptyBag
dup_check a b = if anyBag (== a) b then b else consBag a b dup_check a b = if anyBag (== a) b then b else consBag a b
genAuxBinds' :: BagDerivStuff -> SeparateBagsDerivStuff genAuxBinds' :: BagDerivStuff -> SeparateBagsDerivStuff
genAuxBinds' = foldrBag f ( mapBag (genAuxBindSpec dflags loc) (rm_dups b1) genAuxBinds' = foldr f ( mapBag (genAuxBindSpec dflags loc) (rm_dups b1)
, emptyBag ) , emptyBag )
f :: DerivStuff -> SeparateBagsDerivStuff -> SeparateBagsDerivStuff f :: DerivStuff -> SeparateBagsDerivStuff -> SeparateBagsDerivStuff
f (DerivAuxBind _) = panic "genAuxBinds'" -- We have removed these before f (DerivAuxBind _) = panic "genAuxBinds'" -- We have removed these before
......
...@@ -1677,7 +1677,7 @@ zonkEvBinds env binds ...@@ -1677,7 +1677,7 @@ zonkEvBinds env binds
; return (env1, binds') }) ; return (env1, binds') })
where where
collect_ev_bndrs :: Bag EvBind -> [EvVar] collect_ev_bndrs :: Bag EvBind -> [EvVar]
collect_ev_bndrs = foldrBag add [] collect_ev_bndrs = foldr add []
add (EvBind { eb_lhs = var }) vars = var : vars add (EvBind { eb_lhs = var }) vars = var : vars
zonkEvBind :: ZonkEnv -> EvBind -> TcM EvBind zonkEvBind :: ZonkEnv -> EvBind -> TcM EvBind
......
...@@ -223,7 +223,7 @@ solveSimples :: Cts -> TcS () ...@@ -223,7 +223,7 @@ solveSimples :: Cts -> TcS ()
solveSimples cts solveSimples cts
= {-# SCC "solveSimples" #-} = {-# SCC "solveSimples" #-}
do { updWorkListTcS (\wl -> foldrBag extendWorkListCt wl cts) do { updWorkListTcS (\wl -> foldr extendWorkListCt wl cts)
; solve_loop } ; solve_loop }
where where
solve_loop solve_loop
......
...@@ -1458,7 +1458,7 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls, ...@@ -1458,7 +1458,7 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
foe_binds foe_binds
; fo_gres = fi_gres `unionBags` foe_gres ; fo_gres = fi_gres `unionBags` foe_gres
; fo_fvs = foldrBag (\gre fvs -> fvs `addOneFV` gre_name gre) ; fo_fvs = foldr (\gre fvs -> fvs `addOneFV` gre_name gre)
emptyFVs fo_gres emptyFVs fo_gres
; sig_names = mkNameSet (collectHsValBinders hs_val_binds) ; sig_names = mkNameSet (collectHsValBinders hs_val_binds)
......
...@@ -1978,7 +1978,7 @@ tyCoVarsOfCtsList = fvVarList . tyCoFVsOfCts ...@@ -1978,7 +1978,7 @@ tyCoVarsOfCtsList = fvVarList . tyCoFVsOfCts
-- | Returns free variables of a bag of constraints as a composable FV -- | Returns free variables of a bag of constraints as a composable FV
-- computation. See Note [Deterministic FV] in FV. -- computation. See Note [Deterministic FV] in FV.
tyCoFVsOfCts :: Cts -> FV tyCoFVsOfCts :: Cts -> FV
tyCoFVsOfCts = foldrBag (unionFV . tyCoFVsOfCt) emptyFV tyCoFVsOfCts = foldr (unionFV . tyCoFVsOfCt) emptyFV
-- | Returns free variables of WantedConstraints as a non-deterministic -- | Returns free variables of WantedConstraints as a non-deterministic
-- set. See Note [Deterministic FV] in FV. -- set. See Note [Deterministic FV] in FV.
...@@ -2015,7 +2015,7 @@ tyCoFVsOfImplic (Implic { ic_skols = skols ...@@ -2015,7 +2015,7 @@ tyCoFVsOfImplic (Implic { ic_skols = skols
tyCoFVsOfWC wanted tyCoFVsOfWC wanted
tyCoFVsOfBag :: (a -> FV) -> Bag a -> FV tyCoFVsOfBag :: (a -> FV) -> Bag a -> FV
tyCoFVsOfBag tvs_of = foldrBag (unionFV . tvs_of) emptyFV tyCoFVsOfBag tvs_of = foldr (unionFV . tvs_of) emptyFV
--------------------------- ---------------------------
dropDerivedWC :: WantedConstraints -> WantedConstraints dropDerivedWC :: WantedConstraints -> WantedConstraints
...@@ -2525,7 +2525,7 @@ ppr_bag :: Outputable a => SDoc -> Bag a -> SDoc ...@@ -2525,7 +2525,7 @@ ppr_bag :: Outputable a => SDoc -> Bag a -> SDoc
ppr_bag doc bag ppr_bag doc bag
| isEmptyBag bag = empty | isEmptyBag bag = empty
| otherwise = hang (doc <+> equals) | otherwise = hang (doc <+> equals)
2 (foldrBag (($$) . ppr) empty bag) 2 (foldr (($$) . ppr) empty bag)
{- Note [Given insolubles] {- Note [Given insolubles]
~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~~~~
......
...@@ -1668,7 +1668,7 @@ kick_out_rewritable new_fr new_tv ...@@ -1668,7 +1668,7 @@ kick_out_rewritable new_fr new_tv
-- constraints, which perhaps may have become soluble after new_tv -- constraints, which perhaps may have become soluble after new_tv
-- is substituted; ditto the dictionaries, which may include (a~b) -- is substituted; ditto the dictionaries, which may include (a~b)
-- or (a~~b) constraints. -- or (a~~b) constraints.
kicked_out = foldrBag extendWorkListCt kicked_out = foldr extendWorkListCt
(emptyWorkList { wl_eqs = tv_eqs_out (emptyWorkList { wl_eqs = tv_eqs_out
, wl_funeqs = feqs_out }) , wl_funeqs = feqs_out })
((dicts_out `andCts` irs_out) ((dicts_out `andCts` irs_out)
...@@ -2054,7 +2054,7 @@ getNoGivenEqs :: TcLevel -- TcLevel of this implication ...@@ -2054,7 +2054,7 @@ getNoGivenEqs :: TcLevel -- TcLevel of this implication
getNoGivenEqs tclvl skol_tvs getNoGivenEqs tclvl skol_tvs
= do { inerts@(IC { inert_eqs = ieqs, inert_irreds = irreds }) = do { inerts@(IC { inert_eqs = ieqs, inert_irreds = irreds })
<- getInertCans <- getInertCans
; let has_given_eqs = foldrBag ((||) . ct_given_here) False irreds ; let has_given_eqs = foldr ((||) . ct_given_here) False irreds
|| anyDVarEnv eqs_given_here ieqs || anyDVarEnv eqs_given_here ieqs
insols = filterBag insolubleEqCt irreds insols = filterBag insolubleEqCt irreds
-- Specifically includes ones that originated in some -- Specifically includes ones that originated in some
...@@ -2317,7 +2317,7 @@ lookupSolvedDict (IS { inert_solved_dicts = solved }) loc cls tys ...@@ -2317,7 +2317,7 @@ lookupSolvedDict (IS { inert_solved_dicts = solved }) loc cls tys
********************************************************************* -} ********************************************************************* -}
foldIrreds :: (Ct -> b -> b) -> Cts -> b -> b foldIrreds :: (Ct -> b -> b) -> Cts -> b -> b
foldIrreds k irreds z = foldrBag k z irreds foldIrreds k irreds z = foldr k z irreds
{- ********************************************************************* {- *********************************************************************
...@@ -2467,7 +2467,7 @@ addDict m cls tys item = insertTcApp m (getUnique cls) tys item ...@@ -2467,7 +2467,7 @@ addDict m cls tys item = insertTcApp m (getUnique cls) tys item
addDictsByClass :: DictMap Ct -> Class -> Bag Ct -> DictMap Ct addDictsByClass :: DictMap Ct -> Class -> Bag Ct -> DictMap Ct
addDictsByClass m cls items addDictsByClass m cls items
= addToUDFM m cls (foldrBag add emptyTM items) = addToUDFM m cls (foldr add emptyTM items)
where where
add ct@(CDictCan { cc_tyargs = tys }) tm = insertTM tys ct tm add ct@(CDictCan { cc_tyargs = tys }) tm = insertTM tys ct tm
add ct _ = pprPanic "addDictsByClass" (ppr ct) add ct _ = pprPanic "addDictsByClass" (ppr ct)
......
...@@ -45,7 +45,6 @@ import Var ( TyVar, tyVarKind ) ...@@ -45,7 +45,6 @@ import Var ( TyVar, tyVarKind )
import Id ( Id, idName, idType, idInlinePragma, setInlinePragma, mkLocalId ) import Id ( Id, idName, idType, idInlinePragma, setInlinePragma, mkLocalId )
import PrelNames( mkUnboundName ) import PrelNames( mkUnboundName )
import BasicTypes import BasicTypes
import Bag( foldrBag )
import Module( getModule ) import Module( getModule )
import Name import Name
import NameEnv import NameEnv
...@@ -577,7 +576,7 @@ mkPragEnv sigs binds ...@@ -577,7 +576,7 @@ mkPragEnv sigs binds
-- ar_env maps a local to the arity of its definition -- ar_env maps a local to the arity of its definition
ar_env :: NameEnv Arity ar_env :: NameEnv Arity
ar_env = foldrBag lhsBindArity emptyNameEnv binds ar_env = foldr lhsBindArity emptyNameEnv binds
lhsBindArity :: LHsBind GhcRn -> NameEnv Arity -> NameEnv Arity lhsBindArity :: LHsBind GhcRn -> NameEnv Arity -> NameEnv Arity
lhsBindArity (L _ (FunBind { fun_id = id, fun_matches = ms })) env lhsBindArity (L _ (FunBind { fun_id = id, fun_matches = ms })) env
......
...@@ -1849,7 +1849,7 @@ neededEvVars implic@(Implic { ic_given = givens ...@@ -1849,7 +1849,7 @@ neededEvVars implic@(Implic { ic_given = givens
= do { ev_binds <- TcS.getTcEvBindsMap ev_binds_var = do { ev_binds <- TcS.getTcEvBindsMap ev_binds_var
; tcvs <- TcS.getTcEvTyCoVars ev_binds_var ; tcvs <- TcS.getTcEvTyCoVars ev_binds_var
; let seeds1 = foldrBag add_implic_seeds old_needs implics ; let seeds1 = foldr add_implic_seeds old_needs implics
seeds2 = foldEvBindMap add_wanted seeds1 ev_binds seeds2 = foldEvBindMap add_wanted seeds1 ev_binds
seeds3 = seeds2 `unionVarSet` tcvs seeds3 = seeds2 `unionVarSet` tcvs
need_inner = findNeededEvVars ev_binds seeds3 need_inner = findNeededEvVars ev_binds seeds3
...@@ -2127,7 +2127,7 @@ approximateWC float_past_equalities wc ...@@ -2127,7 +2127,7 @@ approximateWC float_past_equalities wc
new_trapping_tvs = trapping_tvs `extendVarSetList` ic_skols imp new_trapping_tvs = trapping_tvs `extendVarSetList` ic_skols imp
do_bag :: (a -> Bag c) -> Bag a -> Bag c do_bag :: (a -> Bag c) -> Bag a -> Bag c
do_bag f = foldrBag (unionBags.f) emptyBag do_bag f = foldr (unionBags.f) emptyBag
is_floatable skol_tvs ct is_floatable skol_tvs ct
| isGivenCt ct = False | isGivenCt ct = False
...@@ -2368,7 +2368,7 @@ floatEqualities skols given_ids ev_binds_var no_given_eqs ...@@ -2368,7 +2368,7 @@ floatEqualities skols given_ids ev_binds_var no_given_eqs
seed_skols = mkVarSet skols `unionVarSet` seed_skols = mkVarSet skols `unionVarSet`
mkVarSet given_ids `unionVarSet` mkVarSet given_ids `unionVarSet`
foldrBag add_non_flt_ct emptyVarSet no_float_cts `unionVarSet` foldr add_non_flt_ct emptyVarSet no_float_cts `unionVarSet`
foldEvBindMap add_one_bind emptyVarSet binds foldEvBindMap add_one_bind emptyVarSet binds
-- seed_skols: See Note [What prevents a constraint from floating] (1,2,3) -- seed_skols: See Note [What prevents a constraint from floating] (1,2,3)
-- Include the EvIds of any non-floating constraints -- Include the EvIds of any non-floating constraints
...@@ -2407,7 +2407,7 @@ floatEqualities skols given_ids ev_binds_var no_given_eqs ...@@ -2407,7 +2407,7 @@ floatEqualities skols given_ids ev_binds_var no_given_eqs
| otherwise = not (ctEvId ct `elemVarSet` skols) | otherwise = not (ctEvId ct `elemVarSet` skols)
add_captured_ev_ids :: Cts -> VarSet -> VarSet add_captured_ev_ids :: Cts -> VarSet -> VarSet
add_captured_ev_ids cts skols = foldrBag extra_skol emptyVarSet cts add_captured_ev_ids cts skols = foldr extra_skol emptyVarSet cts
where