[commit: ghc] master: Make tyConsOfType return a (NameEnv TyCon) rather than [TyCon] (e7523fe)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/e7523fe73e938956aa31ad07a97e9f8ef87a4e0c/ghc

>---------------------------------------------------------------

commit e7523fe73e938956aa31ad07a97e9f8ef87a4e0c
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Thu Nov 6 13:18:16 2014 +0000

    Make tyConsOfType return a (NameEnv TyCon) rather than [TyCon]
    
    A little refactoring


>---------------------------------------------------------------

e7523fe73e938956aa31ad07a97e9f8ef87a4e0c
 compiler/basicTypes/NameEnv.lhs  |  8 ++++++--
 compiler/typecheck/TcFlatten.lhs |  2 +-
 compiler/typecheck/TcTyDecls.lhs | 13 +++++--------
 compiler/types/Type.lhs          |  4 ++--
 4 files changed, 14 insertions(+), 13 deletions(-)

diff --git a/compiler/basicTypes/NameEnv.lhs b/compiler/basicTypes/NameEnv.lhs
index 1fe908b..f86e174 100644
--- a/compiler/basicTypes/NameEnv.lhs
+++ b/compiler/basicTypes/NameEnv.lhs
@@ -15,10 +15,10 @@ module NameEnv (
         emptyNameEnv, unitNameEnv, nameEnvElts, nameEnvUniqueElts,
         extendNameEnv_C, extendNameEnv_Acc, extendNameEnv,
         extendNameEnvList, extendNameEnvList_C,
-        foldNameEnv, filterNameEnv,
+        foldNameEnv, filterNameEnv, anyNameEnv,
         plusNameEnv, plusNameEnv_C, alterNameEnv,
         lookupNameEnv, lookupNameEnv_NF, delFromNameEnv, delListFromNameEnv,
-        elemNameEnv, mapNameEnv,
+        elemNameEnv, mapNameEnv, disjointNameEnv,
 
         -- ** Dependency analysis
         depAnal
@@ -88,7 +88,9 @@ lookupNameEnv      :: NameEnv a -> Name -> Maybe a
 lookupNameEnv_NF   :: NameEnv a -> Name -> a
 foldNameEnv        :: (a -> b -> b) -> b -> NameEnv a -> b
 filterNameEnv      :: (elt -> Bool) -> NameEnv elt -> NameEnv elt
+anyNameEnv         :: (elt -> Bool) -> NameEnv elt -> Bool
 mapNameEnv         :: (elt1 -> elt2) -> NameEnv elt1 -> NameEnv elt2
+disjointNameEnv    :: NameEnv a -> NameEnv a -> Bool
 
 nameEnvElts x         = eltsUFM x
 emptyNameEnv          = emptyUFM
@@ -110,6 +112,8 @@ extendNameEnvList_C x y z = addListToUFM_C x y z
 delFromNameEnv x y      = delFromUFM x y
 delListFromNameEnv x y  = delListFromUFM x y
 filterNameEnv x y       = filterUFM x y
+anyNameEnv f x          = foldUFM ((||) . f) False x
+disjointNameEnv x y     = isNullUFM (intersectUFM x y)
 
 lookupNameEnv_NF env n = expectJust "lookupNameEnv_NF" (lookupNameEnv env n)
 \end{code}
diff --git a/compiler/typecheck/TcFlatten.lhs b/compiler/typecheck/TcFlatten.lhs
index 02783a9..dcfdd1b 100644
--- a/compiler/typecheck/TcFlatten.lhs
+++ b/compiler/typecheck/TcFlatten.lhs
@@ -626,7 +626,7 @@ flatten fmode (TyConApp tc tys)
   | Just (tenv, rhs, tys') <- tcExpandTyCon_maybe tc tys
   , let expanded_ty = mkAppTys (substTy (mkTopTvSubst tenv) rhs) tys'
   = case fe_mode fmode of
-      FM_FlattenAll | any isSynFamilyTyCon (tyConsOfType rhs)
+      FM_FlattenAll | anyNameEnv isSynFamilyTyCon (tyConsOfType rhs)
                    -> flatten fmode expanded_ty
                     | otherwise
                    -> flattenTyConApp fmode tc tys
diff --git a/compiler/typecheck/TcTyDecls.lhs b/compiler/typecheck/TcTyDecls.lhs
index ee26641..f2c2395 100644
--- a/compiler/typecheck/TcTyDecls.lhs
+++ b/compiler/typecheck/TcTyDecls.lhs
@@ -422,14 +422,11 @@ calcRecFlags boot_details is_boot mrole_env tyclss
     nt_edges = [(t, mk_nt_edges t) | t <- new_tycons]
 
     mk_nt_edges nt      -- Invariant: nt is a newtype
-        = concatMap (mk_nt_edges1 nt) (tyConsOfType (new_tc_rhs nt))
+        = [ tc | tc <- nameEnvElts (tyConsOfType (new_tc_rhs nt))
                         -- tyConsOfType looks through synonyms
-
-    mk_nt_edges1 _ tc
-        | tc `elem` new_tycons = [tc]           -- Loop
-                -- At this point we know that either it's a local *data* type,
-                -- or it's imported.  Either way, it can't form part of a newtype cycle
-        | otherwise = []
+               , tc `elem` new_tycons ]
+           -- If not (tc `elem` new_tycons) we know that either it's a local *data* type,
+           -- or it's imported.  Either way, it can't form part of a newtype cycle
 
         --------------- Product types ----------------------
     prod_loop_breakers = mkNameSet (findLoopBreakers prod_edges)
@@ -439,7 +436,7 @@ calcRecFlags boot_details is_boot mrole_env tyclss
     mk_prod_edges tc    -- Invariant: tc is a product tycon
         = concatMap (mk_prod_edges1 tc) (dataConOrigArgTys (head (tyConDataCons tc)))
 
-    mk_prod_edges1 ptc ty = concatMap (mk_prod_edges2 ptc) (tyConsOfType ty)
+    mk_prod_edges1 ptc ty = concatMap (mk_prod_edges2 ptc) (nameEnvElts (tyConsOfType ty))
 
     mk_prod_edges2 ptc tc
         | tc `elem` prod_tycons   = [tc]                -- Local product
diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs
index 8cad95e..01ec26c 100644
--- a/compiler/types/Type.lhs
+++ b/compiler/types/Type.lhs
@@ -662,9 +662,9 @@ repType ty
 -- | All type constructors occurring in the type; looking through type
 --   synonyms, but not newtypes.
 --  When it finds a Class, it returns the class TyCon.
-tyConsOfType :: Type -> [TyCon]
+tyConsOfType :: Type -> NameEnv TyCon
 tyConsOfType ty
-  = nameEnvElts (go ty)
+  = go ty
   where
      go :: Type -> NameEnv TyCon  -- The NameEnv does duplicate elim
      go ty | Just ty' <- tcView ty = go ty'