[project @ 2003-07-21 15:14:18 by ross]

[ghc-hetmet.git] / ghc / compiler / types / Variance.lhs

diff --git a/ghc/compiler/types/Variance.lhs b/ghc/compiler/types/Variance.lhs
index 57119ff..5f4b3f6 100644 (file)
--- a/ghc/compiler/types/Variance.lhs
+++ b/ghc/compiler/types/Variance.lhs
@@ -12,15 +12,15 @@ module Variance(
 #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}
 
@@ -48,9 +48,9 @@ calcTyConArgVrcs tycons
 
     initial_oi :: FiniteMap TyCon ArgVrcs
     initial_oi   = foldl (\fm tc -> addToFM fm tc (initial tc)) emptyFM tycons
-    initial tc   = if isAlgTyCon tc && null (tyConDataConsIfAvailable tc) then
+    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)
 
@@ -75,12 +75,12 @@ calcTyConArgVrcs tycons
     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)" $
@@ -97,11 +97,18 @@ calcTyConArgVrcs tycons
         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}
 
 
@@ -119,10 +126,6 @@ vrcInTy :: (TyCon -> ArgVrcs)  -- function to get argVrcs of a tycon (break out
         -> 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
@@ -145,9 +148,9 @@ vrcInTy fao v (AppTy ty1 ty2)           = if vrcInTy fao v ty2 /= (False,False)
                         -- 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)
@@ -180,6 +183,9 @@ orVrc (p1,m1) (p2,m2) = (p1||p2,m1||m2)
 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