[project @ 2000-08-02 14:13:26 by rrt]

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

diff --git a/ghc/compiler/types/Variance.lhs b/ghc/compiler/types/Variance.lhs
index e3b34eb..57119ff 100644 (file)
--- a/ghc/compiler/types/Variance.lhs
+++ b/ghc/compiler/types/Variance.lhs
@@ -12,10 +12,9 @@ module Variance(
 #include "HsVersions.h"
 
 import TypeRep          ( Type(..), TyNote(..) )  -- friend
-import Type             ( mkDictTy )
-import TyCon            ( TyCon, ArgVrcs, tyConKind, tyConArity, tyConDataCons, tyConTyVars,
+import TyCon            ( TyCon, ArgVrcs, tyConKind, tyConArity, tyConDataConsIfAvailable, tyConTyVars,
                           tyConArgVrcs_maybe, getSynTyConDefn, isSynTyCon, isAlgTyCon )
-import DataCon          ( dataConRawArgTys, dataConSig )
+import DataCon          ( dataConRepArgTys )
 
 import FiniteMap
 import Var              ( TyVar )
@@ -41,21 +40,19 @@ tycons as a whole.  It returns a list of @tyconVrcInfo@ data, ready to
 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 (tyConDataCons 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 && null (tyConDataConsIfAvailable tc) then
                          -- make pessimistic assumption (and warn)
                          take (tyConArity tc) abstractVrcs
                        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
@@ -76,17 +73,20 @@ calcTyConArgVrcs tycons
             -> ArgVrcs                  -- new ArgVrcs for tycon
 
     tcaoIter oi tc | isAlgTyCon tc
-      = let cs        = tyConDataCons tc
-            vs        = tyConTyVars tc
-           argtys    = concatMap dataConRawArgTys cs
-            exdicttys = concatMap ((\ (_,_,_,exth,_,_) -> map (uncurry mkDictTy) exth)
-                                   . dataConSig) cs
-           myfao tc  = lookupWithDefaultFM oi (expectJust "tcaoIter(Alg)" $
-                                                  tyConArgVrcs_maybe tc)
-                                               tc
-                        -- we use the already-computed result for tycons not in this SCC
-        in  map (\v -> anyVrc (\ty -> vrcInTy myfao v ty) (exdicttys ++ argtys))
+      = if null data_cons then
+               -- Abstract types get uninformative variances
+           abstractVrcs
+       else
+            map (\v -> anyVrc (\ty -> vrcInTy myfao v ty) argtys)
                 vs
+      where
+               data_cons = tyConDataConsIfAvailable tc
+               vs        = tyConTyVars tc
+               argtys    = concatMap dataConRepArgTys data_cons
+               myfao tc  = lookupWithDefaultFM oi (expectJust "tcaoIter(Alg)" $
+                                                          tyConArgVrcs_maybe tc)
+                                                  tc
+                                -- we use the already-computed result for tycons not in this SCC
 
     tcaoIter oi tc | isSynTyCon tc
       = let (tyvs,ty) = getSynTyConDefn tc