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
n_val_bndrs = length val_bndrs
mk_discount :: Bag (Id,Int) -> Id -> Int
mk_discount cbs bndr = foldlBag combine 0 cbs
mk_discount cbs bndr = foldl' combine 0 cbs
where
combine acc (bndr', disc)
| bndr == bndr' = acc `plus_disc` disc
......
......@@ -121,7 +121,7 @@ guessSourceFile :: LHsBinds GhcTc -> FilePath -> FilePath
guessSourceFile binds orig_file =
-- Try look for a file generated from a .hsc file to a
-- .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
in
case top_pos of
......
......@@ -50,7 +50,6 @@ import TysWiredIn
import BasicTypes
import PrelNames
import Outputable
import Bag
import VarSet
import SrcLoc
import ListSetOps( assocMaybe )
......@@ -1251,7 +1250,7 @@ collectl (dL->L _ pat) bndrs
go p@(XPat {}) = pprPanic "collectl/go" (ppr p)
collectEvBinders :: TcEvBinds -> [Id]
collectEvBinders (EvBinds bs) = foldrBag add_ev_bndr [] bs
collectEvBinders (EvBinds bs) = foldr add_ev_bndr [] bs
collectEvBinders (TcEvBinds {}) = panic "ToDo: collectEvBinders"
add_ev_bndr :: EvBind -> [Id] -> [Id]
......
......@@ -1164,7 +1164,7 @@ mk_ev_binds ds_binds
= map ds_scc (stronglyConnCompFromEdgedVerticesUniq edges)
where
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 b@(var, rhs)
......
......@@ -187,7 +187,7 @@ dsUnliftedBind (AbsBinds { abs_tvs = [], abs_ev_vars = []
, abs_binds = lbinds }) body
= do { let body1 = foldr bind_export body exports
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
; ds_binds <- dsTcEvBinds_s ev_binds
; return (mkCoreLets ds_binds body2) }
......
......@@ -1000,7 +1000,7 @@ collect_out_binds ps = foldr (collect_binds ps . snd) []
collect_binds :: Bool -> LHsBindsLR (GhcPass p) idR ->
[IdP (GhcPass p)] -> [IdP (GhcPass p)]
-- 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)) =>
Bool -> HsBindLR p idR -> [IdP p] -> [IdP p]
......@@ -1019,7 +1019,7 @@ collect_bind _ (XHsBindsLR _) acc = acc
collectMethodBinders :: LHsBindsLR idL idR -> [Located (IdP idL)]
-- 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
get (FunBind { fun_id = f }) fs = f : fs
get _ fs = fs
......@@ -1201,7 +1201,7 @@ hsPatSynSelectors :: HsValBinds (GhcPass p) -> [IdP (GhcPass p)]
-- names are collected by collectHsValBinders.
hsPatSynSelectors (ValBinds _ _ _) = panic "hsPatSynSelectors"
hsPatSynSelectors (XValBindsLR (NValBinds binds _))
= foldrBag addPatSynSelector [] . unionManyBags $ map snd binds
= foldr addPatSynSelector [] . unionManyBags $ map snd binds
addPatSynSelector:: LHsBind p -> [IdP p] -> [IdP p]
addPatSynSelector bind sels
......
......@@ -310,7 +310,7 @@ buildGraph code
-- Add the reg-reg conflicts to the graph.
let conflictBag = unionManyBags conflictList
let graph_conflict
= foldrBag graphAddConflictSet Color.initGraph conflictBag
= foldr graphAddConflictSet Color.initGraph conflictBag
-- Add the coalescences edges to the graph.
let moveBag
......@@ -318,7 +318,7 @@ buildGraph code
(unionManyBags moveList)
let graph_coalesce
= foldrBag graphAddCoalesce graph_conflict moveBag
= foldr graphAddCoalesce graph_conflict moveBag
return graph_coalesce
......
......@@ -853,7 +853,7 @@ rnMethodBinds is_cls_decl cls ktv_names binds sigs
-- for instance decls too
-- 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
-- Annoyingly the type variables /are/ in scope for signatures, but
......@@ -875,7 +875,7 @@ rnMethodBinds is_cls_decl cls ktv_names binds sigs
; scoped_tvs <- xoptM LangExt.ScopedTypeVariables
; (binds'', bind_fvs) <- maybe_extend_tyvar_env scoped_tvs $
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
; return (mapBag fstOf3 binds_w_dus, bind_fvs) }
......
......@@ -2135,7 +2135,7 @@ extendPatSynEnv val_decls local_fix_env thing = do {
; setEnvs (final_gbl_env, lcl_env) (thing pat_syn_bndrs) }
where
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' :: LHsBindLR GhcPs GhcPs
......
......@@ -629,7 +629,7 @@ flattenTopFloats (FB tops ceils defs)
addTopFloatPairs :: Bag CoreBind -> [(Id,CoreExpr)] -> [(Id,CoreExpr)]
addTopFloatPairs float_bag prs
= foldrBag add prs float_bag
= foldr add prs float_bag
where
add (NonRec b r) prs = (b,r):prs
add (Rec prs1) prs2 = prs1 ++ prs2
......@@ -673,7 +673,7 @@ plusMinor = M.unionWith unionBags
install :: Bag FloatBind -> CoreExpr -> CoreExpr
install defn_groups expr
= foldrBag wrapFloat expr defn_groups
= foldr wrapFloat expr defn_groups
partitionByLevel
:: Level -- Partitioning level
......
......@@ -2181,7 +2181,7 @@ callDetailsFVs calls =
callInfoFVs :: CallInfoSet -> VarSet
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 = length . filter isValueArg . dropWhileEndLE isUnspecArg
......@@ -2350,7 +2350,7 @@ plusUDs (MkUD {ud_binds = db1, ud_calls = calls1})
-----------------------------
_dictBindBndrs :: Bag DictBind -> [Id]
_dictBindBndrs dbs = foldrBag ((++) . bindersOf . fst) [] dbs
_dictBindBndrs dbs = foldr ((++) . bindersOf . fst) [] dbs
-- | Construct a 'DictBind' from a 'CoreBind'
mkDB :: CoreBind -> DictBind
......@@ -2389,7 +2389,7 @@ recWithDumpedDicts :: [(Id,CoreExpr)] -> Bag DictBind ->DictBind
recWithDumpedDicts pairs dbs
= (Rec bindings, fvs)
where
(bindings, fvs) = foldrBag add
(bindings, fvs) = foldr add
([], emptyVarSet)
(dbs `snocBag` mkDB (Rec pairs))
add (NonRec b r, fvs') (pairs, fvs) =
......@@ -2413,13 +2413,13 @@ snocDictBind uds bind = uds { ud_binds = ud_binds uds `snocBag` bind }
wrapDictBinds :: Bag DictBind -> [CoreBind] -> [CoreBind]
wrapDictBinds dbs binds
= foldrBag add binds dbs
= foldr add binds dbs
where
add (bind,_) binds = bind : binds
wrapDictBindsE :: Bag DictBind -> CoreExpr -> CoreExpr
wrapDictBindsE dbs expr
= foldrBag add expr dbs
= foldr add expr dbs
where
add (bind,_) expr = Let bind expr
......@@ -2478,7 +2478,7 @@ filterCalls :: CallInfoSet -> Bag DictBind -> [CallInfo]
filterCalls (CIS fn call_bag) dbs
= filter ok_call (bagToList call_bag)
where
dump_set = foldlBag go (unitVarSet fn) dbs
dump_set = foldl' go (unitVarSet fn) dbs
-- This dump-set could also be computed by splitDictBinds
-- (_,_,dump_set) = splitDictBinds dbs {fn}
-- But this variant is shorter
......@@ -2498,8 +2498,8 @@ splitDictBinds :: Bag DictBind -> IdSet -> (Bag DictBind, Bag DictBind, IdSet)
-- * free_dbs does not depend on bndrs
-- * dump_set = bndrs `union` bndrs(dump_dbs)
splitDictBinds dbs bndr_set
= foldlBag split_db (emptyBag, emptyBag, bndr_set) dbs
-- Important that it's foldl not foldr;
= foldl' split_db (emptyBag, emptyBag, bndr_set) dbs
-- Important that it's foldl' not foldr;
-- we're accumulating the set of dumped ids in dump_set
where
split_db (free_dbs, dump_dbs, dump_idset) db@(bind, fvs)
......
......@@ -369,7 +369,7 @@ findMethodBind :: Name -- Selector
-- site of the method binder, and any inline or
-- specialisation pragmas
findMethodBind sel_name binds prag_fn
= foldlBag mplus Nothing (mapBag f binds)
= foldl' mplus Nothing (mapBag f binds)
where
prags = lookupPragEnv prag_fn sel_name
......
......@@ -29,6 +29,7 @@ import Util
import Bag
import Control.Monad
import MonadUtils ( zipWith3M )
import Data.Foldable ( foldrM )
import Control.Arrow ( first )
......@@ -1690,11 +1691,11 @@ unflattenWanteds tv_eqs funeqs
-- ==> (flatten) [W] F alpha ~ fmv, [W] alpha ~ [fmv]
-- ==> (unify) [W] F [fmv] ~ fmv
-- See Note [Unflatten using funeqs first]
; funeqs <- foldrBagM unflatten_funeq emptyCts funeqs
; funeqs <- foldrM unflatten_funeq emptyCts funeqs
; traceTcS "Unflattening 1" $ braces (pprCts funeqs)
-- 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)
-- Step 3: fill any remaining fmvs with fresh unification variables
......@@ -1702,7 +1703,7 @@ unflattenWanteds tv_eqs funeqs
; traceTcS "Unflattening 3" $ braces (pprCts funeqs)
-- 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
; traceTcS "Unflattening done" $ braces (pprCts all_flat)
......
......@@ -1973,11 +1973,11 @@ genAuxBinds dflags loc b = genAuxBinds' b2 where
splitDerivAuxBind (DerivAuxBind x) = Left 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
genAuxBinds' :: BagDerivStuff -> SeparateBagsDerivStuff
genAuxBinds' = foldrBag f ( mapBag (genAuxBindSpec dflags loc) (rm_dups b1)
genAuxBinds' = foldr f ( mapBag (genAuxBindSpec dflags loc) (rm_dups b1)
, emptyBag )
f :: DerivStuff -> SeparateBagsDerivStuff -> SeparateBagsDerivStuff
f (DerivAuxBind _) = panic "genAuxBinds'" -- We have removed these before
......
......@@ -1677,7 +1677,7 @@ zonkEvBinds env binds
; return (env1, binds') })
where
collect_ev_bndrs :: Bag EvBind -> [EvVar]
collect_ev_bndrs = foldrBag add []
collect_ev_bndrs = foldr add []
add (EvBind { eb_lhs = var }) vars = var : vars
zonkEvBind :: ZonkEnv -> EvBind -> TcM EvBind
......
......@@ -223,7 +223,7 @@ solveSimples :: Cts -> TcS ()
solveSimples cts
= {-# SCC "solveSimples" #-}
do { updWorkListTcS (\wl -> foldrBag extendWorkListCt wl cts)
do { updWorkListTcS (\wl -> foldr extendWorkListCt wl cts)
; solve_loop }
where
solve_loop
......
......@@ -1458,7 +1458,7 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
foe_binds
; 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
; sig_names = mkNameSet (collectHsValBinders hs_val_binds)
......
......@@ -1978,7 +1978,7 @@ tyCoVarsOfCtsList = fvVarList . tyCoFVsOfCts
-- | Returns free variables of a bag of constraints as a composable FV
-- computation. See Note [Deterministic FV] in FV.
tyCoFVsOfCts :: Cts -> FV
tyCoFVsOfCts = foldrBag (unionFV . tyCoFVsOfCt) emptyFV
tyCoFVsOfCts = foldr (unionFV . tyCoFVsOfCt) emptyFV
-- | Returns free variables of WantedConstraints as a non-deterministic
-- set. See Note [Deterministic FV] in FV.
......@@ -2015,7 +2015,7 @@ tyCoFVsOfImplic (Implic { ic_skols = skols
tyCoFVsOfWC wanted
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
......@@ -2525,7 +2525,7 @@ ppr_bag :: Outputable a => SDoc -> Bag a -> SDoc
ppr_bag doc bag
| isEmptyBag bag = empty
| otherwise = hang (doc <+> equals)
2 (foldrBag (($$) . ppr) empty bag)
2 (foldr (($$) . ppr) empty bag)
{- Note [Given insolubles]
~~~~~~~~~~~~~~~~~~~~~~~~~~
......
......@@ -1668,7 +1668,7 @@ kick_out_rewritable new_fr new_tv
-- constraints, which perhaps may have become soluble after new_tv
-- is substituted; ditto the dictionaries, which may include (a~b)
-- or (a~~b) constraints.
kicked_out = foldrBag extendWorkListCt
kicked_out = foldr extendWorkListCt
(emptyWorkList { wl_eqs = tv_eqs_out
, wl_funeqs = feqs_out })
((dicts_out `andCts` irs_out)
......@@ -2054,7 +2054,7 @@ getNoGivenEqs :: TcLevel -- TcLevel of this implication
getNoGivenEqs tclvl skol_tvs
= do { inerts@(IC { inert_eqs = ieqs, inert_irreds = irreds })
<- 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
insols = filterBag insolubleEqCt irreds
-- Specifically includes ones that originated in some
......@@ -2317,7 +2317,7 @@ lookupSolvedDict (IS { inert_solved_dicts = solved }) loc cls tys
********************************************************************* -}
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
addDictsByClass :: DictMap Ct -> Class -> Bag Ct -> DictMap Ct
addDictsByClass m cls items
= addToUDFM m cls (foldrBag add emptyTM items)
= addToUDFM m cls (foldr add emptyTM items)
where
add ct@(CDictCan { cc_tyargs = tys }) tm = insertTM tys ct tm
add ct _ = pprPanic "addDictsByClass" (ppr ct)
......
......@@ -45,7 +45,6 @@ import Var ( TyVar, tyVarKind )
import Id ( Id, idName, idType, idInlinePragma, setInlinePragma, mkLocalId )
import PrelNames( mkUnboundName )
import BasicTypes
import Bag( foldrBag )
import Module( getModule )
import Name
import NameEnv
......@@ -577,7 +576,7 @@ mkPragEnv sigs binds
-- ar_env maps a local to the arity of its definition
ar_env :: NameEnv Arity
ar_env = foldrBag lhsBindArity emptyNameEnv binds
ar_env = foldr lhsBindArity emptyNameEnv binds
lhsBindArity :: LHsBind GhcRn -> NameEnv Arity -> NameEnv Arity
lhsBindArity (L _ (FunBind { fun_id = id, fun_matches = ms })) env
......
......@@ -1849,7 +1849,7 @@ neededEvVars implic@(Implic { ic_given = givens
= do { ev_binds <- TcS.getTcEvBindsMap 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
seeds3 = seeds2 `unionVarSet` tcvs
need_inner = findNeededEvVars ev_binds seeds3
......@@ -2127,7 +2127,7 @@ approximateWC float_past_equalities wc
new_trapping_tvs = trapping_tvs `extendVarSetList` ic_skols imp
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
| isGivenCt ct = False
......@@ -2368,7 +2368,7 @@ floatEqualities skols given_ids ev_binds_var no_given_eqs
seed_skols = mkVarSet skols `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
-- seed_skols: See Note [What prevents a constraint from floating] (1,2,3)
-- Include the EvIds of any non-floating constraints
......@@ -2407,7 +2407,7 @@ floatEqualities skols given_ids ev_binds_var no_given_eqs
| otherwise = not (ctEvId ct `elemVarSet` skols)
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
extra_skol ct acc
| isDerivedCt ct = acc
......
......@@ -15,11 +15,11 @@ module Bag (
mapBag,
elemBag, lengthBag,
filterBag, partitionBag, partitionBagWith,
concatBag, catBagMaybes, foldBag, foldrBag, foldlBag,
concatBag, catBagMaybes, foldBag,
isEmptyBag, isSingletonBag, consBag, snocBag, anyBag, allBag,
listToBag, bagToList, mapAccumBagL,
concatMapBag, concatMapBagPair, mapMaybeBag,
foldrBagM, foldlBagM, mapBagM, mapBagM_,
mapBagM, mapBagM_,
flatMapBagM, flatMapBagPairM,
mapAndUnzipBagM, mapAccumBagLM,
anyBagM, filterBagM
......@@ -134,12 +134,12 @@ anyBagM p (TwoBags b1 b2) = do flag <- anyBagM p b1
anyBagM p (ListBag xs) = anyM p xs
concatBag :: Bag (Bag a) -> Bag a
concatBag bss = foldrBag add emptyBag bss
concatBag bss = foldr add emptyBag bss
where
add bs rs = bs `unionBags` rs
catBagMaybes :: Bag (Maybe a) -> Bag a
catBagMaybes bs = foldrBag add emptyBag bs
catBagMaybes bs = foldr add emptyBag bs
where
add Nothing rs = rs
add (Just x) rs = x `consBag` rs
......@@ -191,30 +191,6 @@ foldBag t u e (UnitBag x) = u x `t` e
foldBag t u e (TwoBags b1 b2) = foldBag t u (foldBag t u e b2) b1
foldBag t u e (ListBag xs) = foldr (t.u) e xs
foldrBag :: (a -> r -> r) -> r
-> Bag a
-> r
-- Maintained for backward compatibility - now just a specialisation of
-- Foldable.
foldrBag = Foldable.foldr
foldlBag :: (r -> a -> r) -> r
-> Bag a
-> r
-- Maintained for backward compatibility - now just a specialisation of
-- Foldable.
foldlBag = Foldable.foldl
foldrBagM :: (Monad m) => (a -> b -> m b) -> b -> Bag a -> m b
-- Maintained for backward compatibility - now just a specialisation of
-- Foldable.
foldrBagM = Foldable.foldrM
foldlBagM :: (Monad m) => (b -> a -> m b) -> b -> Bag a -> m b
-- Maintained for backward compatibility - now just a specialisation of
-- Foldable.
foldlBagM = Foldable.foldlM
mapBag :: (a -> b) -> Bag a -> Bag b
mapBag = fmap
......@@ -324,7 +300,7 @@ listToBag [x] = UnitBag x
listToBag vs = ListBag vs
bagToList :: Bag a -> [a]
bagToList b = foldrBag (:) [] b
bagToList b = foldr (:) [] b
instance (Outputable a) => Outputable (Bag a) where
ppr bag = braces (pprWithCommas ppr (bagToList bag))
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment