Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
GHC
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Locked Files
Issues
0
Issues
0
List
Boards
Labels
Service Desk
Milestones
Iterations
Merge Requests
0
Merge Requests
0
Requirements
Requirements
List
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Security & Compliance
Security & Compliance
Dependency List
License Compliance
Operations
Operations
Incidents
Environments
Packages & Registries
Packages & Registries
Package Registry
Container Registry
Analytics
Analytics
CI / CD
Code Review
Insights
Issue
Repository
Value Stream
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
Alex D
GHC
Commits
ac79dfe9
Commit
ac79dfe9
authored
Aug 17, 2019
by
Richard Lupton
Committed by
Marge Bot
Aug 19, 2019
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Remove Bag fold specialisations (#16969)
parent
2a394246
Changes
22
Hide whitespace changes
Inline
Side-by-side
Showing
22 changed files
with
50 additions
and
75 deletions
+50
-75
compiler/coreSyn/CoreUnfold.hs
compiler/coreSyn/CoreUnfold.hs
+1
-1
compiler/deSugar/Coverage.hs
compiler/deSugar/Coverage.hs
+1
-1
compiler/deSugar/DsArrows.hs
compiler/deSugar/DsArrows.hs
+1
-2
compiler/deSugar/DsBinds.hs
compiler/deSugar/DsBinds.hs
+1
-1
compiler/deSugar/DsExpr.hs
compiler/deSugar/DsExpr.hs
+1
-1
compiler/hsSyn/HsUtils.hs
compiler/hsSyn/HsUtils.hs
+3
-3
compiler/nativeGen/RegAlloc/Graph/Main.hs
compiler/nativeGen/RegAlloc/Graph/Main.hs
+2
-2
compiler/rename/RnBinds.hs
compiler/rename/RnBinds.hs
+2
-2
compiler/rename/RnSource.hs
compiler/rename/RnSource.hs
+1
-1
compiler/simplCore/FloatOut.hs
compiler/simplCore/FloatOut.hs
+2
-2
compiler/specialise/Specialise.hs
compiler/specialise/Specialise.hs
+8
-8
compiler/typecheck/TcClassDcl.hs
compiler/typecheck/TcClassDcl.hs
+1
-1
compiler/typecheck/TcFlatten.hs
compiler/typecheck/TcFlatten.hs
+4
-3
compiler/typecheck/TcGenDeriv.hs
compiler/typecheck/TcGenDeriv.hs
+2
-2
compiler/typecheck/TcHsSyn.hs
compiler/typecheck/TcHsSyn.hs
+1
-1
compiler/typecheck/TcInteract.hs
compiler/typecheck/TcInteract.hs
+1
-1
compiler/typecheck/TcRnDriver.hs
compiler/typecheck/TcRnDriver.hs
+1
-1
compiler/typecheck/TcRnTypes.hs
compiler/typecheck/TcRnTypes.hs
+3
-3
compiler/typecheck/TcSMonad.hs
compiler/typecheck/TcSMonad.hs
+4
-4
compiler/typecheck/TcSigs.hs
compiler/typecheck/TcSigs.hs
+1
-2
compiler/typecheck/TcSimplify.hs
compiler/typecheck/TcSimplify.hs
+4
-4
compiler/utils/Bag.hs
compiler/utils/Bag.hs
+5
-29
No files found.
compiler/coreSyn/CoreUnfold.hs
View file @
ac79dfe9
...
...
@@ -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
=
foldl
Bag
combine
0
cbs
mk_discount
cbs
bndr
=
foldl
'
combine
0
cbs
where
combine
acc
(
bndr'
,
disc
)
|
bndr
==
bndr'
=
acc
`
plus_disc
`
disc
...
...
compiler/deSugar/Coverage.hs
View file @
ac79dfe9
...
...
@@ -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
$
foldr
Bag
(
\
(
dL
->
L
pos
_
)
rest
->
let
top_pos
=
catMaybes
$
foldr
(
\
(
dL
->
L
pos
_
)
rest
->
srcSpanFileName_maybe
pos
:
rest
)
[]
binds
in
case
top_pos
of
...
...
compiler/deSugar/DsArrows.hs
View file @
ac79dfe9
...
...
@@ -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
)
=
foldr
Bag
add_ev_bndr
[]
bs
collectEvBinders
(
EvBinds
bs
)
=
foldr
add_ev_bndr
[]
bs
collectEvBinders
(
TcEvBinds
{})
=
panic
"ToDo: collectEvBinders"
add_ev_bndr
::
EvBind
->
[
Id
]
->
[
Id
]
...
...
compiler/deSugar/DsBinds.hs
View file @
ac79dfe9
...
...
@@ -1164,7 +1164,7 @@ mk_ev_binds ds_binds
=
map
ds_scc
(
stronglyConnCompFromEdgedVerticesUniq
edges
)
where
edges
::
[
Node
EvVar
(
EvVar
,
CoreExpr
)
]
edges
=
foldr
Bag
((
:
)
.
mk_node
)
[]
ds_binds
edges
=
foldr
((
:
)
.
mk_node
)
[]
ds_binds
mk_node
::
(
Id
,
CoreExpr
)
->
Node
EvVar
(
EvVar
,
CoreExpr
)
mk_node
b
@
(
var
,
rhs
)
...
...
compiler/deSugar/DsExpr.hs
View file @
ac79dfe9
...
...
@@ -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
<-
foldl
Bag
M
(
\
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
)
}
...
...
compiler/hsSyn/HsUtils.hs
View file @
ac79dfe9
...
...
@@ -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
=
foldr
Bag
(
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
=
foldr
Bag
(
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
_
))
=
foldr
Bag
addPatSynSelector
[]
.
unionManyBags
$
map
snd
binds
=
foldr
addPatSynSelector
[]
.
unionManyBags
$
map
snd
binds
addPatSynSelector
::
LHsBind
p
->
[
IdP
p
]
->
[
IdP
p
]
addPatSynSelector
bind
sels
...
...
compiler/nativeGen/RegAlloc/Graph/Main.hs
View file @
ac79dfe9
...
...
@@ -310,7 +310,7 @@ buildGraph code
-- Add the reg-reg conflicts to the graph.
let
conflictBag
=
unionManyBags
conflictList
let
graph_conflict
=
foldr
Bag
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
=
foldr
Bag
graphAddCoalesce
graph_conflict
moveBag
=
foldr
graphAddCoalesce
graph_conflict
moveBag
return
graph_coalesce
...
...
compiler/rename/RnBinds.hs
View file @
ac79dfe9
...
...
@@ -853,7 +853,7 @@ rnMethodBinds is_cls_decl cls ktv_names binds sigs
-- for instance decls too
-- Rename the bindings LHSs
;
binds'
<-
foldr
Bag
M
(
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
=
foldr
Bag
(
\
(
_
,
_
,
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
)
}
...
...
compiler/rename/RnSource.hs
View file @
ac79dfe9
...
...
@@ -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
_
)
=
foldr
Bag
M
new_ps'
[]
binds
new_ps
(
ValBinds
_
binds
_
)
=
foldrM
new_ps'
[]
binds
new_ps
_
=
panic
"new_ps"
new_ps'
::
LHsBindLR
GhcPs
GhcPs
...
...
compiler/simplCore/FloatOut.hs
View file @
ac79dfe9
...
...
@@ -629,7 +629,7 @@ flattenTopFloats (FB tops ceils defs)
addTopFloatPairs
::
Bag
CoreBind
->
[(
Id
,
CoreExpr
)]
->
[(
Id
,
CoreExpr
)]
addTopFloatPairs
float_bag
prs
=
foldr
Bag
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
=
foldr
Bag
wrapFloat
expr
defn_groups
=
foldr
wrapFloat
expr
defn_groups
partitionByLevel
::
Level
-- Partitioning level
...
...
compiler/specialise/Specialise.hs
View file @
ac79dfe9
...
...
@@ -2181,7 +2181,7 @@ callDetailsFVs calls =
callInfoFVs
::
CallInfoSet
->
VarSet
callInfoFVs
(
CIS
_
call_info
)
=
foldr
Bag
(
\
(
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
=
foldr
Bag
((
++
)
.
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
)
=
foldr
Bag
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
=
foldr
Bag
add
binds
dbs
=
foldr
add
binds
dbs
where
add
(
bind
,
_
)
binds
=
bind
:
binds
wrapDictBindsE
::
Bag
DictBind
->
CoreExpr
->
CoreExpr
wrapDictBindsE
dbs
expr
=
foldr
Bag
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
=
foldl
Bag
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
=
foldl
Bag
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
)
...
...
compiler/typecheck/TcClassDcl.hs
View file @
ac79dfe9
...
...
@@ -369,7 +369,7 @@ findMethodBind :: Name -- Selector
-- site of the method binder, and any inline or
-- specialisation pragmas
findMethodBind
sel_name
binds
prag_fn
=
foldl
Bag
mplus
Nothing
(
mapBag
f
binds
)
=
foldl
'
mplus
Nothing
(
mapBag
f
binds
)
where
prags
=
lookupPragEnv
prag_fn
sel_name
...
...
compiler/typecheck/TcFlatten.hs
View file @
ac79dfe9
...
...
@@ -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
<-
foldr
Bag
M
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
<-
foldr
Bag
M
(
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
<-
foldr
Bag
M
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
)
...
...
compiler/typecheck/TcGenDeriv.hs
View file @
ac79dfe9
...
...
@@ -1973,11 +1973,11 @@ genAuxBinds dflags loc b = genAuxBinds' b2 where
splitDerivAuxBind
(
DerivAuxBind
x
)
=
Left
x
splitDerivAuxBind
x
=
Right
x
rm_dups
=
foldr
Bag
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'
=
foldr
Bag
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
...
...
compiler/typecheck/TcHsSyn.hs
View file @
ac79dfe9
...
...
@@ -1677,7 +1677,7 @@ zonkEvBinds env binds
;
return
(
env1
,
binds'
)
})
where
collect_ev_bndrs
::
Bag
EvBind
->
[
EvVar
]
collect_ev_bndrs
=
foldr
Bag
add
[]
collect_ev_bndrs
=
foldr
add
[]
add
(
EvBind
{
eb_lhs
=
var
})
vars
=
var
:
vars
zonkEvBind
::
ZonkEnv
->
EvBind
->
TcM
EvBind
...
...
compiler/typecheck/TcInteract.hs
View file @
ac79dfe9
...
...
@@ -223,7 +223,7 @@ solveSimples :: Cts -> TcS ()
solveSimples
cts
=
{-# SCC "solveSimples" #-}
do
{
updWorkListTcS
(
\
wl
->
foldr
Bag
extendWorkListCt
wl
cts
)
do
{
updWorkListTcS
(
\
wl
->
foldr
extendWorkListCt
wl
cts
)
;
solve_loop
}
where
solve_loop
...
...
compiler/typecheck/TcRnDriver.hs
View file @
ac79dfe9
...
...
@@ -1458,7 +1458,7 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
foe_binds
;
fo_gres
=
fi_gres
`
unionBags
`
foe_gres
;
fo_fvs
=
foldr
Bag
(
\
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
)
...
...
compiler/typecheck/TcRnTypes.hs
View file @
ac79dfe9
...
...
@@ -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
=
foldr
Bag
(
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
=
foldr
Bag
(
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
(
foldr
Bag
((
$$
)
.
ppr
)
empty
bag
)
2
(
foldr
((
$$
)
.
ppr
)
empty
bag
)
{- Note [Given insolubles]
~~~~~~~~~~~~~~~~~~~~~~~~~~
...
...
compiler/typecheck/TcSMonad.hs
View file @
ac79dfe9
...
...
@@ -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
=
foldr
Bag
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
=
foldr
Bag
((
||
)
.
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
=
foldr
Bag
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
(
foldr
Bag
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
)
...
...
compiler/typecheck/TcSigs.hs
View file @
ac79dfe9
...
...
@@ -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
=
foldr
Bag
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
...
...
compiler/typecheck/TcSimplify.hs
View file @
ac79dfe9
...
...
@@ -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
=
foldr
Bag
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
=
foldr
Bag
(
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
`
foldr
Bag
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
=
foldr
Bag
extra_skol
emptyVarSet
cts
add_captured_ev_ids
cts
skols
=
foldr
extra_skol
emptyVarSet
cts
where
extra_skol
ct
acc
|
isDerivedCt
ct
=
acc
...
...
compiler/utils/Bag.hs
View file @
ac79dfe9
...
...
@@ -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
=
foldr
Bag
add
emptyBag
bss
concatBag
bss
=
foldr
add
emptyBag
bss
where
add
bs
rs
=
bs
`
unionBags
`
rs
catBagMaybes
::
Bag
(
Maybe
a
)
->
Bag
a
catBagMaybes
bs
=
foldr
Bag
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
=
foldr
Bag
(
:
)
[]
b
bagToList
b
=
foldr
(
:
)
[]
b
instance
(
Outputable
a
)
=>
Outputable
(
Bag
a
)
where
ppr
bag
=
braces
(
pprWithCommas
ppr
(
bagToList
bag
))
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment