Commit e7523fe7 authored by Simon Peyton Jones's avatar Simon Peyton Jones

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

A little refactoring
parent 030abf9e
......@@ -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}
......@@ -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
......
......@@ -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
......
......@@ -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'
......
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