2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1999
4 \section[Variance]{Variance in @Type@ and @TyCon@}
12 #include "HsVersions.h"
14 import TypeRep ( Type(..), TyNote(..) ) -- friend
15 import TyCon ( TyCon, ArgVrcs, tyConArity, tyConDataConsIfAvailable, tyConTyVars,
16 tyConArgVrcs_maybe, getSynTyConDefn, isSynTyCon, isAlgTyCon )
17 import DataCon ( dataConRepArgTys )
22 import Maybes ( expectJust )
27 Computing the tyConArgVrcs info
28 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
30 @tyConArgVrcs@ gives a list of (occPos,occNeg) flags, one for each
31 tyvar. For @AlgTyCon@s and @SynTyCon@s, this info must be precomputed
32 separately. Note that this is information about occurrences of type
33 variables, not usages of term variables.
35 The function @calcTyConArgVrcs@ must be passed a list of *algebraic or
36 syntycons only* such that all tycons referred to (by mutual recursion)
37 appear in the list. The fixpointing will be done on this set of
38 tycons as a whole. It returns a list of @tyconVrcInfo@ data, ready to
39 be (knot-tyingly?) stuck back into the appropriate fields.
42 calcTyConArgVrcs :: [TyCon] -> FiniteMap TyCon ArgVrcs
44 calcTyConArgVrcs tycons
48 initial_oi :: FiniteMap TyCon ArgVrcs
49 initial_oi = foldl (\fm tc -> addToFM fm tc (initial tc)) emptyFM tycons
50 initial tc = if isAlgTyCon tc && null (tyConDataConsIfAvailable tc) then
51 -- make pessimistic assumption (and warn)
54 replicate (tyConArity tc) (False,False)
56 tcaoFix :: FiniteMap TyCon ArgVrcs -- initial ArgVrcs per tycon
57 -> FiniteMap TyCon ArgVrcs -- fixpointed ArgVrcs per tycon
59 tcaoFix oi = let (changed,oi') = foldFM (\ tc pms
61 -> let pms' = tcaoIter oi' tc -- seq not simult
62 in (changed || (pms /= pms'),
64 (False,oi) -- seq not simult for faster fixpting
70 tcaoIter :: FiniteMap TyCon ArgVrcs -- reference ArgVrcs (initial)
71 -> TyCon -- tycon to update
72 -> ArgVrcs -- new ArgVrcs for tycon
74 tcaoIter oi tc | isAlgTyCon tc
75 = if null data_cons then
76 -- Abstract types get uninformative variances
79 map (\v -> anyVrc (\ty -> vrcInTy myfao v ty) argtys)
82 data_cons = tyConDataConsIfAvailable tc
84 argtys = concatMap dataConRepArgTys data_cons
85 myfao tc = lookupWithDefaultFM oi (expectJust "tcaoIter(Alg)" $
86 tyConArgVrcs_maybe tc)
88 -- we use the already-computed result for tycons not in this SCC
90 tcaoIter oi tc | isSynTyCon tc
91 = let (tyvs,ty) = getSynTyConDefn tc
92 myfao tc = lookupWithDefaultFM oi (expectJust "tcaoIter(Syn)" $
93 tyConArgVrcs_maybe tc)
95 -- we use the already-computed result for tycons not in this SCC
96 in map (\v -> vrcInTy myfao v ty) tyvs
99 abstractVrcs :: TyCon -> ArgVrcs
102 pprTrace "Vrc: abstract tycon:" (ppr tc) $
104 warn_abstract_vrcs `seq` replicate (tyConArity tc) (True,True)
107 -- we pull the message out as a CAF so the warning only appears *once*
108 = trace ("WARNING: tyConArgVrc info inaccurate due to unavailable constructors.\n"
109 ++ " Use -fno-prune-tydecls to fix.") $
114 Variance of tyvars in a type
115 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
117 A general variance-check function. We pass a function for determining
118 the @ArgVrc@s of a tycon; when fixpointing this refers to the current
119 value; otherwise this should be looked up from the tycon's own
123 vrcInTy :: (TyCon -> ArgVrcs) -- function to get argVrcs of a tycon (break out of recursion)
124 -> TyVar -- tyvar to check Vrcs of
125 -> Type -- type to check for occ in
126 -> (Bool,Bool) -- (occurs positively, occurs negatively)
128 vrcInTy fao v (NoteTy (SynNote _) ty) = vrcInTy fao v ty
129 -- SynTyCon doesn't neccessarily have vrcInfo at this point,
130 -- so don't try and use it
132 vrcInTy fao v (NoteTy (FTVNote ftv) ty) = if elemVarSet v ftv
133 then vrcInTy fao v ty
135 -- note that ftv cannot be calculated as occPos||occNeg,
136 -- since if a tyvar occurs only as unused tyconarg,
137 -- occPos==occNeg==False, but ftv=True
139 vrcInTy fao v (TyVarTy v') = if v==v'
143 vrcInTy fao v (AppTy ty1 ty2) = if vrcInTy fao v ty2 /= (False,False)
145 else vrcInTy fao v ty1
146 -- ty1 is probably unknown (or it would have been beta-reduced);
147 -- hence if v occurs in ty2 at all then it could occur with
148 -- either variance. Otherwise it occurs as it does in ty1.
150 vrcInTy fao v (FunTy ty1 ty2) = negVrc (vrcInTy fao v ty1)
154 vrcInTy fao v (ForAllTy v' ty) = if v==v'
156 else vrcInTy fao v ty
158 vrcInTy fao v (TyConApp tc tys) = let pms1 = map (vrcInTy fao v) tys
160 in orVrcs (zipWith timesVrc pms1 pms2)
162 vrcInTy fao v (UsageTy u ty) = vrcInTy fao v u `orVrc` vrcInTy fao v ty
166 External entry point: assumes tyconargvrcs already computed.
169 tyVarVrc :: TyVar -- tyvar to check Vrc of
170 -> Type -- type to check for occ in
171 -> (Bool,Bool) -- (occurs positively, occurs negatively)
173 tyVarVrc = vrcInTy (expectJust "tyVarVrcs" . tyConArgVrcs_maybe)
181 orVrc :: (Bool,Bool) -> (Bool,Bool) -> (Bool,Bool)
182 orVrc (p1,m1) (p2,m2) = (p1||p2,m1||m2)
184 orVrcs :: [(Bool,Bool)] -> (Bool,Bool)
185 orVrcs = foldl orVrc (False,False)
187 negVrc :: (Bool,Bool) -> (Bool,Bool)
188 negVrc (p1,m1) = (m1,p1)
190 anyVrc :: (a -> (Bool,Bool)) -> [a] -> (Bool,Bool)
191 anyVrc p as = foldl (\ pm a -> pm `orVrc` p a)
194 timesVrc :: (Bool,Bool) -> (Bool,Bool) -> (Bool,Bool)
195 timesVrc (p1,m1) (p2,m2) = (p1 && p2 || m1 && m2,
196 p1 && m2 || m1 && p2)