Add uniqSetAny and uniqSetAll and use them

There are couple of places where we do `foldUniqSet` just to
compute `any` or `all`. `foldUniqSet` is non-deterministic in the
general case and `any` and `all` also read nicer.

Test Plan: ./validate

Reviewers: simonmar, goldfire, simonpj, bgamari, austin

Reviewed By: simonpj

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D2156

GHC Trac Issues: #4012

9 files changed, 36 insertions, 9 deletions

diff --git a/compiler/basicTypes/NameSet.hs b/compiler/basicTypes/NameSet.hs
index 574c3a4c6d..b332fe29e0 100644
--- a/compiler/basicTypes/NameSet.hs
+++ b/compiler/basicTypes/NameSet.hs
@@ -13,6 +13,7 @@ module NameSet (
         minusNameSet, elemNameSet, nameSetElems, extendNameSet, extendNameSetList,
         delFromNameSet, delListFromNameSet, isEmptyNameSet, foldNameSet, filterNameSet,
         intersectsNameSet, intersectNameSet,
+        nameSetAny, nameSetAll,
 
         -- * Free variables
         FreeVars,
@@ -85,6 +86,12 @@ delListFromNameSet set ns = foldl delFromNameSet set ns
 
 intersectsNameSet s1 s2 = not (isEmptyNameSet (s1 `intersectNameSet` s2))
 
+nameSetAny :: (Name -> Bool) -> NameSet -> Bool
+nameSetAny = uniqSetAny
+
+nameSetAll :: (Name -> Bool) -> NameSet -> Bool
+nameSetAll = uniqSetAll
+
 {-
 ************************************************************************
 *                                                                      *
diff --git a/compiler/basicTypes/VarSet.hs b/compiler/basicTypes/VarSet.hs
index f61bbbe20f..57369f3b5b 100644
--- a/compiler/basicTypes/VarSet.hs
+++ b/compiler/basicTypes/VarSet.hs
@@ -17,6 +17,7 @@ module VarSet (
         intersectVarSet, intersectsVarSet, disjointVarSet,
         isEmptyVarSet, delVarSet, delVarSetList, delVarSetByKey,
         minusVarSet, foldVarSet, filterVarSet,
+        varSetAny, varSetAll,
         transCloVarSet, fixVarSet,
         lookupVarSet, lookupVarSetByName,
         mapVarSet, sizeVarSet, seqVarSet,
@@ -134,6 +135,12 @@ intersectsVarSet s1 s2 = not (s1 `disjointVarSet` s2)
 disjointVarSet   s1 s2 = disjointUFM s1 s2
 subVarSet        s1 s2 = isEmptyVarSet (s1 `minusVarSet` s2)
 
+varSetAny :: (Var -> Bool) -> VarSet -> Bool
+varSetAny = uniqSetAny
+
+varSetAll :: (Var -> Bool) -> VarSet -> Bool
+varSetAll = uniqSetAll
+
 fixVarSet :: (VarSet -> VarSet)   -- Map the current set to a new set
           -> VarSet -> VarSet
 -- (fixVarSet f s) repeatedly applies f to the set s,
diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs
index eb1494f765..f92bae9f02 100644
--- a/compiler/rename/RnSource.hs
+++ b/compiler/rename/RnSource.hs
@@ -1420,8 +1420,7 @@ addBootDeps ds_w_fvs
                 | otherwise             = pr
 
              has_local_imports fvs
-                 = foldNameSet ((||) . nameIsHomePackageImport this_mod)
-                               False fvs
+                 = nameSetAny (nameIsHomePackageImport this_mod) fvs
        ; return (add_boot_deps ds_w_fvs) }
 
 
diff --git a/compiler/specialise/Rules.hs b/compiler/specialise/Rules.hs
index 3adad1c83e..f9f195fe45 100644
--- a/compiler/specialise/Rules.hs
+++ b/compiler/specialise/Rules.hs
@@ -855,7 +855,7 @@ match_alts _ _ _ _
 ------------------------------------------
 okToFloat :: RnEnv2 -> VarSet -> Bool
 okToFloat rn_env bind_fvs
-  = foldVarSet ((&&) . not_captured) True bind_fvs
+  = varSetAll not_captured bind_fvs
   where
     not_captured fv = not (inRnEnvR rn_env fv)
 
diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs
index ac19061271..aef80a8fc0 100644
--- a/compiler/typecheck/TcBinds.hs
+++ b/compiler/typecheck/TcBinds.hs
@@ -1973,7 +1973,7 @@ isClosedBndrGroup binds = do
     fvs _                           = emptyNameSet
 
     is_closed_ns :: TcTypeEnv -> NameSet -> Bool -> Bool
-    is_closed_ns type_env ns b = foldNameSet ((&&) . is_closed_id type_env) b ns
+    is_closed_ns type_env ns b = b && nameSetAll (is_closed_id type_env) ns
         -- ns are the Names referred to from the RHS of this bind
 
     is_closed_id :: TcTypeEnv -> Name -> Bool
diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs
index b51a267499..78320c4be3 100644
--- a/compiler/typecheck/TcErrors.hs
+++ b/compiler/typecheck/TcErrors.hs
@@ -2328,7 +2328,7 @@ pprPotentials dflags sty herald insts
        -- are lexically in scope; these instances are likely
        -- to be more useful
     inst_in_scope :: ClsInst -> Bool
-    inst_in_scope cls_inst = foldNameSet ((&&) . name_in_scope) True $
+    inst_in_scope cls_inst = nameSetAll name_in_scope $
                              orphNamesOfTypes (is_tys cls_inst)
 
     name_in_scope name
diff --git a/compiler/types/Unify.hs b/compiler/types/Unify.hs
index dadb8e3104..381f9482d1 100644
--- a/compiler/types/Unify.hs
+++ b/compiler/types/Unify.hs
@@ -454,7 +454,7 @@ niFixTCvSubst tenv = f tenv
         | not_fixpoint = f (mapVarEnv (substTy subst') tenv)
         | otherwise    = subst
         where
-          not_fixpoint  = foldVarSet ((||) . in_domain) False range_tvs
+          not_fixpoint  = varSetAny in_domain range_tvs
           in_domain tv  = tv `elemVarEnv` tenv
 
           range_tvs     = foldVarEnv (unionVarSet . tyCoVarsOfType) emptyVarSet tenv
@@ -1140,7 +1140,7 @@ ty_co_match menv subst ty co lkco rkco
       = noneSet (\v -> elemVarEnv v env) set
 
     noneSet :: (Var -> Bool) -> VarSet -> Bool
-    noneSet f = foldVarSet (\v rest -> rest && (not $ f v)) True
+    noneSet f = varSetAll (not . f)
 
 ty_co_match menv subst ty co lkco rkco
   | CastTy ty' co' <- ty
diff --git a/compiler/utils/UniqFM.hs b/compiler/utils/UniqFM.hs
index 10cc179910..ed82fee4ec 100644
--- a/compiler/utils/UniqFM.hs
+++ b/compiler/utils/UniqFM.hs
@@ -56,7 +56,7 @@ module UniqFM (
         intersectUFM,
         intersectUFM_C,
         disjointUFM,
-        foldUFM, foldUFM_Directly,
+        foldUFM, foldUFM_Directly, anyUFM, allUFM,
         mapUFM, mapUFM_Directly,
         elemUFM, elemUFM_Directly,
         filterUFM, filterUFM_Directly, partitionUFM,
@@ -275,6 +275,8 @@ intersectUFM_C f (UFM x) (UFM y) = UFM (M.intersectionWith f x y)
 disjointUFM (UFM x) (UFM y) = M.null (M.intersection x y)
 
 foldUFM k z (UFM m) = M.fold k z m
+
+
 foldUFM_Directly k z (UFM m) = M.foldWithKey (k . getUnique) z m
 mapUFM f (UFM m) = UFM (M.map f m)
 mapUFM_Directly f (UFM m) = UFM (M.mapWithKey (f . getUnique) m)
@@ -298,6 +300,12 @@ eltsUFM (UFM m) = M.elems m
 ufmToSet_Directly (UFM m) = M.keysSet m
 ufmToList (UFM m) = map (\(k, v) -> (getUnique k, v)) $ M.toList m
 
+anyUFM :: (elt -> Bool) -> UniqFM elt -> Bool
+anyUFM p (UFM m) = M.fold ((||) . p) False m
+
+allUFM :: (elt -> Bool) -> UniqFM elt -> Bool
+allUFM p (UFM m) = M.fold ((&&) . p) True m
+
 ufmToIntMap :: UniqFM elt -> M.IntMap elt
 ufmToIntMap (UFM m) = m
 
diff --git a/compiler/utils/UniqSet.hs b/compiler/utils/UniqSet.hs
index a3d503f6eb..c1d19b3695 100644
--- a/compiler/utils/UniqSet.hs
+++ b/compiler/utils/UniqSet.hs
@@ -22,7 +22,7 @@ module UniqSet (
         unionUniqSets, unionManyUniqSets,
         minusUniqSet,
         intersectUniqSets,
-        foldUniqSet,
+        foldUniqSet, uniqSetAny, uniqSetAll,
         mapUniqSet,
         elementOfUniqSet,
         elemUniqSet_Directly,
@@ -113,3 +113,9 @@ sizeUniqSet = sizeUFM
 isEmptyUniqSet = isNullUFM
 lookupUniqSet = lookupUFM
 uniqSetToList = eltsUFM
+
+uniqSetAny :: (a -> Bool) -> UniqSet a -> Bool
+uniqSetAny = anyUFM
+
+uniqSetAll :: (a -> Bool) -> UniqSet a -> Bool
+uniqSetAll = allUFM