From ac79dfe9cb51f38e122af9a404d50aead8a9e8b0 Mon Sep 17 00:00:00 2001 From: Richard Lupton Date: Sat, 17 Aug 2019 13:34:51 +0100 Subject: Remove Bag fold specialisations (#16969) --- compiler/coreSyn/CoreUnfold.hs | 2 +- compiler/deSugar/Coverage.hs | 2 +- compiler/deSugar/DsArrows.hs | 3 +-- compiler/deSugar/DsBinds.hs | 2 +- compiler/deSugar/DsExpr.hs | 2 +- compiler/hsSyn/HsUtils.hs | 6 +++--- compiler/nativeGen/RegAlloc/Graph/Main.hs | 4 ++-- compiler/rename/RnBinds.hs | 4 ++-- compiler/rename/RnSource.hs | 2 +- compiler/simplCore/FloatOut.hs | 4 ++-- compiler/specialise/Specialise.hs | 16 +++++++-------- compiler/typecheck/TcClassDcl.hs | 2 +- compiler/typecheck/TcFlatten.hs | 7 ++++--- compiler/typecheck/TcGenDeriv.hs | 4 ++-- compiler/typecheck/TcHsSyn.hs | 2 +- compiler/typecheck/TcInteract.hs | 2 +- compiler/typecheck/TcRnDriver.hs | 2 +- compiler/typecheck/TcRnTypes.hs | 6 +++--- compiler/typecheck/TcSMonad.hs | 8 ++++---- compiler/typecheck/TcSigs.hs | 3 +-- compiler/typecheck/TcSimplify.hs | 8 ++++---- compiler/utils/Bag.hs | 34 +++++-------------------------- 22 files changed, 50 insertions(+), 75 deletions(-) diff --git a/compiler/coreSyn/CoreUnfold.hs b/compiler/coreSyn/CoreUnfold.hs index 8a51e587ad..689ad874da 100644 --- a/compiler/coreSyn/CoreUnfold.hs +++ b/compiler/coreSyn/CoreUnfold.hs @@ -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 diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs index ce902f4970..e587c74121 100644 --- a/compiler/deSugar/Coverage.hs +++ b/compiler/deSugar/Coverage.hs @@ -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 diff --git a/compiler/deSugar/DsArrows.hs b/compiler/deSugar/DsArrows.hs index 956eb1d098..cc12920520 100644 --- a/compiler/deSugar/DsArrows.hs +++ b/compiler/deSugar/DsArrows.hs @@ -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] diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs index 96855a61b7..4a6a463b2d 100644 --- a/compiler/deSugar/DsBinds.hs +++ b/compiler/deSugar/DsBinds.hs @@ -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) diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs index 73edf8c2de..183b1e7650 100644 --- a/compiler/deSugar/DsExpr.hs +++ b/compiler/deSugar/DsExpr.hs @@ -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) } diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs index 6fd42ae18d..6823aa1553 100644 --- a/compiler/hsSyn/HsUtils.hs +++ b/compiler/hsSyn/HsUtils.hs @@ -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 diff --git a/compiler/nativeGen/RegAlloc/Graph/Main.hs b/compiler/nativeGen/RegAlloc/Graph/Main.hs index df97de1c62..e756068ca1 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Main.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Main.hs @@ -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 diff --git a/compiler/rename/RnBinds.hs b/compiler/rename/RnBinds.hs index d756272e26..5bb76f8f0d 100644 --- a/compiler/rename/RnBinds.hs +++ b/compiler/rename/RnBinds.hs @@ -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) } diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs index 8f85fac28b..79280ee43f 100644 --- a/compiler/rename/RnSource.hs +++ b/compiler/rename/RnSource.hs @@ -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 diff --git a/compiler/simplCore/FloatOut.hs b/compiler/simplCore/FloatOut.hs index 1f1dd5c4ba..015d096a0a 100644 --- a/compiler/simplCore/FloatOut.hs +++ b/compiler/simplCore/FloatOut.hs @@ -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 diff --git a/compiler/specialise/Specialise.hs b/compiler/specialise/Specialise.hs index 3434172de2..e49a40dc0d 100644 --- a/compiler/specialise/Specialise.hs +++ b/compiler/specialise/Specialise.hs @@ -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) diff --git a/compiler/typecheck/TcClassDcl.hs b/compiler/typecheck/TcClassDcl.hs index f4d89e517e..0239793a51 100644 --- a/compiler/typecheck/TcClassDcl.hs +++ b/compiler/typecheck/TcClassDcl.hs @@ -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 diff --git a/compiler/typecheck/TcFlatten.hs b/compiler/typecheck/TcFlatten.hs index 2bb3d1c0e8..946392f2d9 100644 --- a/compiler/typecheck/TcFlatten.hs +++ b/compiler/typecheck/TcFlatten.hs @@ -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) diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs index 2ed1483fab..4a7032cedf 100644 --- a/compiler/typecheck/TcGenDeriv.hs +++ b/compiler/typecheck/TcGenDeriv.hs @@ -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 diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs index 7dbd4d9fee..d80505ea63 100644 --- a/compiler/typecheck/TcHsSyn.hs +++ b/compiler/typecheck/TcHsSyn.hs @@ -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 diff --git a/compiler/typecheck/TcInteract.hs b/compiler/typecheck/TcInteract.hs index 3a80d5a62c..f6a4f92164 100644 --- a/compiler/typecheck/TcInteract.hs +++ b/compiler/typecheck/TcInteract.hs @@ -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 diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs index ca4f98b98c..151a7cbf83 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -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) diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs index 45fbfd9f95..5d56d33d53 100644 --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs @@ -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] ~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs index 68496dfca6..0d15d26180 100644 --- a/compiler/typecheck/TcSMonad.hs +++ b/compiler/typecheck/TcSMonad.hs @@ -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) diff --git a/compiler/typecheck/TcSigs.hs b/compiler/typecheck/TcSigs.hs index a8a3e0dd47..2ddca2805f 100644 --- a/compiler/typecheck/TcSigs.hs +++ b/compiler/typecheck/TcSigs.hs @@ -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 diff --git a/compiler/typecheck/TcSimplify.hs b/compiler/typecheck/TcSimplify.hs index 5a7924017d..48c7305669 100644 --- a/compiler/typecheck/TcSimplify.hs +++ b/compiler/typecheck/TcSimplify.hs @@ -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 diff --git a/compiler/utils/Bag.hs b/compiler/utils/Bag.hs index db9caa9722..be46640920 100644 --- a/compiler/utils/Bag.hs +++ b/compiler/utils/Bag.hs @@ -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)) -- cgit v1.2.1