[project @ 2000-07-14 08:17:36 by simonpj]
[ghc-hetmet.git] / ghc / compiler / types / Variance.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1999
3 %
4 \section[Variance]{Variance in @Type@ and @TyCon@}
5
6 \begin{code}
7 module Variance(
8         calcTyConArgVrcs,
9         tyVarVrc
10     ) where
11
12 #include "HsVersions.h"
13
14 import TypeRep          ( Type(..), TyNote(..) )  -- friend
15 import TyCon            ( TyCon, ArgVrcs, tyConKind, tyConArity, tyConDataConsIfAvailable, tyConTyVars,
16                           tyConArgVrcs_maybe, getSynTyConDefn, isSynTyCon, isAlgTyCon )
17 import DataCon          ( dataConRepArgTys )
18
19 import FiniteMap
20 import Var              ( TyVar )
21 import VarSet
22 import Name             ( Name, getName )
23 import Maybes           ( expectJust )
24 import Outputable
25 \end{code}
26
27
28 Computing the tyConArgVrcs info
29 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
30
31 @tyConArgVrcs@ gives a list of (occPos,occNeg) flags, one for each
32 tyvar.  For @AlgTyCon@s and @SynTyCon@s, this info must be precomputed
33 separately.  Note that this is information about occurrences of type
34 variables, not usages of term variables.
35
36 The function @calcTyConArgVrcs@ must be passed a list of *algebraic or
37 syntycons only* such that all tycons referred to (by mutual recursion)
38 appear in the list.  The fixpointing will be done on this set of
39 tycons as a whole.  It returns a list of @tyconVrcInfo@ data, ready to
40 be (knot-tyingly?) stuck back into the appropriate fields.
41
42 \begin{code}
43 calcTyConArgVrcs :: [TyCon] -> FiniteMap TyCon ArgVrcs
44
45 calcTyConArgVrcs tycons
46   = tcaoFix initial_oi
47   where
48
49     initial_oi :: FiniteMap TyCon ArgVrcs
50     initial_oi   = foldl (\fm tc -> addToFM fm tc (initial tc)) emptyFM tycons
51     initial tc   = if isAlgTyCon tc && null (tyConDataConsIfAvailable tc) then
52                          -- make pessimistic assumption (and warn)
53                          take (tyConArity tc) abstractVrcs
54                        else
55                          replicate (tyConArity tc) (False,False)
56
57     tcaoFix :: FiniteMap TyCon ArgVrcs   -- initial ArgVrcs per tycon
58             -> FiniteMap TyCon ArgVrcs   -- fixpointed ArgVrcs per tycon
59
60     tcaoFix oi = let (changed,oi') = foldFM (\ tc pms
61                                                (changed,oi')
62                                                -> let pms' = tcaoIter oi' tc  -- seq not simult
63                                                   in  (changed || (pms /= pms'),
64                                                        addToFM oi' tc pms'))
65                                             (False,oi)  -- seq not simult for faster fixpting
66                                             oi
67                  in  if changed
68                      then tcaoFix oi'
69                      else oi'
70
71     tcaoIter :: FiniteMap TyCon ArgVrcs  -- reference ArgVrcs (initial)
72              -> TyCon                    -- tycon to update
73              -> ArgVrcs                  -- new ArgVrcs for tycon
74
75     tcaoIter oi tc | isAlgTyCon tc
76       = if null data_cons then
77                 -- Abstract types get uninformative variances
78             abstractVrcs
79         else
80             map (\v -> anyVrc (\ty -> vrcInTy myfao v ty) argtys)
81                 vs
82       where
83         data_cons = tyConDataConsIfAvailable tc
84         vs        = tyConTyVars tc
85         argtys    = concatMap dataConRepArgTys data_cons
86         myfao tc  = lookupWithDefaultFM oi (expectJust "tcaoIter(Alg)" $
87                                                    tyConArgVrcs_maybe tc)
88                                            tc
89                          -- we use the already-computed result for tycons not in this SCC
90
91     tcaoIter oi tc | isSynTyCon tc
92       = let (tyvs,ty) = getSynTyConDefn tc
93             myfao tc  = lookupWithDefaultFM oi (expectJust "tcaoIter(Syn)" $
94                                                   tyConArgVrcs_maybe tc)
95                                                tc
96                         -- we use the already-computed result for tycons not in this SCC
97         in  map (\v -> vrcInTy myfao v ty) tyvs
98
99
100 abstractVrcs :: ArgVrcs
101 -- we pull this out as a CAF so the warning only appears *once*
102 abstractVrcs = trace ("WARNING: tyConArgVrc info inaccurate due to unavailable constructors.\n"
103                       ++ "\tUse -fno-prune-tydecls to fix.") $
104                  repeat (True,True)
105 \end{code}
106
107
108 Variance of tyvars in a type
109 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
110
111 A general variance-check function.  We pass a function for determining
112 the @ArgVrc@s of a tycon; when fixpointing this refers to the current
113 value; otherwise this should be looked up from the tycon's own
114 tyConArgVrcs.
115
116 \begin{code}
117 vrcInTy :: (TyCon -> ArgVrcs)  -- function to get argVrcs of a tycon (break out of recursion)
118         -> TyVar               -- tyvar to check Vrcs of
119         -> Type                -- type to check for occ in
120         -> (Bool,Bool)         -- (occurs positively, occurs negatively)
121
122 vrcInTy fao v (NoteTy (UsgNote _)   ty) = vrcInTy fao v ty
123
124 vrcInTy fao v (NoteTy (UsgForAll _) ty) = vrcInTy fao v ty
125
126 vrcInTy fao v (NoteTy (SynNote _)   ty) = vrcInTy fao v ty
127                         -- SynTyCon doesn't neccessarily have vrcInfo at this point,
128                         -- so don't try and use it
129
130 vrcInTy fao v (NoteTy (FTVNote ftv) ty) = if elemVarSet v ftv
131                                           then vrcInTy fao v ty
132                                           else (False,False)
133                         -- note that ftv cannot be calculated as occPos||occNeg,
134                         -- since if a tyvar occurs only as unused tyconarg,
135                         -- occPos==occNeg==False, but ftv=True
136
137 vrcInTy fao v (TyVarTy v')              = if v==v'
138                                           then (True,False)
139                                           else (False,False)
140
141 vrcInTy fao v (AppTy ty1 ty2)           = if vrcInTy fao v ty2 /= (False,False)
142                                           then (True,True)
143                                           else vrcInTy fao v ty1
144                         -- ty1 is probably unknown (or it would have been beta-reduced);
145                         -- hence if v occurs in ty2 at all then it could occur with
146                         -- either variance.  Otherwise it occurs as it does in ty1.
147
148 vrcInTy fao v (FunTy ty1 ty2)           = let (p1,m1) = vrcInTy fao v ty1
149                                               (p2,m2) = vrcInTy fao v ty2
150                                           in (m1||p2,p1||m2)
151                                          
152 vrcInTy fao v (ForAllTy v' ty)          = if v==v'
153                                           then (False,False)
154                                           else vrcInTy fao v ty
155
156 vrcInTy fao v (TyConApp tc tys)         = let pms1 = map (vrcInTy fao v) tys
157                                               pms2 = fao tc
158                                           in  orVrcs (zipWith timesVrc pms1 pms2)
159 \end{code}
160
161
162 External entry point: assumes tyconargvrcs already computed.
163
164 \begin{code}
165 tyVarVrc :: TyVar               -- tyvar to check Vrc of
166          -> Type                -- type to check for occ in
167          -> (Bool,Bool)         -- (occurs positively, occurs negatively)
168
169 tyVarVrc = vrcInTy (expectJust "tyVarVrcs" . tyConArgVrcs_maybe)
170 \end{code}
171
172
173 Variance algebra
174 ~~~~~~~~~~~~~~~~
175
176 \begin{code}
177 orVrc :: (Bool,Bool) -> (Bool,Bool) -> (Bool,Bool)
178 orVrc (p1,m1) (p2,m2) = (p1||p2,m1||m2)
179
180 orVrcs :: [(Bool,Bool)] -> (Bool,Bool)
181 orVrcs = foldl orVrc (False,False)
182
183 anyVrc :: (a -> (Bool,Bool)) -> [a] -> (Bool,Bool)
184 anyVrc p as = foldl (\ pm a -> pm `orVrc` p a)
185                     (False,False) as
186
187 timesVrc :: (Bool,Bool) -> (Bool,Bool) -> (Bool,Bool)
188 timesVrc (p1,m1) (p2,m2) = (p1 && p2 || m1 && m2,
189                             p1 && m2 || m1 && p2)
190 \end{code}