\begin{code}
module TcTyDecls(
calcTyConArgVrcs,
- calcRecFlags, calcCycleErrs,
- newTyConRhs
+ calcRecFlags,
+ calcClassCycles, calcSynCycles
) where
#include "HsVersions.h"
import TypeRep ( Type(..), TyNote(..), PredType(..) ) -- friend
-import HsSyn ( TyClDecl(..), HsPred(..), LTyClDecl )
+import HsSyn ( TyClDecl(..), HsPred(..), LTyClDecl, isClassDecl )
import RnHsSyn ( extractHsTyNames )
-import Type ( predTypeRep )
-import BuildTyCl ( newTyConRhs )
-import HscTypes ( TyThing(..) )
+import Type ( predTypeRep, tcView )
+import HscTypes ( TyThing(..), ModDetails(..) )
import TyCon ( TyCon, ArgVrcs, tyConArity, tyConDataCons, tyConTyVars,
- getSynTyConDefn, isSynTyCon, isAlgTyCon, isHiBootTyCon,
- tyConName, isNewTyCon, isProductTyCon, tyConArgVrcs )
+ synTyConDefn, isSynTyCon, isAlgTyCon,
+ tyConName, isNewTyCon, isProductTyCon, tyConArgVrcs, newTyConRhs )
import Class ( classTyCon )
-import DataCon ( dataConRepArgTys, dataConOrigArgTys )
+import DataCon ( dataConOrigArgTys )
import Var ( TyVar )
import VarSet
import Name ( Name, isTyVarName )
import NameSet
import Digraph ( SCC(..), stronglyConnComp, stronglyConnCompR )
import BasicTypes ( RecFlag(..) )
-import SrcLoc ( Located(..) )
+import SrcLoc ( Located(..), unLoc )
import Outputable
\end{code}
%* *
%************************************************************************
+Checking for class-decl loops is easy, because we don't allow class decls
+in interface files.
+
+We allow type synonyms in hi-boot files, but we *trust* hi-boot 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:
The main disadvantage is that a cycle that goes via a type synonym in an
.hi-boot file can lead the compiler into a loop, because it assumes that cycles
-only occur in source code. But hi-boot files are trusted anyway, so this isn't
-much worse than (say) a kind error.
+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
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
---------------------------------------- END NOTE ]
\begin{code}
-calcCycleErrs :: [LTyClDecl Name] -> ([[Name]], -- Recursive type synonym groups
- [[Name]]) -- Ditto classes
-calcCycleErrs decls
- = (findCyclics syn_edges, findCyclics cls_edges)
+calcSynCycles :: [LTyClDecl Name] -> [SCC (LTyClDecl Name)]
+calcSynCycles decls
+ = stronglyConnComp syn_edges
where
- --------------- Type synonyms ----------------------
- syn_edges = [ (name, mk_syn_edges rhs) |
- L _ (TySynonym { tcdLName = L _ name,
- tcdSynRhs = rhs }) <- decls ]
+ 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) ]
- --------------- Classes ----------------------
- cls_edges = [ (name, mk_cls_edges ctxt) |
- L _ (ClassDecl { tcdLName = L _ name,
- tcdCtxt = L _ ctxt }) <- decls ]
+
+calcClassCycles :: [LTyClDecl Name] -> [[LTyClDecl Name]]
+calcClassCycles decls
+ = [decls | CyclicSCC decls <- stronglyConnComp 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}
%* *
%************************************************************************
+For newtypes, we label some as "recursive" such that
+
+ INVARIANT: there is no cycle of non-recursive 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) 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
Hi-boot types
~~~~~~~~~~~~~
-A data type read from an hi-boot file will have an Unknown in its data constructors,
+A data type read from an hi-boot 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
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
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 (newTyConRhs nt))
+ = 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
- | 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` prod_tycons = [tc] -- Local product
| tc `elem` new_tycons = if is_rec_nt tc -- Local newtype
then []
- else mk_prod_edges1 ptc (newTyConRhs tc)
- | isHiBootTyCon tc = [ptc] -- Make it self-recursive if
- -- it mentions an hi-boot TyCon
+ 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
+
getTyCon (ATyCon tc) = tc
getTyCon (AClass cl) = classTyCon cl
go edges = [ name
| CyclicSCC ((tc,_,_) : edges') <- stronglyConnCompR edges,
name <- tyConName tc : go edges']
-
-findCyclics :: [(Name,[Name])] -> [[Name]]
-findCyclics deps
- = [names | CyclicSCC names <- stronglyConnComp edges]
- where
- edges = [(name,name,ds) | (name,ds) <- deps]
\end{code}
These two functions know about type representations, so they could be
= 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
where
data_cons = tyConDataCons tc
vs = tyConTyVars tc
- argtys = concatMap dataConRepArgTys data_cons -- Rep? or Orig?
+ 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