%************************************************************************
Checking for class-decl loops is easy, because we don't allow class decls
in interface files.
%************************************************************************
Checking for class-decl loops is easy, because we don't allow class decls
in interface files.
so we don't check for loops that involve them. So we only look for synonym
loops in the module being compiled.
We check for type synonym and class cycles on the *source* code.
so we don't check for loops that involve them. So we only look for synonym
loops in the module being compiled.
We check for type synonym and class cycles on the *source* code.
- can't do a hoistForAllTys on the type synonym rhs, (else we fall into
- a black hole) which seems unclean. Apart from anything else, it'd mean
- that a type-synonym rhs could have for-alls to the right of an arrow,
- which means adding new cases to the validity checker
+ can't do a hoistForAllTys on the type synonym rhs, (else we fall into
+ a black hole) which seems unclean. Apart from anything else, it'd mean
+ that a type-synonym rhs could have for-alls to the right of an arrow,
+ which means adding new cases to the validity checker
- Indeed, in general, checking for cycles beforehand means we need to
- be less careful about black holes through synonym cycles.
+ Indeed, in general, checking for cycles beforehand means we need to
+ be less careful about black holes through synonym cycles.
-only occur entirely within the source code of the module being compiled.
-But hi-boot files are trusted anyway, so this isn't much worse than (say)
+only occur entirely within the source code of the module being compiled.
+But hi-boot files are trusted anyway, so this isn't much worse than (say)
a kind error.
[ NOTE ----------------------------------------------
If we reverse this decision, this comment came from tcTyDecl1, and should
go back there
a kind error.
[ NOTE ----------------------------------------------
If we reverse this decision, this comment came from tcTyDecl1, and should
go back there
- -- dsHsType, not tcHsKindedType, to avoid a loop. tcHsKindedType does hoisting,
- -- which requires looking through synonyms... and therefore goes into a loop
- -- on (erroneously) recursive synonyms.
- -- Solution: do not hoist synonyms, because they'll be hoisted soon enough
- -- when they are substituted
+ -- dsHsType, not tcHsKindedType, to avoid a loop. tcHsKindedType does hoisting,
+ -- which requires looking through synonyms... and therefore goes into a loop
+ -- on (erroneously) recursive synonyms.
+ -- Solution: do not hoist synonyms, because they'll be hoisted soon enough
+ -- when they are substituted
- 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_s tys -- Ignore class
- go (NoteTy _ ty) = go ty
- go (ForAllTy _ 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_s tys -- Ignore class
+ go (ForAllTy _ ty) = go ty
go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys
---------------------------------------- END NOTE ]
\begin{code}
calcSynCycles :: [LTyClDecl Name] -> [SCC (LTyClDecl Name)]
calcSynCycles decls
go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys
---------------------------------------- END NOTE ]
\begin{code}
calcSynCycles :: [LTyClDecl Name] -> [SCC (LTyClDecl Name)]
calcSynCycles decls
- syn_edges = [ (ldecl, unLoc (tcdLName decl),
- mk_syn_edges (tcdSynRhs decl))
- | ldecl@(L _ decl) <- decls ]
+ syn_edges = [ (ldecl, unLoc (tcdLName decl),
+ mk_syn_edges (tcdSynRhs decl))
+ | ldecl@(L _ decl) <- decls ]
- cls_edges = [ (ldecl, unLoc (tcdLName decl),
- mk_cls_edges (unLoc (tcdCtxt decl)))
- | ldecl@(L _ decl) <- decls, isClassDecl decl ]
+ cls_edges = [ (ldecl, unLoc (tcdLName decl),
+ mk_cls_edges (unLoc (tcdCtxt decl)))
+ | ldecl@(L _ decl) <- decls, isClassDecl decl ]
mk_cls_edges ctxt = [ cls | L _ (HsClassP cls _) <- ctxt ]
\end{code}
%************************************************************************
mk_cls_edges ctxt = [ cls | L _ (HsClassP cls _) <- ctxt ]
\end{code}
%************************************************************************
%************************************************************************
For newtypes, we label some as "recursive" such that
%************************************************************************
For newtypes, we label some as "recursive" such that
- (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)
-
-(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
+ (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)
+
+(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
(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
- it has just one constructor, and
- (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
+ it has just one constructor, and
+ (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
and will respond True to isHiBootTyCon. The idea is that we treat these as if one
could get from these types to anywhere. So when we see
and will respond True to isHiBootTyCon. The idea is that we treat these as if one
could get from these types to anywhere. So when we see
then we don't need to look inside S to compute R's recursiveness. Since S is imported
(not from an hi-boot file), one cannot get from R back to S except via an hi-boot file,
and that means that some data type will be marked recursive along the way. So R is
unconditionly non-recursive (i.e. there'll be a loop breaker elsewhere if necessary)
then we don't need to look inside S to compute R's recursiveness. Since S is imported
(not from an hi-boot file), one cannot get from R back to S except via an hi-boot file,
and that means that some data type will be marked recursive along the way. So R is
unconditionly non-recursive (i.e. there'll be a loop breaker elsewhere if necessary)
recursiveness, because we need only look at the type decls in the module being
compiled, plus the outer structure of directly-mentioned types.
recursiveness, because we need only look at the type decls in the module being
compiled, plus the outer structure of directly-mentioned types.
- -- 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
- -- These edge-construction loops rely on
- -- every loop going via tyclss, the types and classes
- -- in the module being compiled. Stuff in interface
- -- files should be correctly marked. If not (e.g. a
- -- type synonym in a hi-boot file) we can get an infinite
- -- loop. We could program round this, but it'd make the code
- -- rather less nice, so I'm not going to do that yet.
-
- --------------- Newtypes ----------------------
+ -- 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
+ -- These edge-construction loops rely on
+ -- every loop going via tyclss, the types and classes
+ -- in the module being compiled. Stuff in interface
+ -- files should be correctly marked. If not (e.g. a
+ -- type synonym in a hi-boot file) we can get an infinite
+ -- loop. We could program round this, but it'd make the code
+ -- rather less nice, so I'm not going to do that yet.
+
+ --------------- Newtypes ----------------------
new_tycons = filter isNewTyConAndNotOpen all_tycons
isNewTyConAndNotOpen tycon = isNewTyCon tycon && not (isOpenTyCon tycon)
nt_loop_breakers = mkNameSet (findLoopBreakers nt_edges)
is_rec_nt tc = tyConName tc `elemNameSet` nt_loop_breakers
new_tycons = filter isNewTyConAndNotOpen all_tycons
isNewTyConAndNotOpen tycon = isNewTyCon tycon && not (isOpenTyCon tycon)
nt_loop_breakers = mkNameSet (findLoopBreakers nt_edges)
is_rec_nt tc = tyConName tc `elemNameSet` nt_loop_breakers
- mk_nt_edges nt -- Invariant: nt is a newtype
- = concatMap (mk_nt_edges1 nt) (tcTyConsOfType (new_tc_rhs nt))
- -- tyConsOfType looks through synonyms
+ mk_nt_edges nt -- Invariant: nt is a newtype
+ = concatMap (mk_nt_edges1 nt) (tcTyConsOfType (new_tc_rhs nt))
+ -- tyConsOfType looks through synonyms
- mk_nt_edges1 nt 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 = []
+ 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 = []
- --------------- Product types ----------------------
- -- The "prod_tycons" are the non-newtype products
- prod_tycons = [tc | tc <- all_tycons,
- not (isNewTyCon tc), isProductTyCon tc]
+ --------------- Product types ----------------------
+ -- The "prod_tycons" are the non-newtype products
+ prod_tycons = [tc | tc <- all_tycons,
+ not (isNewTyCon tc), isProductTyCon tc]
prod_loop_breakers = mkNameSet (findLoopBreakers prod_edges)
prod_edges = [(tc, mk_prod_edges tc) | tc <- prod_tycons]
prod_loop_breakers = mkNameSet (findLoopBreakers prod_edges)
prod_edges = [(tc, mk_prod_edges tc) | tc <- prod_tycons]
-
- mk_prod_edges tc -- Invariant: tc is a product tycon
- = concatMap (mk_prod_edges1 tc) (dataConOrigArgTys (head (tyConDataCons tc)))
+
+ mk_prod_edges tc -- Invariant: tc is a product tycon
+ = concatMap (mk_prod_edges1 tc) (dataConOrigArgTys (head (tyConDataCons tc)))
- mk_prod_edges2 ptc tc
- | tc `elem` prod_tycons = [tc] -- Local product
- | tc `elem` new_tycons = if is_rec_nt tc -- Local newtype
- then []
- else mk_prod_edges1 ptc (new_tc_rhs tc)
- -- 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 = []
-
-new_tc_rhs tc = snd (newTyConRhs tc) -- Ignore the type variables
+ mk_prod_edges2 ptc tc
+ | tc `elem` prod_tycons = [tc] -- Local product
+ | tc `elem` new_tycons = if is_rec_nt tc -- Local newtype
+ then []
+ else mk_prod_edges1 ptc (new_tc_rhs tc)
+ -- 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 = []
+
+new_tc_rhs :: TyCon -> Type
+new_tc_rhs tc = snd (newTyConRhs tc) -- Ignore the type variables
findLoopBreakers :: [(TyCon, [TyCon])] -> [Name]
-- Finds a set of tycons that cut all loops
findLoopBreakers :: [(TyCon, [TyCon])] -> [Name]
-- Finds a set of tycons that cut all loops
= go [(tc,tc,ds) | (tc,ds) <- deps]
where
go edges = [ name
= go [(tc,tc,ds) | (tc,ds) <- deps]
where
go edges = [ name
- | CyclicSCC ((tc,_,_) : edges') <- stronglyConnCompR edges,
- name <- tyConName tc : go edges']
+ | CyclicSCC ((tc,_,_) : edges') <- stronglyConnCompFromEdgedVerticesR edges,
+ name <- tyConName tc : go edges']
-- 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.
-- 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.
= nameEnvElts (go ty)
where
go :: Type -> NameEnv TyCon -- The NameEnv does duplicate elim
go ty | Just ty' <- tcView ty = go ty'
= nameEnvElts (go ty)
where
go :: Type -> NameEnv TyCon -- The NameEnv does duplicate elim
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 (TyVarTy _) = 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_tc tc tys = extendNameEnv (go_s tys) (tyConName tc) tc
go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys
go_tc tc tys = extendNameEnv (go_s tys) (tyConName tc) tc
go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys