%
% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 19921999
%
Analysis functions over data types. Specficially, detecting recursive types.
This stuff is only used for sourcecode decls; it's recorded in interface
files for imported data types.
\begin{code}
module TcTyDecls(
calcRecFlags,
calcClassCycles, calcSynCycles
) where
#include "HsVersions.h"
import TypeRep
import HsSyn
import RnHsSyn
import Type
import HscTypes
import TyCon
import Class
import DataCon
import Name
import NameEnv
import NameSet
import Digraph
import BasicTypes
import SrcLoc
import Outputable
import Util ( isSingleton )
import Data.List
\end{code}
%************************************************************************
%* *
Cycles in class and type synonym declarations
%* *
%************************************************************************
Checking for classdecl loops is easy, because we don't allow class decls
in interface files.
We allow type synonyms in hiboot files, but we *trust* hiboot 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.
Main reasons:
a) Otherwise we'd need a special function to extract typesynonym tycons
from a type, whereas we have extractHsTyNames already
b) If we checked for type synonym loops after building the TyCon, we
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 typesynonym rhs could have foralls 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.
The main disadvantage is that a cycle that goes via a type synonym in an
.hiboot file can lead the compiler into a loop, because it assumes that cycles
only occur entirely within the source code of the module being compiled.
But hiboot 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
We'd also need to add back in this definition
synTyConsOfType :: Type -> [TyCon]
synTyConsOfType ty
= nameEnvElts (go ty)
where
go :: Type -> NameEnv TyCon
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
go (ForAllTy _ ty) = go ty
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
\begin{code}
calcSynCycles :: [LTyClDecl Name] -> [SCC (LTyClDecl Name)]
calcSynCycles decls
= stronglyConnCompFromEdgedVertices syn_edges
where
syn_edges = [ (ldecl, unLoc (tcdLName decl),
mk_syn_edges (tcdSynRhs decl))
| ldecl@(L _ decl) <- decls ]
mk_syn_edges rhs = [ tc | tc <- nameSetToList (extractHsTyNames rhs),
not (isTyVarName tc) ]
calcClassCycles :: [LTyClDecl Name] -> [[LTyClDecl Name]]
calcClassCycles decls
= [decls | CyclicSCC decls <- stronglyConnCompFromEdgedVertices cls_edges]
where
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}
%************************************************************************
%* *
Deciding which type constructors are recursive
%* *
%************************************************************************
For newtypes, we label some as "recursive" such that
INVARIANT: there is no cycle of nonrecursive newtypes
In any loop, only one newtype need be marked as recursive; it is
a "loop breaker". Labelling more than necessary as recursive is OK,
provided the invariant is maintained.
A newtype M.T is defined to be "recursive" iff
(a) it is declared in an hiboot file (see RdrHsSyn.hsIfaceDecl)
(b) it is declared in a source file, but that source file has a
companion hiboot file which declares the type
or (c) one can get from T's rhs to T via type
synonyms, or nonrecursive newtypes *in M*
e.g. newtype T = MkT (T -> Int)
(a) is conservative; declarations in hiboot 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 nonloopbreaker. 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) it is declared in an hiboot file (see RdrHsSyn.hsIfaceDecl)
(b) it is declared in a source file, but that source file has a
companion hiboot file which declares the type
or (c) one can get from its arg types to T via type synonyms,
or by nonrecursive newtypes or nonrecursive product types in M
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
reported as an error.)
A class is recursive if one can get from its superclasses
back to it. (This is an error too.)
Hiboot types
~~~~~~~~~~~~~
A data type read from an hiboot file will have an AbstractTyCon as its AlgTyConRhs
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
module Baz where
import Foo( T )
newtype S = MkS T
then we mark S as recursive, just in case. What that means is that if we see
import Baz( S )
newtype R = MkR S
then we don't need to look inside S to compute R's recursiveness. Since S is imported
(not from an hiboot file), one cannot get from R back to S except via an hiboot file,
and that means that some data type will be marked recursive along the way. So R is
unconditionly nonrecursive (i.e. there'll be a loop breaker elsewhere if necessary)
This in turn means that we grovel through fewer interface files when computing
recursiveness, because we need only look at the type decls in the module being
compiled, plus the outer structure of directlymentioned types.
\begin{code}
calcRecFlags :: ModDetails -> [TyThing] -> (Name -> RecFlag)
calcRecFlags boot_details tyclss
= is_rec
where
is_rec n | n `elemNameSet` rec_names = Recursive
| otherwise = NonRecursive
boot_name_set = availsToNameSet (md_exports boot_details)
rec_names = boot_name_set `unionNameSets`
nt_loop_breakers `unionNameSets`
prod_loop_breakers
all_tycons = [ tc | tycls <- tyclss,
let tc = getTyCon tycls,
not (tyConName tc `elemNameSet` boot_name_set) ]
single_con_tycons = filter (isSingleton . tyConDataCons) all_tycons
(new_tycons, prod_tycons) = partition isNewTyCon single_con_tycons
nt_loop_breakers = mkNameSet (findLoopBreakers nt_edges)
is_rec_nt tc = tyConName tc `elemNameSet` nt_loop_breakers
nt_edges = [(t, mk_nt_edges t) | t <- new_tycons]
mk_nt_edges nt
= concatMap (mk_nt_edges1 nt) (tcTyConsOfType (new_tc_rhs nt))
mk_nt_edges1 _ tc
| tc `elem` new_tycons = [tc]
| otherwise = []
prod_loop_breakers = mkNameSet (findLoopBreakers prod_edges)
prod_edges = [(tc, mk_prod_edges tc) | tc <- prod_tycons]
mk_prod_edges tc
= concatMap (mk_prod_edges1 tc) (dataConOrigArgTys (head (tyConDataCons tc)))
mk_prod_edges1 ptc ty = concatMap (mk_prod_edges2 ptc) (tcTyConsOfType ty)
mk_prod_edges2 ptc tc
| tc `elem` prod_tycons = [tc]
| tc `elem` new_tycons = if is_rec_nt tc
then []
else mk_prod_edges1 ptc (new_tc_rhs tc)
| otherwise = []
new_tc_rhs :: TyCon -> Type
new_tc_rhs tc = snd (newTyConRhs tc)
getTyCon :: TyThing -> TyCon
getTyCon (ATyCon tc) = tc
getTyCon (AClass cl) = classTyCon cl
getTyCon _ = panic "getTyCon"
findLoopBreakers :: [(TyCon, [TyCon])] -> [Name]
findLoopBreakers deps
= go [(tc,tc,ds) | (tc,ds) <- deps]
where
go edges = [ name
| CyclicSCC ((tc,_,_) : edges') <- stronglyConnCompFromEdgedVerticesR edges,
name <- tyConName tc : go edges']
\end{code}
These two functions know about type representations, so they could be
in Type or TcType
I've chosen to put them here.
\begin{code}
tcTyConsOfType :: Type -> [TyCon]
tcTyConsOfType ty
= nameEnvElts (go ty)
where
go :: Type -> NameEnv TyCon
go ty | Just ty' <- tcView ty = go ty'
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 (PredTy (IParam _ ty)) = go ty
go (PredTy (ClassP cls tys)) = go_tc (classTyCon cls) tys
go (ForAllTy _ ty) = go ty
go _ = panic "tcTyConsOfType"
go_tc tc tys = extendNameEnv (go_s tys) (tyConName tc) tc
go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys
\end{code}