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.
16 calcRecFlags, calcCycleErrs,
20 #include "HsVersions.h"
22 import TypeRep ( Type(..), TyNote(..), PredType(..) ) -- friend
23 import HsSyn ( TyClDecl(..), HsPred(..), LTyClDecl )
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(..) )
40 import SrcLoc ( Located(..) )
45 %************************************************************************
47 Cycles in class and type synonym declarations
49 %************************************************************************
51 We check for type synonym and class cycles on the *source* code.
54 a) Otherwise we'd need a special function to extract type-synonym tycons
55 from a type, whereas we have extractHsTyNames already
57 b) If we checked for type synonym loops after building the TyCon, we
58 can't do a hoistForAllTys on the type synonym rhs, (else we fall into
59 a black hole) which seems unclean. Apart from anything else, it'd mean
60 that a type-synonym rhs could have for-alls to the right of an arrow,
61 which means adding new cases to the validity checker
63 Indeed, in general, checking for cycles beforehand means we need to
64 be less careful about black holes through synonym cycles.
66 The main disadvantage is that a cycle that goes via a type synonym in an
67 .hi-boot file can lead the compiler into a loop, because it assumes that cycles
68 only occur in source code. But hi-boot files are trusted anyway, so this isn't
69 much worse than (say) a kind error.
71 [ NOTE ----------------------------------------------
72 If we reverse this decision, this comment came from tcTyDecl1, and should
74 -- dsHsType, not tcHsKindedType, to avoid a loop. tcHsKindedType does hoisting,
75 -- which requires looking through synonyms... and therefore goes into a loop
76 -- on (erroneously) recursive synonyms.
77 -- Solution: do not hoist synonyms, because they'll be hoisted soon enough
78 -- when they are substituted
80 We'd also need to add back in this definition
82 synTyConsOfType :: Type -> [TyCon]
83 -- Does not look through type synonyms at all
84 -- Return a list of synonym tycons
88 go :: Type -> NameEnv TyCon -- The NameEnv does duplicate elim
89 go (TyVarTy v) = emptyNameEnv
90 go (TyConApp tc tys) = go_tc tc tys -- See note (a)
91 go (NewTcApp tc tys) = go_s tys -- Ignore tycon
92 go (AppTy a b) = go a `plusNameEnv` go b
93 go (FunTy a b) = go a `plusNameEnv` go b
94 go (PredTy (IParam _ ty)) = go ty
95 go (PredTy (ClassP cls tys)) = go_s tys -- Ignore class
96 go (NoteTy (SynNote ty) _) = go ty -- Don't look through it!
97 go (NoteTy other ty) = go ty
98 go (ForAllTy _ ty) = go ty
100 -- Note (a): the unexpanded branch of a SynNote has a
101 -- TyConApp for the synonym, so the tc of
102 -- a TyConApp must be tested for possible synonyms
104 go_tc tc tys | isSynTyCon tc = extendNameEnv (go_s tys) (tyConName tc) tc
105 | otherwise = go_s tys
106 go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys
107 ---------------------------------------- END NOTE ]
110 calcCycleErrs :: [LTyClDecl Name] -> ([[Name]], -- Recursive type synonym groups
111 [[Name]]) -- Ditto classes
113 = (findCyclics syn_edges, findCyclics cls_edges)
115 --------------- Type synonyms ----------------------
116 syn_edges = [ (name, mk_syn_edges rhs) |
117 L _ (TySynonym { tcdLName = L _ name,
118 tcdSynRhs = rhs }) <- decls ]
120 mk_syn_edges rhs = [ tc | tc <- nameSetToList (extractHsTyNames rhs),
121 not (isTyVarName tc) ]
123 --------------- Classes ----------------------
124 cls_edges = [ (name, mk_cls_edges ctxt) |
125 L _ (ClassDecl { tcdLName = L _ name,
126 tcdCtxt = L _ ctxt }) <- decls ]
128 mk_cls_edges ctxt = [ cls | L _ (HsClassP cls _) <- ctxt ]
132 %************************************************************************
134 Deciding which type constructors are recursive
136 %************************************************************************
138 A newtype M.T is defined to be "recursive" iff
139 (a) its rhs mentions an abstract (hi-boot) TyCon
140 or (b) one can get from T's rhs to T via type
141 synonyms, or non-recursive newtypes *in M*
142 e.g. newtype T = MkT (T -> Int)
144 (a) is conservative; it assumes that the hi-boot type can loop
145 around to T. That's why in (b) we can restrict attention
146 to tycons in M, because any loops through newtypes outside M
147 will be broken by those newtypes
149 An algebraic data type M.T is "recursive" iff
150 it has just one constructor, and
151 (a) its arg types mention an abstract (hi-boot) TyCon
152 or (b) one can get from its arg types to T via type synonyms,
153 or by non-recursive newtypes or non-recursive product types in M
154 e.g. data T = MkT (T -> Int) Bool
156 A type synonym is recursive if one can get from its
157 right hand side back to it via type synonyms. (This is
158 reported as an error.)
160 A class is recursive if one can get from its superclasses
161 back to it. (This is an error too.)
165 A data type read from an hi-boot file will have an Unknown in its data constructors,
166 and will respond True to isHiBootTyCon. The idea is that we treat these as if one
167 could get from these types to anywhere. So when we see
170 import {-# SOURCE #-} Foo( T )
173 then we mark S as recursive, just in case. What that means is that if we see
178 then we don't need to look inside S to compute R's recursiveness. Since S is imported
179 (not from an hi-boot file), one cannot get from R back to S except via an hi-boot file,
180 and that means that some data type will be marked recursive along the way. So R is
181 unconditionly non-recursive (i.e. there'll be a loop breaker elsewhere if necessary)
183 This in turn means that we grovel through fewer interface files when computing
184 recursiveness, because we need only look at the type decls in the module being
185 compiled, plus the outer structure of directly-mentioned types.
188 calcRecFlags :: [TyThing] -> (Name -> RecFlag)
192 is_rec n | n `elemNameSet` rec_names = Recursive
193 | otherwise = NonRecursive
195 rec_names = nt_loop_breakers `unionNameSets` prod_loop_breakers
197 all_tycons = map getTyCon tyclss -- Recursion of newtypes/data types
198 -- can happen via the class TyCon
200 -------------------------------------------------
202 -- These edge-construction loops rely on
203 -- every loop going via tyclss, the types and classes
204 -- in the module being compiled. Stuff in interface
205 -- files should be correctly marked. If not (e.g. a
206 -- type synonym in a hi-boot file) we can get an infinite
207 -- loop. We could program round this, but it'd make the code
208 -- rather less nice, so I'm not going to do that yet.
210 --------------- Newtypes ----------------------
211 new_tycons = filter isNewTyCon all_tycons
212 nt_loop_breakers = mkNameSet (findLoopBreakers nt_edges)
213 is_rec_nt tc = tyConName tc `elemNameSet` nt_loop_breakers
214 -- is_rec_nt is a locally-used helper function
216 nt_edges = [(t, mk_nt_edges t) | t <- new_tycons]
218 mk_nt_edges nt -- Invariant: nt is a newtype
219 = concatMap (mk_nt_edges1 nt) (tcTyConsOfType (newTyConRhs nt))
220 -- tyConsOfType looks through synonyms
223 | tc `elem` new_tycons = [tc] -- Loop
224 | isHiBootTyCon tc = [nt] -- Make it self-recursive if
225 -- it mentions an hi-boot TyCon
226 -- At this point we know that either it's a local data type,
227 -- or it's imported. Either way, it can't form part of a cycle
230 --------------- Product types ----------------------
231 -- The "prod_tycons" are the non-newtype products
232 prod_tycons = [tc | tc <- all_tycons,
233 not (isNewTyCon tc), isProductTyCon tc]
234 prod_loop_breakers = mkNameSet (findLoopBreakers prod_edges)
236 prod_edges = [(tc, mk_prod_edges tc) | tc <- prod_tycons]
238 mk_prod_edges tc -- Invariant: tc is a product tycon
239 = concatMap (mk_prod_edges1 tc) (dataConOrigArgTys (head (tyConDataCons tc)))
241 mk_prod_edges1 ptc ty = concatMap (mk_prod_edges2 ptc) (tcTyConsOfType ty)
243 mk_prod_edges2 ptc tc
244 | tc `elem` prod_tycons = [tc] -- Local product
245 | tc `elem` new_tycons = if is_rec_nt tc -- Local newtype
247 else mk_prod_edges1 ptc (newTyConRhs tc)
248 | isHiBootTyCon tc = [ptc] -- Make it self-recursive if
249 -- it mentions an hi-boot TyCon
250 -- At this point we know that either it's a local non-product data type,
251 -- or it's imported. Either way, it can't form part of a cycle
254 getTyCon (ATyCon tc) = tc
255 getTyCon (AClass cl) = classTyCon cl
257 findLoopBreakers :: [(TyCon, [TyCon])] -> [Name]
258 -- Finds a set of tycons that cut all loops
259 findLoopBreakers deps
260 = go [(tc,tc,ds) | (tc,ds) <- deps]
263 | CyclicSCC ((tc,_,_) : edges') <- stronglyConnCompR edges,
264 name <- tyConName tc : go edges']
266 findCyclics :: [(Name,[Name])] -> [[Name]]
268 = [names | CyclicSCC names <- stronglyConnComp edges]
270 edges = [(name,name,ds) | (name,ds) <- deps]
273 These two functions know about type representations, so they could be
274 in Type or TcType -- but they are very specialised to this module, so
275 I've chosen to put them here.
278 tcTyConsOfType :: Type -> [TyCon]
279 -- tcTyConsOfType looks through all synonyms, but not through any newtypes.
280 -- When it finds a Class, it returns the class TyCon. The reaons it's here
281 -- (not in Type.lhs) is because it is newtype-aware.
283 = nameEnvElts (go ty)
285 go :: Type -> NameEnv TyCon -- The NameEnv does duplicate elim
286 go (TyVarTy v) = emptyNameEnv
287 go (TyConApp tc tys) = go_tc tc tys
288 go (NewTcApp tc tys) = go_tc tc tys
289 go (AppTy a b) = go a `plusNameEnv` go b
290 go (FunTy a b) = go a `plusNameEnv` go b
291 go (PredTy (IParam _ ty)) = go ty
292 go (PredTy (ClassP cls tys)) = go_tc (classTyCon cls) tys
293 go (NoteTy _ ty) = go ty
294 go (ForAllTy _ ty) = go ty
296 go_tc tc tys = extendNameEnv (go_s tys) (tyConName tc) tc
297 go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys
301 %************************************************************************
303 Compuing TyCon argument variances
305 %************************************************************************
307 Computing the tyConArgVrcs info
308 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
310 @tyConArgVrcs@ gives a list of (occPos,occNeg) flags, one for each
311 tyvar. For @AlgTyCon@s and @SynTyCon@s, this info must be precomputed
312 separately. Note that this is information about occurrences of type
313 variables, not usages of term variables.
315 The function @calcTyConArgVrcs@ must be passed a list of *algebraic or
316 syntycons only* such that all tycons referred to (by mutual recursion)
317 appear in the list. The fixpointing will be done on this set of
318 tycons as a whole. It returns a list of @tyconVrcInfo@ data, ready to
319 be (knot-tyingly?) stuck back into the appropriate fields.
322 calcTyConArgVrcs :: [TyThing] -> Name -> ArgVrcs
323 -- Gives arg variances for TyCons,
324 -- including the class TyCon of a class
325 calcTyConArgVrcs tyclss
328 tycons = map getTyCon tyclss
330 -- We should only look up things that are in the map
331 get_vrc n = case lookupNameEnv final_oi n of
333 Nothing -> pprPanic "calcVrcs" (ppr n)
335 -- We are going to fold over this map,
336 -- so we need the TyCon in the range
337 final_oi :: NameEnv (TyCon, ArgVrcs)
338 final_oi = tcaoFix initial_oi
340 initial_oi :: NameEnv (TyCon, ArgVrcs)
341 initial_oi = mkNameEnv [(tyConName tc, (tc, initial tc))
343 initial tc = replicate (tyConArity tc) (False,False)
345 tcaoFix :: NameEnv (TyCon, ArgVrcs) -- initial ArgVrcs per tycon
346 -> NameEnv (TyCon, ArgVrcs) -- fixpointed ArgVrcs per tycon
348 | changed = tcaoFix oi'
351 (changed,oi') = foldNameEnv iterate (False,oi) oi
353 iterate (tc, pms) (changed,oi')
354 = (changed || (pms /= pms'),
355 extendNameEnv oi' (tyConName tc) (tc, pms'))
357 pms' = tcaoIter oi' tc -- seq not simult
359 tcaoIter :: NameEnv (TyCon, ArgVrcs) -- reference ArgVrcs (initial)
360 -> TyCon -- tycon to update
361 -> ArgVrcs -- new ArgVrcs for tycon
363 tcaoIter oi tc | isAlgTyCon tc
364 = map (\v -> anyVrc (vrcInTy (lookup oi) v) argtys) vs
366 data_cons = tyConDataCons tc
368 argtys = concatMap dataConRepArgTys data_cons -- Rep? or Orig?
370 tcaoIter oi tc | isSynTyCon tc
371 = let (tyvs,ty) = getSynTyConDefn tc
372 -- we use the already-computed result for tycons not in this SCC
373 in map (\v -> vrcInTy (lookup oi) v ty) tyvs
375 lookup oi tc = case lookupNameEnv oi (tyConName tc) of
377 Nothing -> tyConArgVrcs tc
378 -- We use the already-computed result for tycons not in this SCC
382 Variance of tyvars in a type
383 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
385 A general variance-check function. We pass a function for determining
386 the @ArgVrc@s of a tycon; when fixpointing this refers to the current
387 value; otherwise this should be looked up from the tycon's own
388 tyConArgVrcs. Again, it knows the representation of Types.
391 vrcInTy :: (TyCon -> ArgVrcs) -- function to get argVrcs of a tycon (break out of recursion)
392 -> TyVar -- tyvar to check Vrcs of
393 -> Type -- type to check for occ in
394 -> (Bool,Bool) -- (occurs positively, occurs negatively)
396 vrcInTy fao v (NoteTy (SynNote _) ty) = vrcInTy fao v ty
397 -- SynTyCon doesn't neccessarily have vrcInfo at this point,
398 -- so don't try and use it
400 vrcInTy fao v (NoteTy (FTVNote ftv) ty) = if elemVarSet v ftv
401 then vrcInTy fao v ty
403 -- note that ftv cannot be calculated as occPos||occNeg,
404 -- since if a tyvar occurs only as unused tyconarg,
405 -- occPos==occNeg==False, but ftv=True
407 vrcInTy fao v (TyVarTy v') = if v==v'
411 vrcInTy fao v (AppTy ty1 ty2) = if vrcInTy fao v ty2 /= (False,False)
413 else vrcInTy fao v ty1
414 -- ty1 is probably unknown (or it would have been beta-reduced);
415 -- hence if v occurs in ty2 at all then it could occur with
416 -- either variance. Otherwise it occurs as it does in ty1.
418 vrcInTy fao v (FunTy ty1 ty2) = negVrc (vrcInTy fao v ty1)
422 vrcInTy fao v (ForAllTy v' ty) = if v==v'
424 else vrcInTy fao v ty
426 vrcInTy fao v (TyConApp tc tys) = let pms1 = map (vrcInTy fao v) tys
428 in orVrcs (zipWith timesVrc pms1 pms2)
430 vrcInTy fao v (NewTcApp tc tys) = let pms1 = map (vrcInTy fao v) tys
432 in orVrcs (zipWith timesVrc pms1 pms2)
434 vrcInTy fao v (PredTy st) = vrcInTy fao v (predTypeRep st)
441 orVrc :: (Bool,Bool) -> (Bool,Bool) -> (Bool,Bool)
442 orVrc (p1,m1) (p2,m2) = (p1||p2,m1||m2)
444 orVrcs :: [(Bool,Bool)] -> (Bool,Bool)
445 orVrcs = foldl orVrc (False,False)
447 negVrc :: (Bool,Bool) -> (Bool,Bool)
448 negVrc (p1,m1) = (m1,p1)
450 anyVrc :: (a -> (Bool,Bool)) -> [a] -> (Bool,Bool)
451 anyVrc p as = foldl (\ pm a -> pm `orVrc` p a)
454 timesVrc :: (Bool,Bool) -> (Bool,Bool) -> (Bool,Bool)
455 timesVrc (p1,m1) (p2,m2) = (p1 && p2 || m1 && m2,
456 p1 && m2 || m1 && p2)