2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1999
5 Analysis functions over data types. Specficially
6 a) detecting recursive types
7 b) computing argument variances
9 This stuff is only used for source-code decls; it's recorded in interface
10 files for imported data types.
17 calcClassCycles, calcSynCycles
20 #include "HsVersions.h"
22 import TypeRep ( Type(..), TyNote(..), PredType(..) ) -- friend
23 import HsSyn ( TyClDecl(..), HsPred(..), LTyClDecl, isClassDecl )
24 import RnHsSyn ( extractHsTyNames )
25 import Type ( predTypeRep )
26 import HscTypes ( TyThing(..) )
27 import TyCon ( TyCon, ArgVrcs, tyConArity, tyConDataCons, tyConTyVars,
28 getSynTyConDefn, isSynTyCon, isAlgTyCon, isHiBootTyCon,
29 tyConName, isNewTyCon, isProductTyCon, tyConArgVrcs, newTyConRhs )
30 import Class ( classTyCon )
31 import DataCon ( dataConOrigArgTys )
34 import Name ( Name, isTyVarName )
37 import Digraph ( SCC(..), stronglyConnComp, stronglyConnCompR )
38 import BasicTypes ( RecFlag(..) )
39 import SrcLoc ( Located(..), unLoc )
44 %************************************************************************
46 Cycles in class and type synonym declarations
48 %************************************************************************
50 Checking for class-decl loops is easy, because we don't allow class decls
53 We allow type synonyms in hi-boot files, but we *trust* hi-boot files,
54 so we don't check for loops that involve them. So we only look for synonym
55 loops in the module being compiled.
57 We check for type synonym and class cycles on the *source* code.
60 a) Otherwise we'd need a special function to extract type-synonym tycons
61 from a type, whereas we have extractHsTyNames already
63 b) If we checked for type synonym loops after building the TyCon, we
64 can't do a hoistForAllTys on the type synonym rhs, (else we fall into
65 a black hole) which seems unclean. Apart from anything else, it'd mean
66 that a type-synonym rhs could have for-alls to the right of an arrow,
67 which means adding new cases to the validity checker
69 Indeed, in general, checking for cycles beforehand means we need to
70 be less careful about black holes through synonym cycles.
72 The main disadvantage is that a cycle that goes via a type synonym in an
73 .hi-boot file can lead the compiler into a loop, because it assumes that cycles
74 only occur entirely within the source code of the module being compiled.
75 But hi-boot files are trusted anyway, so this isn't much worse than (say)
78 [ NOTE ----------------------------------------------
79 If we reverse this decision, this comment came from tcTyDecl1, and should
81 -- dsHsType, not tcHsKindedType, to avoid a loop. tcHsKindedType does hoisting,
82 -- which requires looking through synonyms... and therefore goes into a loop
83 -- on (erroneously) recursive synonyms.
84 -- Solution: do not hoist synonyms, because they'll be hoisted soon enough
85 -- when they are substituted
87 We'd also need to add back in this definition
89 synTyConsOfType :: Type -> [TyCon]
90 -- Does not look through type synonyms at all
91 -- Return a list of synonym tycons
95 go :: Type -> NameEnv TyCon -- The NameEnv does duplicate elim
96 go (TyVarTy v) = emptyNameEnv
97 go (TyConApp tc tys) = go_tc tc tys -- See note (a)
98 go (AppTy a b) = go a `plusNameEnv` go b
99 go (FunTy a b) = go a `plusNameEnv` go b
100 go (PredTy (IParam _ ty)) = go ty
101 go (PredTy (ClassP cls tys)) = go_s tys -- Ignore class
102 go (NoteTy (SynNote ty) _) = go ty -- Don't look through it!
103 go (NoteTy other ty) = go ty
104 go (ForAllTy _ ty) = go ty
106 -- Note (a): the unexpanded branch of a SynNote has a
107 -- TyConApp for the synonym, so the tc of
108 -- a TyConApp must be tested for possible synonyms
110 go_tc tc tys | isSynTyCon tc = extendNameEnv (go_s tys) (tyConName tc) tc
111 | otherwise = go_s tys
112 go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys
113 ---------------------------------------- END NOTE ]
116 calcSynCycles :: [LTyClDecl Name] -> [SCC (LTyClDecl Name)]
118 = stronglyConnComp syn_edges
120 syn_edges = [ (ldecl, unLoc (tcdLName decl),
121 mk_syn_edges (tcdSynRhs decl))
122 | ldecl@(L _ decl) <- decls ]
124 mk_syn_edges rhs = [ tc | tc <- nameSetToList (extractHsTyNames rhs),
125 not (isTyVarName tc) ]
128 calcClassCycles :: [LTyClDecl Name] -> [[LTyClDecl Name]]
129 calcClassCycles decls
130 = [decls | CyclicSCC decls <- stronglyConnComp cls_edges]
132 cls_edges = [ (ldecl, unLoc (tcdLName decl),
133 mk_cls_edges (unLoc (tcdCtxt decl)))
134 | ldecl@(L _ decl) <- decls, isClassDecl decl ]
136 mk_cls_edges ctxt = [ cls | L _ (HsClassP cls _) <- ctxt ]
140 %************************************************************************
142 Deciding which type constructors are recursive
144 %************************************************************************
146 For newtypes, we label some as "recursive" such that
148 INVARIANT: there is no cycle of non-recursive newtypes
150 In any loop, only one newtype need be marked as recursive; it is
151 a "loop breaker". Labelling more than necessary as recursive is OK,
152 provided the invariant is maintained.
154 A newtype M.T is defined to be "recursive" iff
155 (a) it is declared in an hi-boot file (see RdrHsSyn.hsIfaceDecl)
156 (b) it is declared in a source file, but that source file has a
157 companion hi-boot file which declares the type
158 or (c) one can get from T's rhs to T via type
159 synonyms, or non-recursive newtypes *in M*
160 e.g. newtype T = MkT (T -> Int)
162 (a) is conservative; declarations in hi-boot files are always
163 made loop breakers. That's why in (b) we can restrict attention
164 to tycons in M, because any loops through newtypes outside M
165 will be broken by those newtypes
166 (b) ensures that a newtype is not treated as a loop breaker in one place
167 and later as a non-loop-breaker. This matters in GHCi particularly, when
168 a newtype T might be embedded in many types in the environment, and then
169 T's source module is compiled. We don't want T's recursiveness to change.
171 The "recursive" flag for algebraic data types is irrelevant (never consulted)
172 for types with more than one constructor.
174 An algebraic data type M.T is "recursive" iff
175 it has just one constructor, and
176 (a) it is declared in an hi-boot file (see RdrHsSyn.hsIfaceDecl)
177 (b) it is declared in a source file, but that source file has a
178 companion hi-boot file which declares the type
179 or (c) one can get from its arg types to T via type synonyms,
180 or by non-recursive newtypes or non-recursive product types in M
181 e.g. data T = MkT (T -> Int) Bool
182 Just like newtype in fact
184 A type synonym is recursive if one can get from its
185 right hand side back to it via type synonyms. (This is
186 reported as an error.)
188 A class is recursive if one can get from its superclasses
189 back to it. (This is an error too.)
193 A data type read from an hi-boot file will have an AbstractTyCon as its AlgTyConRhs
194 and will respond True to isHiBootTyCon. The idea is that we treat these as if one
195 could get from these types to anywhere. So when we see
198 import {-# SOURCE #-} Foo( T )
201 then we mark S as recursive, just in case. What that means is that if we see
206 then we don't need to look inside S to compute R's recursiveness. Since S is imported
207 (not from an hi-boot file), one cannot get from R back to S except via an hi-boot file,
208 and that means that some data type will be marked recursive along the way. So R is
209 unconditionly non-recursive (i.e. there'll be a loop breaker elsewhere if necessary)
211 This in turn means that we grovel through fewer interface files when computing
212 recursiveness, because we need only look at the type decls in the module being
213 compiled, plus the outer structure of directly-mentioned types.
216 calcRecFlags :: [Name] -> [TyThing] -> (Name -> RecFlag)
217 -- The 'boot_names' are the things declared in M.hi-boot, if M is the current module.
218 -- Any type constructors in boot_names are automatically considered loop breakers
219 calcRecFlags boot_names tyclss
222 is_rec n | n `elemNameSet` rec_names = Recursive
223 | otherwise = NonRecursive
225 boot_name_set = mkNameSet boot_names
226 rec_names = boot_name_set `unionNameSets`
227 nt_loop_breakers `unionNameSets`
230 all_tycons = [ tc | tycls <- tyclss,
231 -- Recursion of newtypes/data types can happen via
232 -- the class TyCon, so tyclss includes the class tycons
233 let tc = getTyCon tycls,
234 not (tyConName tc `elemNameSet` boot_name_set) ]
235 -- Remove the boot_name_set because they are going
236 -- to be loop breakers regardless.
238 -------------------------------------------------
240 -- These edge-construction loops rely on
241 -- every loop going via tyclss, the types and classes
242 -- in the module being compiled. Stuff in interface
243 -- files should be correctly marked. If not (e.g. a
244 -- type synonym in a hi-boot file) we can get an infinite
245 -- loop. We could program round this, but it'd make the code
246 -- rather less nice, so I'm not going to do that yet.
248 --------------- Newtypes ----------------------
249 new_tycons = filter isNewTyCon all_tycons
250 nt_loop_breakers = mkNameSet (findLoopBreakers nt_edges)
251 is_rec_nt tc = tyConName tc `elemNameSet` nt_loop_breakers
252 -- is_rec_nt is a locally-used helper function
254 nt_edges = [(t, mk_nt_edges t) | t <- new_tycons]
256 mk_nt_edges nt -- Invariant: nt is a newtype
257 = concatMap (mk_nt_edges1 nt) (tcTyConsOfType (new_tc_rhs nt))
258 -- tyConsOfType looks through synonyms
261 | tc `elem` new_tycons = [tc] -- Loop
262 -- At this point we know that either it's a local *data* type,
263 -- or it's imported. Either way, it can't form part of a newtype cycle
266 --------------- Product types ----------------------
267 -- The "prod_tycons" are the non-newtype products
268 prod_tycons = [tc | tc <- all_tycons,
269 not (isNewTyCon tc), isProductTyCon tc]
270 prod_loop_breakers = mkNameSet (findLoopBreakers prod_edges)
272 prod_edges = [(tc, mk_prod_edges tc) | tc <- prod_tycons]
274 mk_prod_edges tc -- Invariant: tc is a product tycon
275 = concatMap (mk_prod_edges1 tc) (dataConOrigArgTys (head (tyConDataCons tc)))
277 mk_prod_edges1 ptc ty = concatMap (mk_prod_edges2 ptc) (tcTyConsOfType ty)
279 mk_prod_edges2 ptc tc
280 | tc `elem` prod_tycons = [tc] -- Local product
281 | tc `elem` new_tycons = if is_rec_nt tc -- Local newtype
283 else mk_prod_edges1 ptc (new_tc_rhs tc)
284 -- At this point we know that either it's a local non-product data type,
285 -- or it's imported. Either way, it can't form part of a cycle
288 new_tc_rhs tc = snd (newTyConRhs tc) -- Ignore the type variables
290 getTyCon (ATyCon tc) = tc
291 getTyCon (AClass cl) = classTyCon cl
293 findLoopBreakers :: [(TyCon, [TyCon])] -> [Name]
294 -- Finds a set of tycons that cut all loops
295 findLoopBreakers deps
296 = go [(tc,tc,ds) | (tc,ds) <- deps]
299 | CyclicSCC ((tc,_,_) : edges') <- stronglyConnCompR edges,
300 name <- tyConName tc : go edges']
303 These two functions know about type representations, so they could be
304 in Type or TcType -- but they are very specialised to this module, so
305 I've chosen to put them here.
308 tcTyConsOfType :: Type -> [TyCon]
309 -- tcTyConsOfType looks through all synonyms, but not through any newtypes.
310 -- When it finds a Class, it returns the class TyCon. The reaons it's here
311 -- (not in Type.lhs) is because it is newtype-aware.
313 = nameEnvElts (go ty)
315 go :: Type -> NameEnv TyCon -- The NameEnv does duplicate elim
316 go (TyVarTy v) = emptyNameEnv
317 go (TyConApp tc tys) = go_tc tc tys
318 go (AppTy a b) = go a `plusNameEnv` go b
319 go (FunTy a b) = go a `plusNameEnv` go b
320 go (PredTy (IParam _ ty)) = go ty
321 go (PredTy (ClassP cls tys)) = go_tc (classTyCon cls) tys
322 go (NoteTy _ ty) = go ty
323 go (ForAllTy _ ty) = go ty
325 go_tc tc tys = extendNameEnv (go_s tys) (tyConName tc) tc
326 go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys
330 %************************************************************************
332 Compuing TyCon argument variances
334 %************************************************************************
336 Computing the tyConArgVrcs info
337 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
339 @tyConArgVrcs@ gives a list of (occPos,occNeg) flags, one for each
340 tyvar. For @AlgTyCon@s and @SynTyCon@s, this info must be precomputed
341 separately. Note that this is information about occurrences of type
342 variables, not usages of term variables.
344 The function @calcTyConArgVrcs@ must be passed a list of *algebraic or
345 syntycons only* such that all tycons referred to (by mutual recursion)
346 appear in the list. The fixpointing will be done on this set of
347 tycons as a whole. It returns a list of @tyconVrcInfo@ data, ready to
348 be (knot-tyingly?) stuck back into the appropriate fields.
351 calcTyConArgVrcs :: [TyThing] -> Name -> ArgVrcs
352 -- Gives arg variances for TyCons,
353 -- including the class TyCon of a class
354 calcTyConArgVrcs tyclss
357 tycons = map getTyCon tyclss
359 -- We should only look up things that are in the map
360 get_vrc n = case lookupNameEnv final_oi n of
362 Nothing -> pprPanic "calcVrcs" (ppr n)
364 -- We are going to fold over this map,
365 -- so we need the TyCon in the range
366 final_oi :: NameEnv (TyCon, ArgVrcs)
367 final_oi = tcaoFix initial_oi
369 initial_oi :: NameEnv (TyCon, ArgVrcs)
370 initial_oi = mkNameEnv [(tyConName tc, (tc, initial tc))
372 initial tc = replicate (tyConArity tc) (False,False)
374 tcaoFix :: NameEnv (TyCon, ArgVrcs) -- initial ArgVrcs per tycon
375 -> NameEnv (TyCon, ArgVrcs) -- fixpointed ArgVrcs per tycon
377 | changed = tcaoFix oi'
380 (changed,oi') = foldNameEnv iterate (False,oi) oi
382 iterate (tc, pms) (changed,oi')
383 = (changed || (pms /= pms'),
384 extendNameEnv oi' (tyConName tc) (tc, pms'))
386 pms' = tcaoIter oi' tc -- seq not simult
388 tcaoIter :: NameEnv (TyCon, ArgVrcs) -- reference ArgVrcs (initial)
389 -> TyCon -- tycon to update
390 -> ArgVrcs -- new ArgVrcs for tycon
392 tcaoIter oi tc | isAlgTyCon tc
393 = map (\v -> anyVrc (vrcInTy (lookup oi) v) argtys) vs
395 data_cons = tyConDataCons tc
397 argtys = concatMap dataConOrigArgTys data_cons -- Rep? or Orig?
399 tcaoIter oi tc | isSynTyCon tc
400 = let (tyvs,ty) = getSynTyConDefn tc
401 -- we use the already-computed result for tycons not in this SCC
402 in map (\v -> vrcInTy (lookup oi) v ty) tyvs
404 lookup oi tc = case lookupNameEnv oi (tyConName tc) of
406 Nothing -> tyConArgVrcs tc
407 -- We use the already-computed result for tycons not in this SCC
411 Variance of tyvars in a type
412 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
414 A general variance-check function. We pass a function for determining
415 the @ArgVrc@s of a tycon; when fixpointing this refers to the current
416 value; otherwise this should be looked up from the tycon's own
417 tyConArgVrcs. Again, it knows the representation of Types.
420 vrcInTy :: (TyCon -> ArgVrcs) -- function to get argVrcs of a tycon (break out of recursion)
421 -> TyVar -- tyvar to check Vrcs of
422 -> Type -- type to check for occ in
423 -> (Bool,Bool) -- (occurs positively, occurs negatively)
425 vrcInTy fao v (NoteTy (SynNote _) ty) = vrcInTy fao v ty
426 -- SynTyCon doesn't neccessarily have vrcInfo at this point,
427 -- so don't try and use it
429 vrcInTy fao v (NoteTy (FTVNote ftv) ty) = if elemVarSet v ftv
430 then vrcInTy fao v ty
432 -- note that ftv cannot be calculated as occPos||occNeg,
433 -- since if a tyvar occurs only as unused tyconarg,
434 -- occPos==occNeg==False, but ftv=True
436 vrcInTy fao v (TyVarTy v') = if v==v'
440 vrcInTy fao v (AppTy ty1 ty2) = if vrcInTy fao v ty2 /= (False,False)
442 else vrcInTy fao v ty1
443 -- ty1 is probably unknown (or it would have been beta-reduced);
444 -- hence if v occurs in ty2 at all then it could occur with
445 -- either variance. Otherwise it occurs as it does in ty1.
447 vrcInTy fao v (FunTy ty1 ty2) = negVrc (vrcInTy fao v ty1)
451 vrcInTy fao v (ForAllTy v' ty) = if v==v'
453 else vrcInTy fao v ty
455 vrcInTy fao v (TyConApp tc tys) = let pms1 = map (vrcInTy fao v) tys
457 in orVrcs (zipWith timesVrc pms1 pms2)
459 vrcInTy fao v (PredTy st) = vrcInTy fao v (predTypeRep st)
466 orVrc :: (Bool,Bool) -> (Bool,Bool) -> (Bool,Bool)
467 orVrc (p1,m1) (p2,m2) = (p1||p2,m1||m2)
469 orVrcs :: [(Bool,Bool)] -> (Bool,Bool)
470 orVrcs = foldl orVrc (False,False)
472 negVrc :: (Bool,Bool) -> (Bool,Bool)
473 negVrc (p1,m1) = (m1,p1)
475 anyVrc :: (a -> (Bool,Bool)) -> [a] -> (Bool,Bool)
476 anyVrc p as = foldl (\ pm a -> pm `orVrc` p a)
479 timesVrc :: (Bool,Bool) -> (Bool,Bool) -> (Bool,Bool)
480 timesVrc (p1,m1) (p2,m2) = (p1 && p2 || m1 && m2,
481 p1 && m2 || m1 && p2)