Refactor some ppr functions to use pprUFM

Nondeterminism doesn't matter in these places and pprUFM makes
it obvious. I've flipped the order of arguments for convenience.

Test Plan: ./validate

Reviewers: simonmar, bgamari, austin, simonpj

Reviewed By: simonpj

Subscribers: thomie

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

GHC Trac Issues: #4012

12 files changed, 27 insertions, 20 deletions

diff --git a/compiler/basicTypes/RdrName.hs b/compiler/basicTypes/RdrName.hs
index ee63882d11..ec51ea5516 100644
--- a/compiler/basicTypes/RdrName.hs
+++ b/compiler/basicTypes/RdrName.hs
@@ -74,6 +74,7 @@ import FastString
 import FieldLabel
 import Outputable
 import Unique
+import UniqFM
 import Util
 import StaticFlags( opt_PprStyle_Debug )
 
@@ -333,7 +334,7 @@ instance Outputable LocalRdrEnv where
     = hang (text "LocalRdrEnv {")
          2 (vcat [ text "env =" <+> pprOccEnv ppr_elt env
                  , text "in_scope ="
-                    <+> braces (pprWithCommas ppr (nameSetElems ns))
+                    <+> pprUFM ns (braces . pprWithCommas ppr)
                  ] <+> char '}')
     where
       ppr_elt name = parens (ppr (getUnique (nameOccName name))) <+> ppr name
diff --git a/compiler/basicTypes/VarSet.hs b/compiler/basicTypes/VarSet.hs
index 31718f6856..2c2066a1cf 100644
--- a/compiler/basicTypes/VarSet.hs
+++ b/compiler/basicTypes/VarSet.hs
@@ -196,9 +196,9 @@ pluralVarSet = pluralUFM
 -- to use varSetElems at the call site. This prevents from let-binding
 -- non-deterministically ordered lists and reusing them where determinism
 -- matters.
-pprVarSet :: ([Var] -> SDoc) -- ^ The pretty printing function to use on the
+pprVarSet :: VarSet          -- ^ The things to be pretty printed
+          -> ([Var] -> SDoc) -- ^ The pretty printing function to use on the
                              -- elements
-          -> VarSet          -- ^ The things to be pretty printed
           -> SDoc            -- ^ 'SDoc' where the things have been pretty
                              -- printed
 pprVarSet = pprUFM
diff --git a/compiler/coreSyn/CoreSubst.hs b/compiler/coreSyn/CoreSubst.hs
index 1f60e7cd1f..7723b71acc 100644
--- a/compiler/coreSyn/CoreSubst.hs
+++ b/compiler/coreSyn/CoreSubst.hs
@@ -343,11 +343,13 @@ setInScope (Subst _ ids tvs cvs) in_scope = Subst in_scope ids tvs cvs
 
 instance Outputable Subst where
   ppr (Subst in_scope ids tvs cvs)
-        =  text "<InScope =" <+> braces (fsep (map ppr (varEnvElts (getInScopeVars in_scope))))
+        =  text "<InScope =" <+> in_scope_doc
         $$ text " IdSubst   =" <+> ppr ids
         $$ text " TvSubst   =" <+> ppr tvs
         $$ text " CvSubst   =" <+> ppr cvs
          <> char '>'
