Expose tcTyConsOfType as Types.tyConsOfType

and add related function tyConsOfTyCon.

4 files changed, 40 insertions, 35 deletions

diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs
index 51a096b10f..c3872eec29 100644
--- a/compiler/basicTypes/DataCon.lhs
+++ b/compiler/basicTypes/DataCon.lhs
@@ -39,6 +39,8 @@ module DataCon (
 
 	splitDataProductType_maybe,
 
+        tyConsOfTyCon,
+
 	-- ** Predicates on DataCons
 	isNullarySrcDataCon, isNullaryRepDataCon, isTupleDataCon, isUnboxedTupleCon,
 	isVanillaDataCon, classDataCon, dataConCannotMatch,
@@ -70,6 +72,7 @@ import BasicTypes
 import FastString
 import Module
 import VarEnv
+import NameEnv
 
 import qualified Data.Data as Data
 import qualified Data.Typeable
@@ -1125,4 +1128,15 @@ splitDataProductType_maybe ty
   = Just (tycon, ty_args, con, dataConInstArgTys con ty_args)
   | otherwise
   = Nothing
+
+-- | All type constructors used in the definition of this type constructor,
+--   recursively. This is used to find out all the type constructors whose data
+--   constructors need to be in scope to be allowed to safely coerce under this
+--   type constructor in Safe Haskell mode.
+tyConsOfTyCon :: TyCon -> [TyCon]
+tyConsOfTyCon tc = nameEnvElts (add tc emptyNameEnv)
+  where
+     go env tc = foldr add env (tyConDataCons tc >>= dataConOrigArgTys >>= tyConsOfType)
+     add tc env | tyConName tc `elemNameEnv` env = env
+                | otherwise = go (extendNameEnv env (tyConName tc) tc) tc
 \end{code}
diff --git a/compiler/typecheck/TcTyDecls.lhs b/compiler/typecheck/TcTyDecls.lhs
index 4f3971b7d7..d873b250fa 100644
--- a/compiler/typecheck/TcTyDecls.lhs
+++ b/compiler/typecheck/TcTyDecls.lhs
@@ -422,7 +422,7 @@ calcRecFlags boot_details 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) (tcTyConsOfType (new_tc_rhs nt))
+        = concatMap (mk_nt_edges1 nt) (tyConsOfType (new_tc_rhs nt))
                         -- tyConsOfType looks through synonyms
 
     mk_nt_edges1 _ tc
@@ -439,7 +439,7 @@ calcRecFlags boot_details 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) (tcTyConsOfType ty)
+    mk_prod_edges1 ptc ty = concatMap (mk_prod_edges2 ptc) (tyConsOfType ty)
 
     mk_prod_edges2 ptc tc
         | tc `elem` prod_tycons   = [tc]                -- Local product
@@ -826,34 +826,3 @@ updateRoleEnv name n role
                          else state )
 
 \end{code}
-
-%************************************************************************
-%*                                                                      *
-        Miscellaneous funcions
-%*                                                                      *
-%************************************************************************
-
-These two functions know about type representations, so they could be
-in Type or TcType -- but they are very specialised to this module, so
-I've chosen to put them here.
-
-\begin{code}
-tcTyConsOfType :: Type -> [TyCon]
--- tcTyConsOfType looks through all synonyms, but not through any newtypes.
--- When it finds a Class, it returns the class TyCon.  The reaons it's here
--- (not in Type.lhs) is because it is newtype-aware.
-tcTyConsOfType ty
-  = nameEnvElts (go ty)
-  where
-     go :: Type -> NameEnv TyCon  -- The NameEnv does duplicate elim
-     go ty | Just ty' <- tcView ty = go ty'
-     go (TyVarTy {})               = emptyNameEnv
-     go (LitTy {})                 = emptyNameEnv
-     go (TyConApp tc tys)          = go_tc tc tys
-     go (AppTy a b)                = go a `plusNameEnv` go b
-     go (FunTy a b)                = go a `plusNameEnv` go b
-     go (ForAllTy _ ty)            = go ty
-
-     go_tc tc tys = extendNameEnv (go_s tys) (tyConName tc) tc
-     go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys
-\end{code}
diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs
index 9db0aaa3ee..b2dfe97409 100644
--- a/compiler/types/Type.lhs
+++ b/compiler/types/Type.lhs
@@ -100,6 +100,7 @@ module Type (
         coreView, tcView,
 
         UnaryType, RepType(..), flattenRepType, repType,
+        tyConsOfType,
 
         -- * Type representation for the code generator
         typePrimRep, typeRepArity,
@@ -154,6 +155,7 @@ import TypeRep
 import Var
 import VarEnv
 import VarSet
+import NameEnv
 
 import Class
 import TyCon
@@ -644,6 +646,26 @@ repType ty
 
     go _ ty = UnaryRep 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 ty
+  = nameEnvElts (go ty)
+  where
+     go :: Type -> NameEnv TyCon  -- The NameEnv does duplicate elim
+     go ty | Just ty' <- tcView ty = go ty'
+     go (TyVarTy {})               = emptyNameEnv
+     go (LitTy {})                 = emptyNameEnv
+     go (TyConApp tc tys)          = go_tc tc tys
+     go (AppTy a b)                = go a `plusNameEnv` go b
+     go (FunTy a b)                = go a `plusNameEnv` go b
+     go (ForAllTy _ ty)            = go ty
+
+     go_tc tc tys = extendNameEnv (go_s tys) (tyConName tc) tc
+     go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys
+
 -- ToDo: this could be moved to the code generator, using splitTyConApp instead
 -- of inspecting the type directly.
 
diff --git a/compiler/vectorise/Vectorise/Type/Classify.hs b/compiler/vectorise/Vectorise/Type/Classify.hs
index 6d7ed06c00..56b8da5153 100644
--- a/compiler/vectorise/Vectorise/Type/Classify.hs
+++ b/compiler/vectorise/Vectorise/Type/Classify.hs
@@ -21,10 +21,10 @@ where
 import NameSet
 import UniqSet
 import UniqFM
-import DataCon
+import DataCon hiding (tyConsOfTyCon)
 import TyCon
 import TypeRep
-import Type
+import Type hiding (tyConsOfType)
 import PrelNames
 import Digraph