import TypeRep ( Type(..), TyNote(..), PredType(..) ) -- friend
import HsSyn ( TyClDecl(..), HsPred(..), LTyClDecl, isClassDecl )
import RnHsSyn ( extractHsTyNames )
-import Type ( predTypeRep )
-import HscTypes ( TyThing(..) )
+import Type ( predTypeRep, tcView )
+import HscTypes ( TyThing(..), ModDetails(..) )
import TyCon ( TyCon, ArgVrcs, tyConArity, tyConDataCons, tyConTyVars,
- getSynTyConDefn, isSynTyCon, isAlgTyCon, isHiBootTyCon,
+ synTyConDefn, isSynTyCon, isAlgTyCon,
tyConName, isNewTyCon, isProductTyCon, tyConArgVrcs, newTyConRhs )
import Class ( classTyCon )
import DataCon ( dataConOrigArgTys )
where
go :: Type -> NameEnv TyCon -- The NameEnv does duplicate elim
go (TyVarTy v) = emptyNameEnv
- go (TyConApp tc tys) = go_tc tc tys -- See note (a)
- go (NewTcApp tc tys) = go_s tys -- Ignore tycon
+ 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 (PredTy (IParam _ ty)) = go ty
go (PredTy (ClassP cls tys)) = go_s tys -- Ignore class
- go (NoteTy (SynNote ty) _) = go ty -- Don't look through it!
- go (NoteTy other ty) = go ty
+ go (NoteTy _ ty) = go ty
go (ForAllTy _ ty) = go ty
- -- Note (a): the unexpanded branch of a SynNote has a
- -- TyConApp for the synonym, so the tc of
- -- a TyConApp must be tested for possible synonyms
-
go_tc tc tys | isSynTyCon tc = extendNameEnv (go_s tys) (tyConName tc) tc
| otherwise = go_s tys
go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys
provided the invariant is maintained.
A newtype M.T is defined to be "recursive" iff
- (a) its rhs mentions an abstract (hi-boot) TyCon
- or (b) one can get from T's rhs to T via type
+ (a) it is declared in an hi-boot file (see RdrHsSyn.hsIfaceDecl)
+ (b) it is declared in a source file, but that source file has a
+ companion hi-boot file which declares the type
+ or (c) one can get from T's rhs to T via type
synonyms, or non-recursive newtypes *in M*
- e.g. newtype T = MkT (T -> Int)
+ e.g. newtype T = MkT (T -> Int)
-(a) is conservative; it assumes that the hi-boot type can loop
- around to T. That's why in (b) we can restrict attention
+(a) is conservative; declarations in hi-boot files are always
+ made loop breakers. That's why in (b) we can restrict attention
to tycons in M, because any loops through newtypes outside M
will be broken by those newtypes
+(b) ensures that a newtype is not treated as a loop breaker in one place
+and later as a non-loop-breaker. This matters in GHCi particularly, when
+a newtype T might be embedded in many types in the environment, and then
+T's source module is compiled. We don't want T's recursiveness to change.
+
+The "recursive" flag for algebraic data types is irrelevant (never consulted)
+for types with more than one constructor.
An algebraic data type M.T is "recursive" iff
it has just one constructor, and
- (a) its arg types mention an abstract (hi-boot) TyCon
- or (b) one can get from its arg types to T via type synonyms,
+ (a) it is declared in an hi-boot file (see RdrHsSyn.hsIfaceDecl)
+ (b) it is declared in a source file, but that source file has a
+ companion hi-boot file which declares the type
+ or (c) one can get from its arg types to T via type synonyms,
or by non-recursive newtypes or non-recursive product types in M
- e.g. data T = MkT (T -> Int) Bool
+ e.g. data T = MkT (T -> Int) Bool
+Just like newtype in fact
A type synonym is recursive if one can get from its
right hand side back to it via type synonyms. (This is
compiled, plus the outer structure of directly-mentioned types.
\begin{code}
-calcRecFlags :: [TyThing] -> (Name -> RecFlag)
-calcRecFlags tyclss
+calcRecFlags :: ModDetails -> [TyThing] -> (Name -> RecFlag)
+-- The 'boot_names' are the things declared in M.hi-boot, if M is the current module.
+-- Any type constructors in boot_names are automatically considered loop breakers
+calcRecFlags boot_details tyclss
= is_rec
where
is_rec n | n `elemNameSet` rec_names = Recursive
| otherwise = NonRecursive
- rec_names = nt_loop_breakers `unionNameSets` prod_loop_breakers
+ boot_name_set = md_exports boot_details
+ rec_names = boot_name_set `unionNameSets`
+ nt_loop_breakers `unionNameSets`
+ prod_loop_breakers
- all_tycons = map getTyCon tyclss -- Recursion of newtypes/data types
- -- can happen via the class TyCon
+ all_tycons = [ tc | tycls <- tyclss,
+ -- Recursion of newtypes/data types can happen via
+ -- the class TyCon, so tyclss includes the class tycons
+ let tc = getTyCon tycls,
+ not (tyConName tc `elemNameSet` boot_name_set) ]
+ -- Remove the boot_name_set because they are going
+ -- to be loop breakers regardless.
-------------------------------------------------
-- NOTE
mk_nt_edges1 nt tc
| tc `elem` new_tycons = [tc] -- Loop
- | isHiBootTyCon tc = [nt] -- Make it self-recursive if
- -- it mentions an hi-boot TyCon
- -- 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 cycle
+ -- 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 = []
--------------- Product types ----------------------
| tc `elem` new_tycons = if is_rec_nt tc -- Local newtype
then []
else mk_prod_edges1 ptc (new_tc_rhs tc)
- | isHiBootTyCon tc = [ptc] -- Make it self-recursive if
- -- it mentions an hi-boot TyCon
-- At this point we know that either it's a local non-product data type,
-- or it's imported. Either way, it can't form part of a cycle
| otherwise = []
= nameEnvElts (go ty)
where
go :: Type -> NameEnv TyCon -- The NameEnv does duplicate elim
- go (TyVarTy v) = emptyNameEnv
- go (TyConApp tc tys) = go_tc tc tys
- go (NewTcApp 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 (PredTy (IParam _ ty)) = go ty
- go (PredTy (ClassP cls tys)) = go_tc (classTyCon cls) tys
- go (NoteTy _ ty) = go ty
- go (ForAllTy _ ty) = go ty
+ go ty | Just ty' <- tcView ty = go ty'
+ go (TyVarTy v) = 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 (PredTy (IParam _ ty)) = go ty
+ go (PredTy (ClassP cls tys)) = go_tc (classTyCon cls) tys
+ go (ForAllTy _ ty) = go ty
go_tc tc tys = extendNameEnv (go_s tys) (tyConName tc) tc
go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys
argtys = concatMap dataConOrigArgTys data_cons -- Rep? or Orig?
tcaoIter oi tc | isSynTyCon tc
- = let (tyvs,ty) = getSynTyConDefn tc
+ = let (tyvs,ty) = synTyConDefn tc
-- we use the already-computed result for tycons not in this SCC
in map (\v -> vrcInTy (lookup oi) v ty) tyvs
-> Type -- type to check for occ in
-> (Bool,Bool) -- (occurs positively, occurs negatively)
-vrcInTy fao v (NoteTy (SynNote _) ty) = vrcInTy fao v ty
- -- SynTyCon doesn't neccessarily have vrcInfo at this point,
- -- so don't try and use it
-
vrcInTy fao v (NoteTy (FTVNote ftv) ty) = if elemVarSet v ftv
then vrcInTy fao v ty
else (False,False)
pms2 = fao tc
in orVrcs (zipWith timesVrc pms1 pms2)
-vrcInTy fao v (NewTcApp tc tys) = let pms1 = map (vrcInTy fao v) tys
- pms2 = fao tc
- in orVrcs (zipWith timesVrc pms1 pms2)
-
vrcInTy fao v (PredTy st) = vrcInTy fao v (predTypeRep st)
\end{code}
projects / ghc-hetmet.git / blobdiff