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,
21 #include "HsVersions.h"
23 import TypeRep ( Type(..), TyNote(..), PredType(..) ) -- friend
24 import HsSyn ( TyClDecl(..), HsPred(..), LTyClDecl, isClassDecl )
25 import RnHsSyn ( extractHsTyNames )
26 import Type ( predTypeRep )
27 import BuildTyCl ( newTyConRhs )
28 import HscTypes ( TyThing(..) )
29 import TyCon ( TyCon, ArgVrcs, tyConArity, tyConDataCons, tyConTyVars,
30 getSynTyConDefn, isSynTyCon, isAlgTyCon, isHiBootTyCon,
31 tyConName, isNewTyCon, isProductTyCon, tyConArgVrcs )
32 import Class ( classTyCon )
33 import DataCon ( dataConRepArgTys, dataConOrigArgTys )
36 import Name ( Name, isTyVarName )
39 import Digraph ( SCC(..), stronglyConnComp, stronglyConnCompR )
40 import BasicTypes ( RecFlag(..) )
41 import SrcLoc ( Located(..), unLoc )
46 %************************************************************************
48 Cycles in class and type synonym declarations
50 %************************************************************************
52 We check for type synonym and class cycles on the *source* code.
55 a) Otherwise we'd need a special function to extract type-synonym tycons
56 from a type, whereas we have extractHsTyNames already
58 b) If we checked for type synonym loops after building the TyCon, we
59 can't do a hoistForAllTys on the type synonym rhs, (else we fall into
60 a black hole) which seems unclean. Apart from anything else, it'd mean
61 that a type-synonym rhs could have for-alls to the right of an arrow,
62 which means adding new cases to the validity checker
64 Indeed, in general, checking for cycles beforehand means we need to
65 be less careful about black holes through synonym cycles.
67 The main disadvantage is that a cycle that goes via a type synonym in an
68 .hi-boot file can lead the compiler into a loop, because it assumes that cycles
69 only occur in source code. But hi-boot files are trusted anyway, so this isn't
70 much worse than (say) a kind error.
72 [ NOTE ----------------------------------------------
73 If we reverse this decision, this comment came from tcTyDecl1, and should
75 -- dsHsType, not tcHsKindedType, to avoid a loop. tcHsKindedType does hoisting,
76 -- which requires looking through synonyms... and therefore goes into a loop
77 -- on (erroneously) recursive synonyms.
78 -- Solution: do not hoist synonyms, because they'll be hoisted soon enough
79 -- when they are substituted
81 We'd also need to add back in this definition
83 synTyConsOfType :: Type -> [TyCon]
84 -- Does not look through type synonyms at all
85 -- Return a list of synonym tycons
89 go :: Type -> NameEnv TyCon -- The NameEnv does duplicate elim
90 go (TyVarTy v) = emptyNameEnv
91 go (TyConApp tc tys) = go_tc tc tys -- See note (a)
92 go (NewTcApp tc tys) = go_s tys -- Ignore tycon
93 go (AppTy a b) = go a `plusNameEnv` go b
94 go (FunTy a b) = go a `plusNameEnv` go b
95 go (PredTy (IParam _ ty)) = go ty
96 go (PredTy (ClassP cls tys)) = go_s tys -- Ignore class
97 go (NoteTy (SynNote ty) _) = go ty -- Don't look through it!
98 go (NoteTy other ty) = go ty
99 go (ForAllTy _ ty) = go ty
101 -- Note (a): the unexpanded branch of a SynNote has a
102 -- TyConApp for the synonym, so the tc of
103 -- a TyConApp must be tested for possible synonyms
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 A newtype M.T is defined to be "recursive" iff
142 (a) its rhs mentions an abstract (hi-boot) TyCon
143 or (b) one can get from T's rhs to T via type
144 synonyms, or non-recursive newtypes *in M*
145 e.g. newtype T = MkT (T -> Int)
147 (a) is conservative; it assumes that the hi-boot type can loop
148 around to T. That's why in (b) we can restrict attention
149 to tycons in M, because any loops through newtypes outside M
150 will be broken by those newtypes
152 An algebraic data type M.T is "recursive" iff
153 it has just one constructor, and
154 (a) its arg types mention an abstract (hi-boot) TyCon
155 or (b) one can get from its arg types to T via type synonyms,
156 or by non-recursive newtypes or non-recursive product types in M
157 e.g. data T = MkT (T -> Int) Bool
159 A type synonym is recursive if one can get from its
160 right hand side back to it via type synonyms. (This is
161 reported as an error.)
163 A class is recursive if one can get from its superclasses
164 back to it. (This is an error too.)
168 A data type read from an hi-boot file will have an Unknown in its data constructors,
169 and will respond True to isHiBootTyCon. The idea is that we treat these as if one
170 could get from these types to anywhere. So when we see
173 import {-# SOURCE #-} Foo( T )
176 then we mark S as recursive, just in case. What that means is that if we see
181 then we don't need to look inside S to compute R's recursiveness. Since S is imported
182 (not from an hi-boot file), one cannot get from R back to S except via an hi-boot file,
183 and that means that some data type will be marked recursive along the way. So R is
184 unconditionly non-recursive (i.e. there'll be a loop breaker elsewhere if necessary)
186 This in turn means that we grovel through fewer interface files when computing
187 recursiveness, because we need only look at the type decls in the module being
188 compiled, plus the outer structure of directly-mentioned types.
191 calcRecFlags :: [TyThing] -> (Name -> RecFlag)
195 is_rec n | n `elemNameSet` rec_names = Recursive
196 | otherwise = NonRecursive
198 rec_names = nt_loop_breakers `unionNameSets` prod_loop_breakers
200 all_tycons = map getTyCon tyclss -- Recursion of newtypes/data types
201 -- can happen via the class TyCon
203 -------------------------------------------------
205 -- These edge-construction loops rely on
206 -- every loop going via tyclss, the types and classes
207 -- in the module being compiled. Stuff in interface
208 -- files should be correctly marked. If not (e.g. a
209 -- type synonym in a hi-boot file) we can get an infinite
210 -- loop. We could program round this, but it'd make the code
211 -- rather less nice, so I'm not going to do that yet.
213 --------------- Newtypes ----------------------
214 new_tycons = filter isNewTyCon all_tycons
215 nt_loop_breakers = mkNameSet (findLoopBreakers nt_edges)
216 is_rec_nt tc = tyConName tc `elemNameSet` nt_loop_breakers
217 -- is_rec_nt is a locally-used helper function
219 nt_edges = [(t, mk_nt_edges t) | t <- new_tycons]
221 mk_nt_edges nt -- Invariant: nt is a newtype
222 = concatMap (mk_nt_edges1 nt) (tcTyConsOfType (newTyConRhs nt))
223 -- tyConsOfType looks through synonyms
226 | tc `elem` new_tycons = [tc] -- Loop
227 | isHiBootTyCon tc = [nt] -- Make it self-recursive if
228 -- it mentions an hi-boot TyCon
229 -- At this point we know that either it's a local data type,
230 -- or it's imported. Either way, it can't form part of a cycle
233 --------------- Product types ----------------------
234 -- The "prod_tycons" are the non-newtype products
235 prod_tycons = [tc | tc <- all_tycons,
236 not (isNewTyCon tc), isProductTyCon tc]
237 prod_loop_breakers = mkNameSet (findLoopBreakers prod_edges)
239 prod_edges = [(tc, mk_prod_edges tc) | tc <- prod_tycons]
241 mk_prod_edges tc -- Invariant: tc is a product tycon
242 = concatMap (mk_prod_edges1 tc) (dataConOrigArgTys (head (tyConDataCons tc)))
244 mk_prod_edges1 ptc ty = concatMap (mk_prod_edges2 ptc) (tcTyConsOfType ty)
246 mk_prod_edges2 ptc tc
247 | tc `elem` prod_tycons = [tc] -- Local product
248 | tc `elem` new_tycons = if is_rec_nt tc -- Local newtype
250 else mk_prod_edges1 ptc (newTyConRhs tc)
251 | isHiBootTyCon tc = [ptc] -- Make it self-recursive if
252 -- it mentions an hi-boot TyCon
253 -- At this point we know that either it's a local non-product data type,
254 -- or it's imported. Either way, it can't form part of a cycle
257 getTyCon (ATyCon tc) = tc
258 getTyCon (AClass cl) = classTyCon cl
260 findLoopBreakers :: [(TyCon, [TyCon])] -> [Name]
261 -- Finds a set of tycons that cut all loops
262 findLoopBreakers deps
263 = go [(tc,tc,ds) | (tc,ds) <- deps]
266 | CyclicSCC ((tc,_,_) : edges') <- stronglyConnCompR edges,
267 name <- tyConName tc : go edges']
270 These two functions know about type representations, so they could be
271 in Type or TcType -- but they are very specialised to this module, so
272 I've chosen to put them here.
275 tcTyConsOfType :: Type -> [TyCon]
276 -- tcTyConsOfType looks through all synonyms, but not through any newtypes.
277 -- When it finds a Class, it returns the class TyCon. The reaons it's here
278 -- (not in Type.lhs) is because it is newtype-aware.
280 = nameEnvElts (go ty)
282 go :: Type -> NameEnv TyCon -- The NameEnv does duplicate elim
283 go (TyVarTy v) = emptyNameEnv
284 go (TyConApp tc tys) = go_tc tc tys
285 go (NewTcApp tc tys) = go_tc tc tys
286 go (AppTy a b) = go a `plusNameEnv` go b
287 go (FunTy a b) = go a `plusNameEnv` go b
288 go (PredTy (IParam _ ty)) = go ty
289 go (PredTy (ClassP cls tys)) = go_tc (classTyCon cls) tys
290 go (NoteTy _ ty) = go ty
291 go (ForAllTy _ ty) = go ty
293 go_tc tc tys = extendNameEnv (go_s tys) (tyConName tc) tc
294 go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys
298 %************************************************************************
300 Compuing TyCon argument variances
302 %************************************************************************
304 Computing the tyConArgVrcs info
305 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
307 @tyConArgVrcs@ gives a list of (occPos,occNeg) flags, one for each
308 tyvar. For @AlgTyCon@s and @SynTyCon@s, this info must be precomputed
309 separately. Note that this is information about occurrences of type
310 variables, not usages of term variables.
312 The function @calcTyConArgVrcs@ must be passed a list of *algebraic or
313 syntycons only* such that all tycons referred to (by mutual recursion)
314 appear in the list. The fixpointing will be done on this set of
315 tycons as a whole. It returns a list of @tyconVrcInfo@ data, ready to
316 be (knot-tyingly?) stuck back into the appropriate fields.
319 calcTyConArgVrcs :: [TyThing] -> Name -> ArgVrcs
320 -- Gives arg variances for TyCons,
321 -- including the class TyCon of a class
322 calcTyConArgVrcs tyclss
325 tycons = map getTyCon tyclss
327 -- We should only look up things that are in the map
328 get_vrc n = case lookupNameEnv final_oi n of
330 Nothing -> pprPanic "calcVrcs" (ppr n)
332 -- We are going to fold over this map,
333 -- so we need the TyCon in the range
334 final_oi :: NameEnv (TyCon, ArgVrcs)
335 final_oi = tcaoFix initial_oi
337 initial_oi :: NameEnv (TyCon, ArgVrcs)
338 initial_oi = mkNameEnv [(tyConName tc, (tc, initial tc))
340 initial tc = replicate (tyConArity tc) (False,False)
342 tcaoFix :: NameEnv (TyCon, ArgVrcs) -- initial ArgVrcs per tycon
343 -> NameEnv (TyCon, ArgVrcs) -- fixpointed ArgVrcs per tycon
345 | changed = tcaoFix oi'
348 (changed,oi') = foldNameEnv iterate (False,oi) oi
350 iterate (tc, pms) (changed,oi')
351 = (changed || (pms /= pms'),
352 extendNameEnv oi' (tyConName tc) (tc, pms'))
354 pms' = tcaoIter oi' tc -- seq not simult
356 tcaoIter :: NameEnv (TyCon, ArgVrcs) -- reference ArgVrcs (initial)
357 -> TyCon -- tycon to update
358 -> ArgVrcs -- new ArgVrcs for tycon
360 tcaoIter oi tc | isAlgTyCon tc
361 = map (\v -> anyVrc (vrcInTy (lookup oi) v) argtys) vs
363 data_cons = tyConDataCons tc
365 argtys = concatMap dataConRepArgTys data_cons -- Rep? or Orig?
367 tcaoIter oi tc | isSynTyCon tc
368 = let (tyvs,ty) = getSynTyConDefn tc
369 -- we use the already-computed result for tycons not in this SCC
370 in map (\v -> vrcInTy (lookup oi) v ty) tyvs
372 lookup oi tc = case lookupNameEnv oi (tyConName tc) of
374 Nothing -> tyConArgVrcs tc
375 -- We use the already-computed result for tycons not in this SCC
379 Variance of tyvars in a type
380 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
382 A general variance-check function. We pass a function for determining
383 the @ArgVrc@s of a tycon; when fixpointing this refers to the current
384 value; otherwise this should be looked up from the tycon's own
385 tyConArgVrcs. Again, it knows the representation of Types.
388 vrcInTy :: (TyCon -> ArgVrcs) -- function to get argVrcs of a tycon (break out of recursion)
389 -> TyVar -- tyvar to check Vrcs of
390 -> Type -- type to check for occ in
391 -> (Bool,Bool) -- (occurs positively, occurs negatively)
393 vrcInTy fao v (NoteTy (SynNote _) ty) = vrcInTy fao v ty
394 -- SynTyCon doesn't neccessarily have vrcInfo at this point,
395 -- so don't try and use it
397 vrcInTy fao v (NoteTy (FTVNote ftv) ty) = if elemVarSet v ftv
398 then vrcInTy fao v ty
400 -- note that ftv cannot be calculated as occPos||occNeg,
401 -- since if a tyvar occurs only as unused tyconarg,
402 -- occPos==occNeg==False, but ftv=True
404 vrcInTy fao v (TyVarTy v') = if v==v'
408 vrcInTy fao v (AppTy ty1 ty2) = if vrcInTy fao v ty2 /= (False,False)
410 else vrcInTy fao v ty1
411 -- ty1 is probably unknown (or it would have been beta-reduced);
412 -- hence if v occurs in ty2 at all then it could occur with
413 -- either variance. Otherwise it occurs as it does in ty1.
415 vrcInTy fao v (FunTy ty1 ty2) = negVrc (vrcInTy fao v ty1)
419 vrcInTy fao v (ForAllTy v' ty) = if v==v'
421 else vrcInTy fao v ty
423 vrcInTy fao v (TyConApp tc tys) = let pms1 = map (vrcInTy fao v) tys
425 in orVrcs (zipWith timesVrc pms1 pms2)
427 vrcInTy fao v (NewTcApp tc tys) = let pms1 = map (vrcInTy fao v) tys
429 in orVrcs (zipWith timesVrc pms1 pms2)
431 vrcInTy fao v (PredTy st) = vrcInTy fao v (predTypeRep st)
438 orVrc :: (Bool,Bool) -> (Bool,Bool) -> (Bool,Bool)
439 orVrc (p1,m1) (p2,m2) = (p1||p2,m1||m2)
441 orVrcs :: [(Bool,Bool)] -> (Bool,Bool)
442 orVrcs = foldl orVrc (False,False)
444 negVrc :: (Bool,Bool) -> (Bool,Bool)
445 negVrc (p1,m1) = (m1,p1)
447 anyVrc :: (a -> (Bool,Bool)) -> [a] -> (Bool,Bool)
448 anyVrc p as = foldl (\ pm a -> pm `orVrc` p a)
451 timesVrc :: (Bool,Bool) -> (Bool,Bool) -> (Bool,Bool)
452 timesVrc (p1,m1) (p2,m2) = (p1 && p2 || m1 && m2,
453 p1 && m2 || m1 && p2)