[commit: ghc] coercible: Expose tcTyConsOfType as Types.tyConsOfType (638da2f)
git at git.haskell.org
git at git.haskell.org
Fri Sep 13 23:48:19 CEST 2013
Repository : ssh://git@git.haskell.org/ghc
On branch : coercible
Link : http://ghc.haskell.org/trac/ghc/changeset/638da2fecaaaf743c4da7f8e2522f4afc0d8400c/ghc
>---------------------------------------------------------------
commit 638da2fecaaaf743c4da7f8e2522f4afc0d8400c
Author: Joachim Breitner <mail at joachim-breitner.de>
Date: Fri Sep 13 14:17:40 2013 +0200
Expose tcTyConsOfType as Types.tyConsOfType
and add related function tyConsOfTyCon.
>---------------------------------------------------------------
638da2fecaaaf743c4da7f8e2522f4afc0d8400c
compiler/basicTypes/DataCon.lhs | 14 ++++++++++
compiler/typecheck/TcTyDecls.lhs | 35 ++-----------------------
compiler/types/Type.lhs | 22 ++++++++++++++++
compiler/vectorise/Vectorise/Type/Classify.hs | 4 +--
4 files changed, 40 insertions(+), 35 deletions(-)
diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs
index 51a096b..c3872ee 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 4f3971b..d873b25 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 9db0aaa..b2dfe97 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 6d7ed06..56b8da5 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
More information about the ghc-commits
mailing list