#include "HsVersions.h"
import TypeRep ( Type(..), TyNote(..) ) -- friend
-import TyCon ( TyCon, ArgVrcs, tyConKind, tyConArity, tyConDataConsIfAvailable, tyConTyVars,
+import TyCon ( TyCon, ArgVrcs, tyConArity, tyConDataCons_maybe, tyConDataCons, tyConTyVars,
tyConArgVrcs_maybe, getSynTyConDefn, isSynTyCon, isAlgTyCon )
import DataCon ( dataConRepArgTys )
import FiniteMap
import Var ( TyVar )
import VarSet
-import Name ( Name, getName )
import Maybes ( expectJust )
+import Maybe ( isNothing )
import Outputable
\end{code}
be (knot-tyingly?) stuck back into the appropriate fields.
\begin{code}
-calcTyConArgVrcs :: [TyCon]
- -> FiniteMap Name ArgVrcs
+calcTyConArgVrcs :: [TyCon] -> FiniteMap TyCon ArgVrcs
calcTyConArgVrcs tycons
- = let oi = foldl (\fm tc -> addToFM fm tc (initial tc)) emptyFM tycons
- initial tc = if isAlgTyCon tc && null (tyConDataConsIfAvailable tc) then
+ = tcaoFix initial_oi
+ where
+
+ initial_oi :: FiniteMap TyCon ArgVrcs
+ initial_oi = foldl (\fm tc -> addToFM fm tc (initial tc)) emptyFM tycons
+ initial tc = if isAlgTyCon tc && isNothing (tyConDataCons_maybe tc) then
-- make pessimistic assumption (and warn)
- take (tyConArity tc) abstractVrcs
+ abstractVrcs tc
else
replicate (tyConArity tc) (False,False)
- oi'' = tcaoFix oi
- go (tc,vrcs) = (getName tc,vrcs)
- in listToFM (map go (fmToList oi''))
-
- where
tcaoFix :: FiniteMap TyCon ArgVrcs -- initial ArgVrcs per tycon
-> FiniteMap TyCon ArgVrcs -- fixpointed ArgVrcs per tycon
tcaoIter oi tc | isAlgTyCon tc
= if null data_cons then
-- Abstract types get uninformative variances
- abstractVrcs
+ abstractVrcs tc
else
map (\v -> anyVrc (\ty -> vrcInTy myfao v ty) argtys)
vs
where
- data_cons = tyConDataConsIfAvailable tc
+ data_cons = tyConDataCons tc
vs = tyConTyVars tc
argtys = concatMap dataConRepArgTys data_cons
myfao tc = lookupWithDefaultFM oi (expectJust "tcaoIter(Alg)" $
in map (\v -> vrcInTy myfao v ty) tyvs
-abstractVrcs :: ArgVrcs
--- we pull this out as a CAF so the warning only appears *once*
-abstractVrcs = trace ("WARNING: tyConArgVrc info inaccurate due to unavailable constructors.\n"
- ++ "\tUse -fno-prune-tydecls to fix.") $
- repeat (True,True)
+abstractVrcs :: TyCon -> ArgVrcs
+abstractVrcs tc =
+#ifdef DEBUG
+ pprTrace "Vrc: abstract tycon:" (ppr tc) $
+#endif
+ warn_abstract_vrcs `seq` replicate (tyConArity tc) (True,True)
+
+warn_abstract_vrcs
+-- we pull the message out as a CAF so the warning only appears *once*
+ = trace ("WARNING: tyConArgVrc info inaccurate due to unavailable constructors.\n"
+ ++ " Use -fno-prune-tydecls to fix.") $
+ ()
\end{code}
-> Type -- type to check for occ in
-> (Bool,Bool) -- (occurs positively, occurs negatively)
-vrcInTy fao v (NoteTy (UsgNote _) ty) = vrcInTy fao v ty
-
-vrcInTy fao v (NoteTy (UsgForAll _) ty) = vrcInTy fao v ty
-
vrcInTy fao v (NoteTy (SynNote _) ty) = vrcInTy fao v ty
-- SynTyCon doesn't neccessarily have vrcInfo at this point,
-- so don't try and use it
-- hence if v occurs in ty2 at all then it could occur with
-- either variance. Otherwise it occurs as it does in ty1.
-vrcInTy fao v (FunTy ty1 ty2) = let (p1,m1) = vrcInTy fao v ty1
- (p2,m2) = vrcInTy fao v ty2
- in (m1||p2,p1||m2)
+vrcInTy fao v (FunTy ty1 ty2) = negVrc (vrcInTy fao v ty1)
+ `orVrc`
+ vrcInTy fao v ty2
vrcInTy fao v (ForAllTy v' ty) = if v==v'
then (False,False)
orVrcs :: [(Bool,Bool)] -> (Bool,Bool)
orVrcs = foldl orVrc (False,False)
+negVrc :: (Bool,Bool) -> (Bool,Bool)
+negVrc (p1,m1) = (m1,p1)
+
anyVrc :: (a -> (Bool,Bool)) -> [a] -> (Bool,Bool)
anyVrc p as = foldl (\ pm a -> pm `orVrc` p a)
(False,False) as