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.
15 calcTyConArgVrcs, tyVarVrc,
16 calcRecFlags, calcCycleErrs,
20 #include "HsVersions.h"
22 import TypeRep ( Type(..), TyNote(..), PredType(..) ) -- friend
23 import HsSyn ( TyClDecl(..), HsPred(..) )
24 import RnHsSyn ( extractHsTyNames )
25 import Type ( predTypeRep )
26 import BuildTyCl ( newTyConRhs )
27 import HscTypes ( TyThing(..) )
28 import TyCon ( TyCon, ArgVrcs, tyConArity, tyConDataCons, tyConTyVars,
29 getSynTyConDefn, isSynTyCon, isAlgTyCon, isHiBootTyCon,
30 tyConName, isNewTyCon, isProductTyCon, tyConArgVrcs )
31 import Class ( classTyCon )
32 import DataCon ( dataConRepArgTys, dataConOrigArgTys )
35 import Name ( Name, isTyVarName )
38 import Digraph ( SCC(..), stronglyConnComp, stronglyConnCompR )
39 import BasicTypes ( RecFlag(..) )
44 %************************************************************************
46 Cycles in class and type synonym declarations
48 %************************************************************************
50 We check for type synonym and class cycles on the *source* code.
53 a) Otherwise we'd need a special function to extract type-synonym tycons
54 from a type, whereas we have extractHsTyNames already
56 b) If we checked for type synonym loops after building the TyCon, we
57 can't do a hoistForAllTys on the type synonym rhs, (else we fall into
58 a black hole) which seems unclean. Apart from anything else, it'd mean
59 that a type-synonym rhs could have for-alls to the right of an arrow,
60 which means adding new cases to the validity checker
62 Indeed, in general, checking for cycles beforehand means we need to
63 be less careful about black holes through synonym cycles.
65 The main disadvantage is that a cycle that goes via a type synonym in an
66 .hi-boot file can lead the compiler into a loop, because it assumes that cycles
67 only occur in source code. But hi-boot files are trusted anyway, so this isn't
68 much worse than (say) a kind error.
70 [ NOTE ----------------------------------------------
71 If we reverse this decision, this comment came from tcTyDecl1, and should
73 -- dsHsType, not tcHsKindedType, to avoid a loop. tcHsKindedType does hoisting,
74 -- which requires looking through synonyms... and therefore goes into a loop
75 -- on (erroneously) recursive synonyms.
76 -- Solution: do not hoist synonyms, because they'll be hoisted soon enough
77 -- when they are substituted
79 We'd also need to add back in this definition
81 synTyConsOfType :: Type -> [TyCon]
82 -- Does not look through type synonyms at all
83 -- Return a list of synonym tycons
87 go :: Type -> NameEnv TyCon -- The NameEnv does duplicate elim
88 go (TyVarTy v) = emptyNameEnv
89 go (TyConApp tc tys) = go_tc tc tys -- See note (a)
90 go (NewTcApp tc tys) = go_s tys -- Ignore tycon
91 go (AppTy a b) = go a `plusNameEnv` go b
92 go (FunTy a b) = go a `plusNameEnv` go b
93 go (PredTy (IParam _ ty)) = go ty
94 go (PredTy (ClassP cls tys)) = go_s tys -- Ignore class
95 go (NoteTy (SynNote ty) _) = go ty -- Don't look through it!
96 go (NoteTy other ty) = go ty
97 go (ForAllTy _ ty) = go ty
99 -- Note (a): the unexpanded branch of a SynNote has a
100 -- TyConApp for the synonym, so the tc of
101 -- a TyConApp must be tested for possible synonyms
103 go_tc tc tys | isSynTyCon tc = extendNameEnv (go_s tys) (tyConName tc) tc
104 | otherwise = go_s tys
105 go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys
106 ---------------------------------------- END NOTE ]
109 calcCycleErrs :: [TyClDecl Name] -> ([[Name]], -- Recursive type synonym groups
110 [[Name]]) -- Ditto classes
112 = (findCyclics syn_edges, findCyclics cls_edges)
114 --------------- Type synonyms ----------------------
115 syn_edges = [ (name, mk_syn_edges rhs) | TySynonym { tcdName = name, tcdSynRhs = rhs } <- decls ]
116 mk_syn_edges rhs = [ tc | tc <- nameSetToList (extractHsTyNames rhs), not (isTyVarName tc) ]
118 --------------- Classes ----------------------
119 cls_edges = [ (name, mk_cls_edges ctxt) | ClassDecl { tcdName = name, tcdCtxt = ctxt } <- decls ]
120 mk_cls_edges ctxt = [ cls | HsClassP cls _ <- ctxt ]
124 %************************************************************************
126 Deciding which type constructors are recursive
128 %************************************************************************
130 A newtype M.T is defined to be "recursive" iff
131 (a) its rhs mentions an abstract (hi-boot) TyCon
132 or (b) one can get from T's rhs to T via type
133 synonyms, or non-recursive newtypes *in M*
134 e.g. newtype T = MkT (T -> Int)
136 (a) is conservative; it assumes that the hi-boot type can loop
137 around to T. That's why in (b) we can restrict attention
138 to tycons in M, because any loops through newtypes outside M
139 will be broken by those newtypes
141 An algebraic data type M.T is "recursive" iff
142 it has just one constructor, and
143 (a) its arg types mention an abstract (hi-boot) TyCon
144 or (b) one can get from its arg types to T via type synonyms,
145 or by non-recursive newtypes or non-recursive product types in M
146 e.g. data T = MkT (T -> Int) Bool
148 A type synonym is recursive if one can get from its
149 right hand side back to it via type synonyms. (This is
150 reported as an error.)
152 A class is recursive if one can get from its superclasses
153 back to it. (This is an error too.)
157 A data type read from an hi-boot file will have an Unknown in its data constructors,
158 and will respond True to isHiBootTyCon. The idea is that we treat these as if one
159 could get from these types to anywhere. So when we see
162 import {-# SOURCE #-} Foo( T )
165 then we mark S as recursive, just in case. What that means is that if we see
170 then we don't need to look inside S to compute R's recursiveness. Since S is imported
171 (not from an hi-boot file), one cannot get from R back to S except via an hi-boot file,
172 and that means that some data type will be marked recursive along the way. So R is
173 unconditionly non-recursive (i.e. there'll be a loop breaker elsewhere if necessary)
175 This in turn means that we grovel through fewer interface files when computing
176 recursiveness, because we need only look at the type decls in the module being
177 compiled, plus the outer structure of directly-mentioned types.
180 calcRecFlags :: [TyThing] -> (Name -> RecFlag)
184 is_rec n | n `elemNameSet` rec_names = Recursive
185 | otherwise = NonRecursive
187 rec_names = nt_loop_breakers `unionNameSets` prod_loop_breakers
189 all_tycons = map getTyCon tyclss -- Recursion of newtypes/data types
190 -- can happen via the class TyCon
192 -------------------------------------------------
194 -- These edge-construction loops rely on
195 -- every loop going via tyclss, the types and classes
196 -- in the module being compiled. Stuff in interface
197 -- files should be correctly marked. If not (e.g. a
198 -- type synonym in a hi-boot file) we can get an infinite
199 -- loop. We could program round this, but it'd make the code
200 -- rather less nice, so I'm not going to do that yet.
202 --------------- Newtypes ----------------------
203 new_tycons = filter isNewTyCon all_tycons
204 nt_loop_breakers = mkNameSet (findLoopBreakers nt_edges)
205 is_rec_nt tc = tyConName tc `elemNameSet` nt_loop_breakers
206 -- is_rec_nt is a locally-used helper function
208 nt_edges = [(t, mk_nt_edges t) | t <- new_tycons]
210 mk_nt_edges nt -- Invariant: nt is a newtype
211 = concatMap (mk_nt_edges1 nt) (tcTyConsOfType (newTyConRhs nt))
212 -- tyConsOfType looks through synonyms
215 | tc `elem` new_tycons = [tc] -- Loop
216 | isHiBootTyCon tc = [nt] -- Make it self-recursive if
217 -- it mentions an hi-boot TyCon
218 -- At this point we know that either it's a local data type,
219 -- or it's imported. Either way, it can't form part of a cycle
222 --------------- Product types ----------------------
223 -- The "prod_tycons" are the non-newtype products
224 prod_tycons = [tc | tc <- all_tycons,
225 not (isNewTyCon tc), isProductTyCon tc]
226 prod_loop_breakers = mkNameSet (findLoopBreakers prod_edges)
228 prod_edges = [(tc, mk_prod_edges tc) | tc <- prod_tycons]
230 mk_prod_edges tc -- Invariant: tc is a product tycon
231 = concatMap (mk_prod_edges1 tc) (dataConOrigArgTys (head (tyConDataCons tc)))
233 mk_prod_edges1 ptc ty = concatMap (mk_prod_edges2 ptc) (tcTyConsOfType ty)
235 mk_prod_edges2 ptc tc
236 | tc `elem` prod_tycons = [tc] -- Local product
237 | tc `elem` new_tycons = if is_rec_nt tc -- Local newtype
239 else mk_prod_edges1 ptc (newTyConRhs tc)
240 | isHiBootTyCon tc = [ptc] -- Make it self-recursive if
241 -- it mentions an hi-boot TyCon
242 -- At this point we know that either it's a local non-product data type,
243 -- or it's imported. Either way, it can't form part of a cycle
246 getTyCon (ATyCon tc) = tc
247 getTyCon (AClass cl) = classTyCon cl
249 findLoopBreakers :: [(TyCon, [TyCon])] -> [Name]
250 -- Finds a set of tycons that cut all loops
251 findLoopBreakers deps
252 = go [(tc,tc,ds) | (tc,ds) <- deps]
255 | CyclicSCC ((tc,_,_) : edges') <- stronglyConnCompR edges,
256 name <- tyConName tc : go edges']
258 findCyclics :: [(Name,[Name])] -> [[Name]]
260 = [names | CyclicSCC names <- stronglyConnComp edges]
262 edges = [(name,name,ds) | (name,ds) <- deps]
265 These two functions know about type representations, so they could be
266 in Type or TcType -- but they are very specialised to this module, so
267 I've chosen to put them here.
270 tcTyConsOfType :: Type -> [TyCon]
271 -- tcTyConsOfType looks through all synonyms, but not through any newtypes.
272 -- When it finds a Class, it returns the class TyCon. The reaons it's here
273 -- (not in Type.lhs) is because it is newtype-aware.
275 = nameEnvElts (go ty)
277 go :: Type -> NameEnv TyCon -- The NameEnv does duplicate elim
278 go (TyVarTy v) = emptyNameEnv
279 go (TyConApp tc tys) = go_tc tc tys
280 go (NewTcApp tc tys) = go_tc tc tys
281 go (AppTy a b) = go a `plusNameEnv` go b
282 go (FunTy a b) = go a `plusNameEnv` go b
283 go (PredTy (IParam _ ty)) = go ty
284 go (PredTy (ClassP cls tys)) = go_tc (classTyCon cls) tys
285 go (NoteTy _ ty) = go ty
286 go (ForAllTy _ ty) = go ty
288 go_tc tc tys = extendNameEnv (go_s tys) (tyConName tc) tc
289 go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys
293 %************************************************************************
295 Compuing TyCon argument variances
297 %************************************************************************
299 Computing the tyConArgVrcs info
300 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
302 @tyConArgVrcs@ gives a list of (occPos,occNeg) flags, one for each
303 tyvar. For @AlgTyCon@s and @SynTyCon@s, this info must be precomputed
304 separately. Note that this is information about occurrences of type
305 variables, not usages of term variables.
307 The function @calcTyConArgVrcs@ must be passed a list of *algebraic or
308 syntycons only* such that all tycons referred to (by mutual recursion)
309 appear in the list. The fixpointing will be done on this set of
310 tycons as a whole. It returns a list of @tyconVrcInfo@ data, ready to
311 be (knot-tyingly?) stuck back into the appropriate fields.
314 calcTyConArgVrcs :: [TyThing] -> Name -> ArgVrcs
315 -- Gives arg variances for TyCons,
316 -- including the class TyCon of a class
317 calcTyConArgVrcs tyclss
320 tycons = map getTyCon tyclss
322 -- We should only look up things that are in the map
323 get_vrc n = case lookupNameEnv final_oi n of
325 Nothing -> pprPanic "calcVrcs" (ppr n)
327 -- We are going to fold over this map,
328 -- so we need the TyCon in the range
329 final_oi :: NameEnv (TyCon, ArgVrcs)
330 final_oi = tcaoFix initial_oi
332 initial_oi :: NameEnv (TyCon, ArgVrcs)
333 initial_oi = mkNameEnv [(tyConName tc, (tc, initial tc))
335 initial tc = replicate (tyConArity tc) (False,False)
337 tcaoFix :: NameEnv (TyCon, ArgVrcs) -- initial ArgVrcs per tycon
338 -> NameEnv (TyCon, ArgVrcs) -- fixpointed ArgVrcs per tycon
340 | changed = tcaoFix oi'
343 (changed,oi') = foldNameEnv iterate (False,oi) oi
345 iterate (tc, pms) (changed,oi')
346 = (changed || (pms /= pms'),
347 extendNameEnv oi' (tyConName tc) (tc, pms'))
349 pms' = tcaoIter oi' tc -- seq not simult
351 tcaoIter :: NameEnv (TyCon, ArgVrcs) -- reference ArgVrcs (initial)
352 -> TyCon -- tycon to update
353 -> ArgVrcs -- new ArgVrcs for tycon
355 tcaoIter oi tc | isAlgTyCon tc
356 = map (\v -> anyVrc (vrcInTy (lookup oi) v) argtys) vs
358 data_cons = tyConDataCons tc
360 argtys = concatMap dataConRepArgTys data_cons -- Rep? or Orig?
362 tcaoIter oi tc | isSynTyCon tc
363 = let (tyvs,ty) = getSynTyConDefn tc
364 -- we use the already-computed result for tycons not in this SCC
365 in map (\v -> vrcInTy (lookup oi) v ty) tyvs
367 lookup oi tc = case lookupNameEnv oi (tyConName tc) of
369 Nothing -> tyConArgVrcs tc
370 -- We use the already-computed result for tycons not in this SCC
374 Variance of tyvars in a type
375 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
377 A general variance-check function. We pass a function for determining
378 the @ArgVrc@s of a tycon; when fixpointing this refers to the current
379 value; otherwise this should be looked up from the tycon's own
380 tyConArgVrcs. Again, it knows the representation of Types.
383 vrcInTy :: (TyCon -> ArgVrcs) -- function to get argVrcs of a tycon (break out of recursion)
384 -> TyVar -- tyvar to check Vrcs of
385 -> Type -- type to check for occ in
386 -> (Bool,Bool) -- (occurs positively, occurs negatively)
388 vrcInTy fao v (NoteTy (SynNote _) ty) = vrcInTy fao v ty
389 -- SynTyCon doesn't neccessarily have vrcInfo at this point,
390 -- so don't try and use it
392 vrcInTy fao v (NoteTy (FTVNote ftv) ty) = if elemVarSet v ftv
393 then vrcInTy fao v ty
395 -- note that ftv cannot be calculated as occPos||occNeg,
396 -- since if a tyvar occurs only as unused tyconarg,
397 -- occPos==occNeg==False, but ftv=True
399 vrcInTy fao v (TyVarTy v') = if v==v'
403 vrcInTy fao v (AppTy ty1 ty2) = if vrcInTy fao v ty2 /= (False,False)
405 else vrcInTy fao v ty1
406 -- ty1 is probably unknown (or it would have been beta-reduced);
407 -- hence if v occurs in ty2 at all then it could occur with
408 -- either variance. Otherwise it occurs as it does in ty1.
410 vrcInTy fao v (FunTy ty1 ty2) = negVrc (vrcInTy fao v ty1)
414 vrcInTy fao v (ForAllTy v' ty) = if v==v'
416 else vrcInTy fao v ty
418 vrcInTy fao v (TyConApp tc tys) = let pms1 = map (vrcInTy fao v) tys
420 in orVrcs (zipWith timesVrc pms1 pms2)
422 vrcInTy fao v (NewTcApp tc tys) = let pms1 = map (vrcInTy fao v) tys
424 in orVrcs (zipWith timesVrc pms1 pms2)
426 vrcInTy fao v (PredTy st) = vrcInTy fao v (predTypeRep st)
430 External entry point: assumes tyconargvrcs already computed.
433 tyVarVrc :: TyVar -- tyvar to check Vrc of
434 -> Type -- type to check for occ in
435 -> (Bool,Bool) -- (occurs positively, occurs negatively)
437 tyVarVrc = vrcInTy tyConArgVrcs
445 orVrc :: (Bool,Bool) -> (Bool,Bool) -> (Bool,Bool)
446 orVrc (p1,m1) (p2,m2) = (p1||p2,m1||m2)
448 orVrcs :: [(Bool,Bool)] -> (Bool,Bool)
449 orVrcs = foldl orVrc (False,False)
451 negVrc :: (Bool,Bool) -> (Bool,Bool)
452 negVrc (p1,m1) = (m1,p1)
454 anyVrc :: (a -> (Bool,Bool)) -> [a] -> (Bool,Bool)
455 anyVrc p as = foldl (\ pm a -> pm `orVrc` p a)
458 timesVrc :: (Bool,Bool) -> (Bool,Bool) -> (Bool,Bool)
459 timesVrc (p1,m1) (p2,m2) = (p1 && p2 || m1 && m2,
460 p1 && m2 || m1 && p2)