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, tcView )
26 import HscTypes ( TyThing(..), ModDetails(..) )
27 import TyCon ( TyCon, ArgVrcs, tyConArity, tyConDataCons, tyConTyVars,
28 synTyConDefn, isSynTyCon, isAlgTyCon,
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
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 _ ty) = go ty
103 go (ForAllTy _ ty) = go ty
105 go_tc tc tys | isSynTyCon tc = extendNameEnv (go_s tys) (tyConName tc) tc
106 | otherwise = go_s tys
107 go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys
108 ---------------------------------------- END NOTE ]
111 calcSynCycles :: [LTyClDecl Name] -> [SCC (LTyClDecl Name)]
113 = stronglyConnComp syn_edges
115 syn_edges = [ (ldecl, unLoc (tcdLName decl),
116 mk_syn_edges (tcdSynRhs decl))
117 | ldecl@(L _ decl) <- decls ]
119 mk_syn_edges rhs = [ tc | tc <- nameSetToList (extractHsTyNames rhs),
120 not (isTyVarName tc) ]
123 calcClassCycles :: [LTyClDecl Name] -> [[LTyClDecl Name]]
124 calcClassCycles decls
125 = [decls | CyclicSCC decls <- stronglyConnComp cls_edges]
127 cls_edges = [ (ldecl, unLoc (tcdLName decl),
128 mk_cls_edges (unLoc (tcdCtxt decl)))
129 | ldecl@(L _ decl) <- decls, isClassDecl decl ]
131 mk_cls_edges ctxt = [ cls | L _ (HsClassP cls _) <- ctxt ]
135 %************************************************************************
137 Deciding which type constructors are recursive
139 %************************************************************************
141 For newtypes, we label some as "recursive" such that
143 INVARIANT: there is no cycle of non-recursive newtypes
145 In any loop, only one newtype need be marked as recursive; it is
146 a "loop breaker". Labelling more than necessary as recursive is OK,
147 provided the invariant is maintained.
149 A newtype M.T is defined to be "recursive" iff
150 (a) it is declared in an hi-boot file (see RdrHsSyn.hsIfaceDecl)
151 (b) it is declared in a source file, but that source file has a
152 companion hi-boot file which declares the type
153 or (c) one can get from T's rhs to T via type
154 synonyms, or non-recursive newtypes *in M*
155 e.g. newtype T = MkT (T -> Int)
157 (a) is conservative; declarations in hi-boot files are always
158 made loop breakers. That's why in (b) we can restrict attention
159 to tycons in M, because any loops through newtypes outside M
160 will be broken by those newtypes
161 (b) ensures that a newtype is not treated as a loop breaker in one place
162 and later as a non-loop-breaker. This matters in GHCi particularly, when
163 a newtype T might be embedded in many types in the environment, and then
164 T's source module is compiled. We don't want T's recursiveness to change.
166 The "recursive" flag for algebraic data types is irrelevant (never consulted)
167 for types with more than one constructor.
169 An algebraic data type M.T is "recursive" iff
170 it has just one constructor, and
171 (a) it is declared in an hi-boot file (see RdrHsSyn.hsIfaceDecl)
172 (b) it is declared in a source file, but that source file has a
173 companion hi-boot file which declares the type
174 or (c) one can get from its arg types to T via type synonyms,
175 or by non-recursive newtypes or non-recursive product types in M
176 e.g. data T = MkT (T -> Int) Bool
177 Just like newtype in fact
179 A type synonym is recursive if one can get from its
180 right hand side back to it via type synonyms. (This is
181 reported as an error.)
183 A class is recursive if one can get from its superclasses
184 back to it. (This is an error too.)
188 A data type read from an hi-boot file will have an AbstractTyCon as its AlgTyConRhs
189 and will respond True to isHiBootTyCon. The idea is that we treat these as if one
190 could get from these types to anywhere. So when we see
193 import {-# SOURCE #-} Foo( T )
196 then we mark S as recursive, just in case. What that means is that if we see
201 then we don't need to look inside S to compute R's recursiveness. Since S is imported
202 (not from an hi-boot file), one cannot get from R back to S except via an hi-boot file,
203 and that means that some data type will be marked recursive along the way. So R is
204 unconditionly non-recursive (i.e. there'll be a loop breaker elsewhere if necessary)
206 This in turn means that we grovel through fewer interface files when computing
207 recursiveness, because we need only look at the type decls in the module being
208 compiled, plus the outer structure of directly-mentioned types.
211 calcRecFlags :: ModDetails -> [TyThing] -> (Name -> RecFlag)
212 -- The 'boot_names' are the things declared in M.hi-boot, if M is the current module.
213 -- Any type constructors in boot_names are automatically considered loop breakers
214 calcRecFlags boot_details tyclss
217 is_rec n | n `elemNameSet` rec_names = Recursive
218 | otherwise = NonRecursive
220 boot_name_set = md_exports boot_details
221 rec_names = boot_name_set `unionNameSets`
222 nt_loop_breakers `unionNameSets`
225 all_tycons = [ tc | tycls <- tyclss,
226 -- Recursion of newtypes/data types can happen via
227 -- the class TyCon, so tyclss includes the class tycons
228 let tc = getTyCon tycls,
229 not (tyConName tc `elemNameSet` boot_name_set) ]
230 -- Remove the boot_name_set because they are going
231 -- to be loop breakers regardless.
233 -------------------------------------------------
235 -- These edge-construction loops rely on
236 -- every loop going via tyclss, the types and classes
237 -- in the module being compiled. Stuff in interface
238 -- files should be correctly marked. If not (e.g. a
239 -- type synonym in a hi-boot file) we can get an infinite
240 -- loop. We could program round this, but it'd make the code
241 -- rather less nice, so I'm not going to do that yet.
243 --------------- Newtypes ----------------------
244 new_tycons = filter isNewTyCon all_tycons
245 nt_loop_breakers = mkNameSet (findLoopBreakers nt_edges)
246 is_rec_nt tc = tyConName tc `elemNameSet` nt_loop_breakers
247 -- is_rec_nt is a locally-used helper function
249 nt_edges = [(t, mk_nt_edges t) | t <- new_tycons]
251 mk_nt_edges nt -- Invariant: nt is a newtype
252 = concatMap (mk_nt_edges1 nt) (tcTyConsOfType (new_tc_rhs nt))
253 -- tyConsOfType looks through synonyms
256 | tc `elem` new_tycons = [tc] -- Loop
257 -- At this point we know that either it's a local *data* type,
258 -- or it's imported. Either way, it can't form part of a newtype cycle
261 --------------- Product types ----------------------
262 -- The "prod_tycons" are the non-newtype products
263 prod_tycons = [tc | tc <- all_tycons,
264 not (isNewTyCon tc), isProductTyCon tc]
265 prod_loop_breakers = mkNameSet (findLoopBreakers prod_edges)
267 prod_edges = [(tc, mk_prod_edges tc) | tc <- prod_tycons]
269 mk_prod_edges tc -- Invariant: tc is a product tycon
270 = concatMap (mk_prod_edges1 tc) (dataConOrigArgTys (head (tyConDataCons tc)))
272 mk_prod_edges1 ptc ty = concatMap (mk_prod_edges2 ptc) (tcTyConsOfType ty)
274 mk_prod_edges2 ptc tc
275 | tc `elem` prod_tycons = [tc] -- Local product
276 | tc `elem` new_tycons = if is_rec_nt tc -- Local newtype
278 else mk_prod_edges1 ptc (new_tc_rhs tc)
279 -- At this point we know that either it's a local non-product data type,
280 -- or it's imported. Either way, it can't form part of a cycle
283 new_tc_rhs tc = snd (newTyConRhs tc) -- Ignore the type variables
285 getTyCon (ATyCon tc) = tc
286 getTyCon (AClass cl) = classTyCon cl
288 findLoopBreakers :: [(TyCon, [TyCon])] -> [Name]
289 -- Finds a set of tycons that cut all loops
290 findLoopBreakers deps
291 = go [(tc,tc,ds) | (tc,ds) <- deps]
294 | CyclicSCC ((tc,_,_) : edges') <- stronglyConnCompR edges,
295 name <- tyConName tc : go edges']
298 These two functions know about type representations, so they could be
299 in Type or TcType -- but they are very specialised to this module, so
300 I've chosen to put them here.
303 tcTyConsOfType :: Type -> [TyCon]
304 -- tcTyConsOfType looks through all synonyms, but not through any newtypes.
305 -- When it finds a Class, it returns the class TyCon. The reaons it's here
306 -- (not in Type.lhs) is because it is newtype-aware.
308 = nameEnvElts (go ty)
310 go :: Type -> NameEnv TyCon -- The NameEnv does duplicate elim
311 go ty | Just ty' <- tcView ty = go ty'
312 go (TyVarTy v) = emptyNameEnv
313 go (TyConApp tc tys) = go_tc tc tys
314 go (AppTy a b) = go a `plusNameEnv` go b
315 go (FunTy a b) = go a `plusNameEnv` go b
316 go (PredTy (IParam _ ty)) = go ty
317 go (PredTy (ClassP cls tys)) = go_tc (classTyCon cls) tys
318 go (ForAllTy _ ty) = go ty
320 go_tc tc tys = extendNameEnv (go_s tys) (tyConName tc) tc
321 go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys
325 %************************************************************************
327 Compuing TyCon argument variances
329 %************************************************************************
331 Computing the tyConArgVrcs info
332 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
334 @tyConArgVrcs@ gives a list of (occPos,occNeg) flags, one for each
335 tyvar. For @AlgTyCon@s and @SynTyCon@s, this info must be precomputed
336 separately. Note that this is information about occurrences of type
337 variables, not usages of term variables.
339 The function @calcTyConArgVrcs@ must be passed a list of *algebraic or
340 syntycons only* such that all tycons referred to (by mutual recursion)
341 appear in the list. The fixpointing will be done on this set of
342 tycons as a whole. It returns a list of @tyconVrcInfo@ data, ready to
343 be (knot-tyingly?) stuck back into the appropriate fields.
346 calcTyConArgVrcs :: [TyThing] -> Name -> ArgVrcs
347 -- Gives arg variances for TyCons,
348 -- including the class TyCon of a class
349 calcTyConArgVrcs tyclss
352 tycons = map getTyCon tyclss
354 -- We should only look up things that are in the map
355 get_vrc n = case lookupNameEnv final_oi n of
357 Nothing -> pprPanic "calcVrcs" (ppr n)
359 -- We are going to fold over this map,
360 -- so we need the TyCon in the range
361 final_oi :: NameEnv (TyCon, ArgVrcs)
362 final_oi = tcaoFix initial_oi
364 initial_oi :: NameEnv (TyCon, ArgVrcs)
365 initial_oi = mkNameEnv [(tyConName tc, (tc, initial tc))
367 initial tc = replicate (tyConArity tc) (False,False)
369 tcaoFix :: NameEnv (TyCon, ArgVrcs) -- initial ArgVrcs per tycon
370 -> NameEnv (TyCon, ArgVrcs) -- fixpointed ArgVrcs per tycon
372 | changed = tcaoFix oi'
375 (changed,oi') = foldNameEnv iterate (False,oi) oi
377 iterate (tc, pms) (changed,oi')
378 = (changed || (pms /= pms'),
379 extendNameEnv oi' (tyConName tc) (tc, pms'))
381 pms' = tcaoIter oi' tc -- seq not simult
383 tcaoIter :: NameEnv (TyCon, ArgVrcs) -- reference ArgVrcs (initial)
384 -> TyCon -- tycon to update
385 -> ArgVrcs -- new ArgVrcs for tycon
387 tcaoIter oi tc | isAlgTyCon tc
388 = map (\v -> anyVrc (vrcInTy (lookup oi) v) argtys) vs
390 data_cons = tyConDataCons tc
392 argtys = concatMap dataConOrigArgTys data_cons -- Rep? or Orig?
394 tcaoIter oi tc | isSynTyCon tc
395 = let (tyvs,ty) = synTyConDefn tc
396 -- we use the already-computed result for tycons not in this SCC
397 in map (\v -> vrcInTy (lookup oi) v ty) tyvs
399 lookup oi tc = case lookupNameEnv oi (tyConName tc) of
401 Nothing -> tyConArgVrcs tc
402 -- We use the already-computed result for tycons not in this SCC
406 Variance of tyvars in a type
407 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
409 A general variance-check function. We pass a function for determining
410 the @ArgVrc@s of a tycon; when fixpointing this refers to the current
411 value; otherwise this should be looked up from the tycon's own
412 tyConArgVrcs. Again, it knows the representation of Types.
415 vrcInTy :: (TyCon -> ArgVrcs) -- function to get argVrcs of a tycon (break out of recursion)
416 -> TyVar -- tyvar to check Vrcs of
417 -> Type -- type to check for occ in
418 -> (Bool,Bool) -- (occurs positively, occurs negatively)
420 vrcInTy fao v (NoteTy (FTVNote ftv) ty) = if elemVarSet v ftv
421 then vrcInTy fao v ty
423 -- note that ftv cannot be calculated as occPos||occNeg,
424 -- since if a tyvar occurs only as unused tyconarg,
425 -- occPos==occNeg==False, but ftv=True
427 vrcInTy fao v (TyVarTy v') = if v==v'
431 vrcInTy fao v (AppTy ty1 ty2) = if vrcInTy fao v ty2 /= (False,False)
433 else vrcInTy fao v ty1
434 -- ty1 is probably unknown (or it would have been beta-reduced);
435 -- hence if v occurs in ty2 at all then it could occur with
436 -- either variance. Otherwise it occurs as it does in ty1.
438 vrcInTy fao v (FunTy ty1 ty2) = negVrc (vrcInTy fao v ty1)
442 vrcInTy fao v (ForAllTy v' ty) = if v==v'
444 else vrcInTy fao v ty
446 vrcInTy fao v (TyConApp tc tys) = let pms1 = map (vrcInTy fao v) tys
448 in orVrcs (zipWith timesVrc pms1 pms2)
450 vrcInTy fao v (PredTy st) = vrcInTy fao v (predTypeRep st)
457 orVrc :: (Bool,Bool) -> (Bool,Bool) -> (Bool,Bool)
458 orVrc (p1,m1) (p2,m2) = (p1||p2,m1||m2)
460 orVrcs :: [(Bool,Bool)] -> (Bool,Bool)
461 orVrcs = foldl orVrc (False,False)
463 negVrc :: (Bool,Bool) -> (Bool,Bool)
464 negVrc (p1,m1) = (m1,p1)
466 anyVrc :: (a -> (Bool,Bool)) -> [a] -> (Bool,Bool)
467 anyVrc p as = foldl (\ pm a -> pm `orVrc` p a)
470 timesVrc :: (Bool,Bool) -> (Bool,Bool) -> (Bool,Bool)
471 timesVrc (p1,m1) (p2,m2) = (p1 && p2 || m1 && m2,
472 p1 && m2 || m1 && p2)