Commit 638da2fe authored by Joachim Breitner's avatar Joachim Breitner
Browse files

Expose tcTyConsOfType as Types.tyConsOfType

and add related function tyConsOfTyCon.
parent 1f17065a
......@@ -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}
......@@ -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}
......@@ -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.
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment