Fix scoped type variables for expression type signatures

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

diff --git a/compiler/types/Class.lhs b/compiler/types/Class.lhs
index 016ce1b..abf7e4b 100644 (file)
--- a/compiler/types/Class.lhs
+++ b/compiler/types/Class.lhs
@@ -5,11 +5,13 @@
 
 \begin{code}
 module Class (
-       Class, ClassOpItem, FunDep,
+       Class, ClassOpItem, 
        DefMeth (..),
 
+       FunDep, pprFundeps,
+
        mkClass, classTyVars, classArity,
-       classKey, className, classSelIds, classTyCon, classMethods,
+       classKey, className, classATs, classSelIds, classTyCon, classMethods,
        classBigSig, classExtraBigSig, classTvsFds, classSCTheta
     ) where
 
@@ -36,24 +38,27 @@ A @Class@ corresponds to a Greek kappa in the static semantics:
 \begin{code}
 data Class
   = Class {
-       classKey  :: Unique,                    -- Key for fast comparison
+       classKey  :: Unique,            -- Key for fast comparison
        className :: Name,
        
-       classTyVars  :: [TyVar],                -- The class type variables
-       classFunDeps :: [FunDep TyVar],         -- The functional dependencies
+       classTyVars  :: [TyVar],        -- The class type variables
+       classFunDeps :: [FunDep TyVar], -- The functional dependencies
+
+       classSCTheta :: [PredType],     -- Immediate superclasses, and the
+       classSCSels  :: [Id],           -- corresponding selector functions
+                                       -- to extract them from a dictionary
+                                       -- of this class
 
-       classSCTheta :: [PredType],             -- Immediate superclasses, and the
-       classSCSels  :: [Id],                   -- corresponding selector functions to
-                                               -- extract them from a dictionary of this
-                                               -- class
+        classATs     :: [TyCon],       -- Associated type families
 
-       classOpStuff :: [ClassOpItem],          -- Ordered by tag
+       classOpStuff :: [ClassOpItem],  -- Ordered by tag
 
-       classTyCon :: TyCon             -- The data type constructor for dictionaries
-  }                                    -- of this class
+       classTyCon :: TyCon             -- The data type constructor for
+                                       -- dictionaries of this class
+     }
 
-type FunDep a    = ([a],[a])   --  e.g. class C a b c |  a b -> c, a c -> b  where ...
-                               --  Here fun-deps are [([a,b],[c]), ([a,c],[b])]
+type FunDep a = ([a],[a])  --  e.g. class C a b c | a b -> c, a c -> b where...
+                          --  Here fun-deps are [([a,b],[c]), ([a,c],[b])]
 
 type ClassOpItem = (Id, DefMeth)
        -- Selector function; contains unfolding
@@ -71,11 +76,12 @@ The @mkClass@ function fills in the indirect superclasses.
 mkClass :: Name -> [TyVar]
        -> [([TyVar], [TyVar])]
        -> [PredType] -> [Id]
+       -> [TyCon]
        -> [ClassOpItem]
        -> TyCon
        -> Class
 
-mkClass name tyvars fds super_classes superdict_sels
+mkClass name tyvars fds super_classes superdict_sels ats 
        op_stuff tycon
   = Class {    classKey = getUnique name, 
                className = name,
@@ -83,6 +89,7 @@ mkClass name tyvars fds super_classes superdict_sels
                classFunDeps = fds,
                classSCTheta = super_classes,
                classSCSels = superdict_sels,
+               classATs = ats,
                classOpStuff = op_stuff,
                classTyCon = tycon }
 \end{code}
@@ -116,8 +123,8 @@ classBigSig (Class {classTyVars = tyvars, classSCTheta = sc_theta,
   = (tyvars, sc_theta, sc_sels, op_stuff)
 classExtraBigSig (Class {classTyVars = tyvars, classFunDeps = fundeps,
                         classSCTheta = sc_theta, classSCSels = sc_sels,
-                        classOpStuff = op_stuff})
-  = (tyvars, fundeps, sc_theta, sc_sels, op_stuff)
+                        classATs = ats, classOpStuff = op_stuff})
+  = (tyvars, fundeps, sc_theta, sc_sels, ats, op_stuff)
 \end{code}
 
 
@@ -159,6 +166,12 @@ instance Outputable DefMeth where
     ppr DefMeth     =  text "{- has default method -}"
     ppr GenDefMeth  =  text "{- has generic method -}"
     ppr NoDefMeth   =  empty   -- No default method
-\end{code}
 
+pprFundeps :: Outputable a => [FunDep a] -> SDoc
+pprFundeps []  = empty
+pprFundeps fds = hsep (ptext SLIT("|") : punctuate comma (map ppr_fd fds))
+              where
+                ppr_fd (us, vs) = hsep [interppSP us, ptext SLIT("->"), 
+                                        interppSP vs]
+\end{code}