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 Type             ( mkDictTy )
  16 import TyCon            ( TyCon, ArgVrcs, tyConKind, tyConArity, tyConDataCons, tyConTyVars,
  17                           tyConArgVrcs_maybe, getSynTyConDefn, isSynTyCon, isAlgTyCon )
  18 import DataCon          ( dataConRawArgTys, dataConSig )
  19
  20 import FiniteMap
  21 import Var              ( TyVar )
  22 import VarSet
  23 import Name             ( Name, getName )
  24 import Maybes           ( expectJust )
  25 import Outputable
  26 \end{code}
  27
  28
  29 Computing the tyConArgVrcs info
  30 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  31
  32 @tyConArgVrcs@ gives a list of (occPos,occNeg) flags, one for each
  33 tyvar.  For @AlgTyCon@s and @SynTyCon@s, this info must be precomputed
  34 separately.  Note that this is information about occurrences of type
  35 variables, not usages of term variables.
  36
  37 The function @calcTyConArgVrcs@ must be passed a list of *algebraic or
  38 syntycons only* such that all tycons referred to (by mutual recursion)
  39 appear in the list.  The fixpointing will be done on this set of
  40 tycons as a whole.  It returns a list of @tyconVrcInfo@ data, ready to
  41 be (knot-tyingly?) stuck back into the appropriate fields.
  42
  43 \begin{code}
  44 calcTyConArgVrcs :: [TyCon]
  45                  -> FiniteMap Name ArgVrcs
  46
  47 calcTyConArgVrcs tycons
  48   = let oi           = foldl (\fm tc -> addToFM fm tc (initial tc)) emptyFM tycons
  49         initial tc   = if isAlgTyCon tc && null (tyConDataCons tc) then
  50                          -- make pessimistic assumption (and warn)
  51                          take (tyConArity tc) abstractVrcs
  52                        else
  53                          replicate (tyConArity tc) (False,False)
  54         oi''         = tcaoFix oi
  55         go (tc,vrcs) = (getName tc,vrcs)
  56     in  listToFM (map go (fmToList oi''))
  57
  58   where
  59
  60     tcaoFix :: FiniteMap TyCon ArgVrcs   -- initial ArgVrcs per tycon
  61             -> FiniteMap TyCon ArgVrcs   -- fixpointed ArgVrcs per tycon
  62
  63     tcaoFix oi = let (changed,oi') = foldFM (\ tc pms
  64                                                (changed,oi')
  65                                                -> let pms' = tcaoIter oi' tc  -- seq not simult
  66                                                   in  (changed || (pms /= pms'),
  67                                                        addToFM oi' tc pms'))
  68                                             (False,oi)  -- seq not simult for faster fixpting
  69                                             oi
  70                  in  if changed
  71                      then tcaoFix oi'
  72                      else oi'
  73
  74     tcaoIter :: FiniteMap TyCon ArgVrcs  -- reference ArgVrcs (initial)
  75              -> TyCon                    -- tycon to update
  76              -> ArgVrcs                  -- new ArgVrcs for tycon
  77
  78     tcaoIter oi tc | isAlgTyCon tc
  79       = let cs        = tyConDataCons tc
  80             vs        = tyConTyVars tc
  81             argtys    = concatMap dataConRawArgTys cs
  82             exdicttys = concatMap ((\ (_,_,_,exth,_,_) -> map (uncurry mkDictTy) exth)
  83                                    . dataConSig) cs
  84             myfao tc  = lookupWithDefaultFM oi (expectJust "tcaoIter(Alg)" $
  85                                                   tyConArgVrcs_maybe tc)
  86                                                tc
  87                         -- we use the already-computed result for tycons not in this SCC
  88         in  map (\v -> anyVrc (\ty -> vrcInTy myfao v ty) (exdicttys ++ argtys))
  89                 vs
  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}