+    where
+    in_scope_doc = pprVarSet (getInScopeVars in_scope) (braces . fsep . map ppr)
 
 {-
 ************************************************************************
diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs
index 800958bd6f..e7673d6ab4 100644
--- a/compiler/main/HscTypes.hs
+++ b/compiler/main/HscTypes.hs
@@ -486,10 +486,10 @@ emptyPackageIfaceTable = emptyModuleEnv
 
 pprHPT :: HomePackageTable -> SDoc
 -- A bit aribitrary for now
-pprHPT hpt
-  = vcat [ hang (ppr (mi_module (hm_iface hm)))
+pprHPT hpt = pprUFM hpt $ \hms ->
+    vcat [ hang (ppr (mi_module (hm_iface hm)))
               2 (ppr (md_types (hm_details hm)))
-         | hm <- eltsUFM hpt ]
+         | hm <- hms ]
 
 lookupHptByModule :: HomePackageTable -> Module -> Maybe HomeModInfo
 -- The HPT is indexed by ModuleName, not Module,
diff --git a/compiler/simplCore/SimplEnv.hs b/compiler/simplCore/SimplEnv.hs
index da829437ad..7061540942 100644
--- a/compiler/simplCore/SimplEnv.hs
+++ b/compiler/simplCore/SimplEnv.hs
@@ -132,10 +132,11 @@ pprSimplEnv env
   = vcat [text "TvSubst:" <+> ppr (seTvSubst env),
           text "CvSubst:" <+> ppr (seCvSubst env),
           text "IdSubst:" <+> ppr (seIdSubst env),
-          text "InScope:" <+> vcat (map ppr_one in_scope_vars)
+          text "InScope:" <+> in_scope_vars_doc
     ]
   where
-   in_scope_vars = varEnvElts (getInScopeVars (seInScope env))
+   in_scope_vars_doc = pprVarSet (getInScopeVars (seInScope env))
+                                 (vcat . map ppr_one)
    ppr_one v | isId v = ppr v <+> ppr (idUnfolding v)
              | otherwise = ppr v
 
diff --git a/compiler/specialise/Rules.hs b/compiler/specialise/Rules.hs
index f9f195fe45..aebfbc744e 100644
--- a/compiler/specialise/Rules.hs
+++ b/compiler/specialise/Rules.hs
@@ -50,6 +50,7 @@ import VarSet
 import Name             ( Name, NamedThing(..), nameIsLocalOrFrom )
 import NameSet
 import NameEnv
+import UniqFM
 import Unify            ( ruleMatchTyX )
 import BasicTypes       ( Activation, CompilerPhase, isActive, pprRuleName )
 import StaticFlags      ( opt_PprStyle_Debug )
@@ -357,8 +358,9 @@ extendRuleBase rule_base rule
   = extendNameEnv_Acc (:) singleton rule_base (ruleIdName rule) rule
 
 pprRuleBase :: RuleBase -> SDoc
-pprRuleBase rules = vcat [ pprRules (tidyRules emptyTidyEnv rs)
-                         | rs <- nameEnvElts rules ]
+pprRuleBase rules = pprUFM rules $ \rss ->
+  vcat [ pprRules (tidyRules emptyTidyEnv rs)
+       | rs <- rss ]
 
 {-
 ************************************************************************
diff --git a/compiler/typecheck/FamInst.hs b/compiler/typecheck/FamInst.hs
index a7fad313a0..6c357ce5e4 100644
--- a/compiler/typecheck/FamInst.hs
+++ b/compiler/typecheck/FamInst.hs
@@ -562,7 +562,7 @@ unusedInjectiveVarsErr (Pair invis_vars vis_vars) errorBuilder tyfamEqn
       has_kinds = not $ isEmptyVarSet invis_vars
 
       doc = sep [ what <+> text "variable" <>
-                  pluralVarSet tvs <+> pprVarSet (pprQuotedList . toposortTyVars) tvs
+                  pluralVarSet tvs <+> pprVarSet tvs (pprQuotedList . toposortTyVars)
                 , text "cannot be inferred from the right-hand side." ]
       what = case (has_types, has_kinds) of
                (True, True)   -> text "Type and kind"
diff --git a/compiler/typecheck/FunDeps.hs b/compiler/typecheck/FunDeps.hs
index 4f213b2c6e..bf4255812f 100644
--- a/compiler/typecheck/FunDeps.hs
+++ b/compiler/typecheck/FunDeps.hs
@@ -402,7 +402,7 @@ checkInstCoverage be_liberal clas theta inst_taus
                             <+> text "determine rhs type"<>plural rs
                             <+> pprQuotedList rs ]
                     , text "Un-determined variable" <> pluralVarSet undet_set <> colon
-                            <+> pprVarSet (pprWithCommas ppr) undet_set
+                            <+> pprVarSet undet_set (pprWithCommas ppr)
                     , ppWhen (isEmptyVarSet $ pSnd undetermined_tvs) $
                       ppSuggestExplicitKinds
                     , ppWhen (not be_liberal &&
diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs
index d9ba069643..878a3ea821 100644
--- a/compiler/typecheck/TcErrors.hs
+++ b/compiler/typecheck/TcErrors.hs
@@ -178,7 +178,7 @@ report_unsolved mb_binds_var err_as_warn type_errors expr_holes type_holes wante
              free_tvs = tyCoVarsOfWC wanted
 
        ; traceTc "reportUnsolved (after zonking and tidying):" $
-         vcat [ pprVarSet pprTvBndrs free_tvs
+         vcat [ pprVarSet free_tvs pprTvBndrs
               , ppr wanted ]
 
        ; warn_redundant <- woptM Opt_WarnRedundantConstraints
diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs
index 36aeb5087a..db7a5f998d 100644
--- a/compiler/typecheck/TcHsSyn.hs
+++ b/compiler/typecheck/TcHsSyn.hs
@@ -65,6 +65,7 @@ import SrcLoc
 import Bag
 import Outputable
 import Util
+import UniqFM
 
 import Control.Monad
 import Data.List  ( partition )
@@ -214,7 +215,7 @@ data ZonkEnv
         -- Is only consulted lazily; hence knot-tying
 
 instance Outputable ZonkEnv where
-  ppr (ZonkEnv _ _ty_env var_env) = vcat (map ppr (varEnvElts var_env))
+  ppr (ZonkEnv _ _ty_env var_env) = pprUFM var_env (vcat . map ppr)
 
 
 -- The EvBinds have to already be zonked, but that's usually the case.
diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs
index bb3056b30d..fa9216decc 100644
--- a/compiler/typecheck/TcRnDriver.hs
+++ b/compiler/typecheck/TcRnDriver.hs
@@ -2428,7 +2428,7 @@ pprTcGblEnv (TcGblEnv { tcg_type_env  = type_env,
          , vcat (map ppr rules)
          , vcat (map ppr vects)
          , text "Dependent modules:" <+>
-                ppr (sortBy cmp_mp $ eltsUFM (imp_dep_mods imports))
+                pprUFM (imp_dep_mods imports) (ppr . sortBy cmp_mp)
          , text "Dependent packages:" <+>
                 ppr (sortBy stableUnitIdCmp $ imp_dep_pkgs imports)]
   where         -- The two uses of sortBy are just to reduce unnecessary
diff --git a/compiler/utils/UniqFM.hs b/compiler/utils/UniqFM.hs
index 2ff635268d..f49dabc904 100644
--- a/compiler/utils/UniqFM.hs
+++ b/compiler/utils/UniqFM.hs
@@ -349,12 +349,12 @@ pprUniqFM ppr_elt ufm
 -- The order of variables is non-deterministic and for pretty-printing that
 -- shouldn't be a problem.
 -- Having this function helps contain the non-determinism created with
--- eltsUFM.
-pprUFM :: ([a] -> SDoc) -- ^ The pretty printing function to use on the elements
-       -> UniqFM a      -- ^ The things to be pretty printed
+-- nonDetEltsUFM.
+pprUFM :: UniqFM a      -- ^ The things to be pretty printed
+       -> ([a] -> SDoc) -- ^ The pretty printing function to use on the elements
        -> SDoc          -- ^ 'SDoc' where the things have been pretty
                         -- printed
-pprUFM pp ufm = pp (nonDetEltsUFM ufm)
+pprUFM ufm pp = pp (nonDetEltsUFM ufm)
 
 -- | Determines the pluralisation suffix appropriate for the length of a set
 -- in the same way that plural from Outputable does for lists.