Define mapUnionVarSet, and use it

Call sites are much easier to understand than before

12 files changed, 39 insertions, 36 deletions

diff --git a/compiler/basicTypes/VarSet.lhs b/compiler/basicTypes/VarSet.lhs
index 8b7f755dcd..368be68ceb 100644
--- a/compiler/basicTypes/VarSet.lhs
+++ b/compiler/basicTypes/VarSet.lhs
@@ -15,12 +15,12 @@
 module VarSet (
         -- * Var, Id and TyVar set types
 	VarSet, IdSet, TyVarSet, CoVarSet,
-	
+
 	-- ** Manipulating these sets
 	emptyVarSet, unitVarSet, mkVarSet,
 	extendVarSet, extendVarSetList, extendVarSet_C,
 	elemVarSet, varSetElems, subVarSet,
-	unionVarSet, unionVarSets,
+	unionVarSet, unionVarSets, mapUnionVarSet,
 	intersectVarSet, intersectsVarSet, disjointVarSet,
 	isEmptyVarSet, delVarSet, delVarSetList, delVarSetByKey,
 	minusVarSet, foldVarSet, filterVarSet, fixVarSet,
@@ -51,6 +51,10 @@ emptyVarSet	:: VarSet
 intersectVarSet	:: VarSet -> VarSet -> VarSet
 unionVarSet	:: VarSet -> VarSet -> VarSet
 unionVarSets	:: [VarSet] -> VarSet
+
+mapUnionVarSet  :: (a -> VarSet) -> [a] -> VarSet
+-- ^ map the function oer the list, and union the results
+
 varSetElems	:: VarSet -> [Var]
 unitVarSet	:: Var -> VarSet
 extendVarSet	:: VarSet -> Var -> VarSet
@@ -108,6 +112,8 @@ partitionVarSet = partitionUniqSet
 \end{code}
 
 \begin{code}
+mapUnionVarSet get_set xs = foldr (unionVarSet . get_set) emptyVarSet xs
+
 -- See comments with type signatures
 intersectsVarSet s1 s2 = not (s1 `disjointVarSet` s2)
 disjointVarSet   s1 s2 = isEmptyVarSet (s1 `intersectVarSet` s2)
diff --git a/compiler/coreSyn/CoreFVs.lhs b/compiler/coreSyn/CoreFVs.lhs
index ae162b6a55..44ae8f1d77 100644
--- a/compiler/coreSyn/CoreFVs.lhs
+++ b/compiler/coreSyn/CoreFVs.lhs
@@ -78,7 +78,7 @@ exprFreeIds = exprSomeFreeVars isLocalId
 
 -- | Find all locally-defined free Ids or type variables in several expressions
 exprsFreeVars :: [CoreExpr] -> VarSet
-exprsFreeVars = foldr (unionVarSet . exprFreeVars) emptyVarSet
+exprsFreeVars = mapUnionVarSet exprFreeVars
 
 -- | Find all locally defined free Ids in a binding group
 bindFreeVars :: CoreBind -> VarSet
@@ -97,7 +97,7 @@ exprSomeFreeVars fv_cand e = expr_fvs e fv_cand emptyVarSet
 exprsSomeFreeVars :: InterestingVarFun  -- Says which 'Var's are interesting
                   -> [CoreExpr]
                   -> VarSet
-exprsSomeFreeVars fv_cand = foldr (unionVarSet . exprSomeFreeVars fv_cand) emptyVarSet
+exprsSomeFreeVars fv_cand = mapUnionVarSet (exprSomeFreeVars fv_cand)
 
 -- | Predicate on possible free variables: returns @True@ iff the variable is interesting
 type InterestingVarFun = Var -> Bool
@@ -294,7 +294,7 @@ ruleFreeVars (Rule { ru_fn = _, ru_bndrs = bndrs, ru_rhs = rhs, ru_args = args }
 idRuleRhsVars :: (Activation -> Bool) -> Id -> VarSet
 -- Just the variables free on the *rhs* of a rule
 idRuleRhsVars is_active id
-  = foldr (unionVarSet . get_fvs) emptyVarSet (idCoreRules id)
+  = mapUnionVarSet get_fvs (idCoreRules id)
   where
     get_fvs (Rule { ru_fn = fn, ru_bndrs = bndrs
                   , ru_rhs = rhs, ru_act = act })
@@ -307,7 +307,7 @@ idRuleRhsVars is_active id
 
 -- | Those variables free in the right hand side of several rules
 rulesFreeVars :: [CoreRule] -> VarSet
-rulesFreeVars rules = foldr (unionVarSet . ruleFreeVars) emptyVarSet rules
+rulesFreeVars rules = mapUnionVarSet ruleFreeVars rules
 
 ruleLhsFreeIds :: CoreRule -> VarSet
 -- ^ This finds all locally-defined free Ids on the left hand side of a rule
@@ -330,7 +330,7 @@ breaker, which is perfectly inlinable.
 \begin{code}
 -- |Free variables of a vectorisation declaration
 vectsFreeVars :: [CoreVect] -> VarSet
-vectsFreeVars = foldr (unionVarSet . vectFreeVars) emptyVarSet
+vectsFreeVars = mapUnionVarSet vectFreeVars
   where
     vectFreeVars (Vect   _ rhs)   = expr_fvs rhs isLocalId emptyVarSet
     vectFreeVars (NoVect _)       = noFVs
diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
index d60cf56eba..f25ed75b48 100644
--- a/compiler/main/InteractiveEval.hs
+++ b/compiler/main/InteractiveEval.hs
@@ -610,8 +610,8 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do
 
        (ids, offsets) = unzip pointers
 
-       free_tvs = foldr (unionVarSet . tyVarsOfType . idType)
-                        (tyVarsOfType result_ty) ids
+       free_tvs = mapUnionVarSet (tyVarsOfType . idType) ids
+                  `unionVarSet` tyVarsOfType result_ty
 
    -- It might be that getIdValFromApStack fails, because the AP_STACK
    -- has been accidentally evaluated, or something else has gone wrong.
diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs
index 6461f18a19..c92b5933cd 100644
--- a/compiler/main/TidyPgm.lhs
+++ b/compiler/main/TidyPgm.lhs
@@ -635,7 +635,7 @@ chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_
   -- (c) it is the vectorised version of an imported Id
   -- See Note [Which rules to expose]
   is_external id = isExportedId id || id `elemVarSet` rule_rhs_vars || id `elemVarSet` vect_var_vs
-  rule_rhs_vars  = listFVs ruleRhsFreeVars imp_id_rules emptyVarSet
+  rule_rhs_vars  = mapUnionVarSet ruleRhsFreeVars imp_id_rules
   vect_var_vs    = mkVarSet [var_v | (var, var_v) <- nameEnvElts vect_vars, isGlobalId var]
 
   binders          = bindersOfBinds binds
@@ -923,7 +923,7 @@ findExternalRules omit_prags binds imp_id_rules unfold_env
   = (trimmed_binds, filter keep_rule all_rules)
   where
     imp_rules         = filter expose_rule imp_id_rules
-    imp_user_rule_fvs = listFVs user_rule_rhs_fvs imp_rules emptyVarSet
+    imp_user_rule_fvs = mapUnionVarSet user_rule_rhs_fvs imp_rules
 
     user_rule_rhs_fvs rule | isAutoRule rule = emptyVarSet
                            | otherwise       = ruleRhsFreeVars rule
@@ -980,11 +980,11 @@ findExternalRules omit_prags binds imp_id_rules unfold_env
          rhss          = rhssOfBind bind
          bndr_set'     = bndr_set `extendVarSetList` bndrs
 
-         needed_fvs'   = listFVs idUnfoldingVars   bndrs       $
+         needed_fvs'   = needed_fvs                                   `unionVarSet`
+                         mapUnionVarSet idUnfoldingVars   bndrs       `unionVarSet`
                               -- Ignore type variables in the type of bndrs
-                         listFVs exprFreeVars      rhss        $
-                         listFVs user_rule_rhs_fvs local_rules $
-                         needed_fvs
+                         mapUnionVarSet exprFreeVars      rhss        `unionVarSet`
+                         mapUnionVarSet user_rule_rhs_fvs local_rules
             -- In needed_fvs', we don't bother to delete binders from the fv set
 
          local_rules  = [ rule
@@ -992,9 +992,6 @@ findExternalRules omit_prags binds imp_id_rules unfold_env
                         , is_external_id id   -- Only collect rules for external Ids
                         , rule <- idCoreRules id
                         , expose_rule rule ]  -- and ones that can fire in a client
-
-listFVs :: (a -> VarSet) -> [a] -> VarSet -> VarSet
-listFVs fv_fn xs fvs = foldr (unionVarSet . fv_fn) fvs xs
 \end{code}
 
 %************************************************************************
diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs
index faec02e9c6..ad4a0e1a1b 100644
--- a/compiler/simplCore/CoreMonad.lhs
+++ b/compiler/simplCore/CoreMonad.lhs
@@ -274,7 +274,7 @@ interactiveInScope hsc_env
     te1    = mkTypeEnvWithImplicits (ic_tythings ictxt)
     te     = extendTypeEnvWithIds te1 (map instanceDFunId cls_insts)
     ids    = typeEnvIds te
-    tyvars = foldr (unionVarSet . tyVarsOfType . idType) emptyVarSet ids
+    tyvars = mapUnionVarSet (tyVarsOfType . idType) ids
               -- Why the type variables?  How can the top level envt have free tyvars?
               -- I think it's because of the GHCi debugger, which can bind variables
               --   f :: [t] -> [t]
diff --git a/compiler/simplCore/FloatIn.lhs b/compiler/simplCore/FloatIn.lhs
index f00768a9f5..a90d59cf77 100644
--- a/compiler/simplCore/FloatIn.lhs
+++ b/compiler/simplCore/FloatIn.lhs
@@ -344,7 +344,7 @@ fiExpr dflags to_drop (_,AnnLet (AnnRec bindings) body)
     body_fvs = freeVarsOf body 
 
 	-- See Note [extra_fvs (1,2)]
-    rule_fvs = foldr (unionVarSet . idRuleAndUnfoldingVars) emptyVarSet ids
+    rule_fvs = mapUnionVarSet idRuleAndUnfoldingVars ids
     extra_fvs = rule_fvs `unionVarSet` 
 		unionVarSets [ fvs | (fvs, rhs) <- rhss
 			     , noFloatIntoExpr rhs ]
@@ -552,7 +552,7 @@ sepBindsByDropPoint dflags is_case drop_pts floaters
 
 
 floatedBindsFVs :: FloatInBinds -> FreeVarSet
-floatedBindsFVs binds = foldr (unionVarSet . fbFVs) emptyVarSet binds
+floatedBindsFVs binds = mapUnionVarSet fbFVs binds
 
 fbFVs :: FloatInBind -> VarSet
 fbFVs (FB _ fvs _) = fvs
diff --git a/compiler/simplCore/OccurAnal.lhs b/compiler/simplCore/OccurAnal.lhs
index 2ce32a1e9a..6456eccd49 100644
--- a/compiler/simplCore/OccurAnal.lhs
+++ b/compiler/simplCore/OccurAnal.lhs
@@ -684,10 +684,10 @@ makeNode env imp_rules_edges bndr_set (bndr, rhs)
                   , let fvs = exprFreeVars (ru_rhs rule)
                               `delVarSetList` ru_bndrs rule
                   , not (isEmptyVarSet fvs) ]
-    all_rule_fvs = foldr (unionVarSet . snd) rule_lhs_fvs rules_w_fvs
-    rule_lhs_fvs = foldr (unionVarSet . (\ru -> exprsFreeVars (ru_args ru)
-                                                `delVarSetList` ru_bndrs ru))
-                         emptyVarSet rules
+    all_rule_fvs = rule_lhs_fvs `unionVarSet` rule_rhs_fvs
+    rule_rhs_fvs = mapUnionVarSet snd rules_w_fvs
+    rule_lhs_fvs = mapUnionVarSet (\ru -> exprsFreeVars (ru_args ru)
+                                          `delVarSetList` ru_bndrs ru) rules
     active_rule_fvs = unionVarSets [fvs | (a,fvs) <- rules_w_fvs, is_active a]
 
     -- Finding the free variables of the INLINE pragma (if any)
@@ -757,7 +757,7 @@ occAnalRec (CyclicSCC nodes) (body_uds, binds)
           -- a fresh SCC computation that will yield a single CyclicSCC result.
 
     weak_fvs :: VarSet
-    weak_fvs = foldr (unionVarSet . nd_weak . fstOf3) emptyVarSet nodes
+    weak_fvs = mapUnionVarSet (nd_weak . fstOf3) nodes
 
         -- See Note [Choosing loop breakers] for loop_breaker_edges
     loop_breaker_edges = map mk_node tagged_nodes
diff --git a/compiler/typecheck/TcEvidence.lhs b/compiler/typecheck/TcEvidence.lhs
index 7fc6194b8f..e2c2e60b04 100644
--- a/compiler/typecheck/TcEvidence.lhs
+++ b/compiler/typecheck/TcEvidence.lhs
@@ -316,12 +316,12 @@ coVarsOfTcCo tc_co
   = go tc_co
   where
     go (TcRefl _ _)              = emptyVarSet
-    go (TcTyConAppCo _ _ cos)    = foldr (unionVarSet . go) emptyVarSet cos
+    go (TcTyConAppCo _ _ cos)    = mapUnionVarSet go cos
     go (TcAppCo co1 co2)         = go co1 `unionVarSet` go co2
     go (TcCastCo co1 co2)        = go co1 `unionVarSet` go co2
     go (TcForAllCo _ co)         = go co
     go (TcCoVarCo v)             = unitVarSet v
-    go (TcAxiomInstCo _ _ cos)   = foldr (unionVarSet . go) emptyVarSet cos
+    go (TcAxiomInstCo _ _ cos)   = mapUnionVarSet go cos
     go (TcPhantomCo _ _)         = emptyVarSet
     go (TcSymCo co)              = go co
     go (TcTransCo co1 co2)       = go co1 `unionVarSet` go co2
@@ -332,7 +332,7 @@ coVarsOfTcCo tc_co
                                    `minusVarSet` get_bndrs bs
     go (TcLetCo {}) = emptyVarSet    -- Harumph. This does legitimately happen in the call
                                      -- to evVarsOfTerm in the DEBUG check of setEvBind
-    go (TcAxiomRuleCo _ _ cos)   = foldr (unionVarSet . go) emptyVarSet cos
+    go (TcAxiomRuleCo _ _ cos)   = mapUnionVarSet go cos
 
 
     -- We expect only coercion bindings, so use evTermCoercion 
@@ -738,7 +738,7 @@ evVarsOfTerm (EvDelayedError _ _) = emptyVarSet
 evVarsOfTerm (EvLit _)            = emptyVarSet
 
 evVarsOfTerms :: [EvTerm] -> VarSet
-evVarsOfTerms = foldr (unionVarSet . evVarsOfTerm) emptyVarSet 
+evVarsOfTerms = mapUnionVarSet evVarsOfTerm
 \end{code}
 
 
diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index dde5902ccc..4fff6ab45a 100644
--- a/compiler/typecheck/TcSimplify.lhs
+++ b/compiler/typecheck/TcSimplify.lhs
@@ -1371,7 +1371,7 @@ findDefaultableGroups (default_tys, (ovl_strings, extended_defaults)) wanteds
     find_unary cc = Right cc  -- Non unary or non dictionary
 
     bad_tvs :: TcTyVarSet  -- TyVars mentioned by non-unaries
-    bad_tvs = foldr (unionVarSet . tyVarsOfCt) emptyVarSet non_unaries
+    bad_tvs = mapUnionVarSet tyVarsOfCt non_unaries
 
     cmp_tv (_,_,tv1) (_,_,tv2) = tv1 `compare` tv2
 
diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs
index f12ec9d6d5..db3ae8315f 100644
--- a/compiler/typecheck/TcType.lhs
+++ b/compiler/typecheck/TcType.lhs
@@ -571,7 +571,7 @@ exactTyVarsOfType ty
     go (ForAllTy tyvar ty)  = delVarSet (go ty) tyvar
 
 exactTyVarsOfTypes :: [Type] -> TyVarSet
-exactTyVarsOfTypes tys = foldr (unionVarSet . exactTyVarsOfType) emptyVarSet tys
+exactTyVarsOfTypes = mapUnionVarSet exactTyVarsOfType
 \end{code}
 
 %************************************************************************
@@ -1319,7 +1319,7 @@ tcTyVarsOfType (ForAllTy tyvar ty)  = tcTyVarsOfType ty `delVarSet` tyvar
         -- We do sometimes quantify over skolem TcTyVars
 
 tcTyVarsOfTypes :: [Type] -> TyVarSet
-tcTyVarsOfTypes tys = foldr (unionVarSet.tcTyVarsOfType) emptyVarSet tys
+tcTyVarsOfTypes = mapUnionVarSet tcTyVarsOfType
 \end{code}
 
 Find the free tycons and classes of a type.  This is used in the front
diff --git a/compiler/types/Coercion.lhs b/compiler/types/Coercion.lhs
index 38f38ed50b..f0c0516c0e 100644
--- a/compiler/types/Coercion.lhs
+++ b/compiler/types/Coercion.lhs
@@ -535,7 +535,7 @@ tyCoVarsOfCo (SubCo co)            = tyCoVarsOfCo co
 tyCoVarsOfCo (AxiomRuleCo _ ts cs) = tyVarsOfTypes ts `unionVarSet` tyCoVarsOfCos cs
 
 tyCoVarsOfCos :: [Coercion] -> VarSet
-tyCoVarsOfCos cos = foldr (unionVarSet . tyCoVarsOfCo) emptyVarSet cos
+tyCoVarsOfCos = mapUnionVarSet tyCoVarsOfCo
 
 coVarsOfCo :: Coercion -> VarSet
 -- Extract *coerction* variables only.  Tiresome to repeat the code, but easy.
@@ -555,7 +555,7 @@ coVarsOfCo (SubCo co)            = coVarsOfCo co
 coVarsOfCo (AxiomRuleCo _ _ cos) = coVarsOfCos cos
 
 coVarsOfCos :: [Coercion] -> VarSet
-coVarsOfCos cos = foldr (unionVarSet . coVarsOfCo) emptyVarSet cos
+coVarsOfCos = mapUnionVarSet coVarsOfCo
 
 coercionSize :: Coercion -> Int
 coercionSize (Refl _ ty)           = typeSize ty
diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs
index c8b20e8d93..45acb86b64 100644
--- a/compiler/types/TypeRep.lhs
+++ b/compiler/types/TypeRep.lhs
@@ -327,7 +327,7 @@ tyVarsOfType (ForAllTy tyvar ty) = delVarSet (tyVarsOfType ty) tyvar
                                    `unionVarSet` tyVarsOfType (tyVarKind tyvar)
 
 tyVarsOfTypes :: [Type] -> TyVarSet
-tyVarsOfTypes tys = foldr (unionVarSet . tyVarsOfType) emptyVarSet tys
+tyVarsOfTypes = mapUnionVarSet tyVarsOfType
 
 closeOverKinds :: TyVarSet -> TyVarSet
 -- Add the kind variables free in the kinds