Make tyConsOfType return a (NameEnv TyCon) rather than [TyCon]
authorSimon Peyton Jones <simonpj@microsoft.com>
Thu, 6 Nov 2014 13:18:16 +0000 (13:18 +0000)
committerSimon Peyton Jones <simonpj@microsoft.com>
Thu, 6 Nov 2014 15:42:23 +0000 (15:42 +0000)
A little refactoring

compiler/basicTypes/NameEnv.lhs
compiler/typecheck/TcFlatten.lhs
compiler/typecheck/TcTyDecls.lhs
compiler/types/Type.lhs

index 1fe908b..f86e174 100644 (file)
@@ -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}
index 02783a9..dcfdd1b 100644 (file)
@@ -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
index ee26641..f2c2395 100644 (file)
@@ -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
index 8cad95e..01ec26c 100644 (file)
@@ -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'