Refactor (again) the handling of default methods

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

diff --git a/compiler/types/Class.lhs b/compiler/types/Class.lhs
index 016ce1b..27ec5c1 100644 (file)
--- a/compiler/types/Class.lhs
+++ b/compiler/types/Class.lhs
@@ -1,28 +1,36 @@
 %
+% (c) The University of Glasgow 2006
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-\section[Class]{The @Class@ datatype}
+
+The @Class@ datatype
 
 \begin{code}
 module Class (
-       Class, ClassOpItem, FunDep,
+       Class, ClassOpItem, 
        DefMeth (..),
 
+       FunDep, pprFundeps, pprFunDep,
+
        mkClass, classTyVars, classArity,
-       classKey, className, classSelIds, classTyCon, classMethods,
+       classKey, className, classATs, classSelIds, classTyCon, classMethods,
        classBigSig, classExtraBigSig, classTvsFds, classSCTheta
     ) where
 
-#include "HsVersions.h"
+#include "Typeable.h"
 
 import {-# SOURCE #-} TyCon    ( TyCon )
 import {-# SOURCE #-} TypeRep  ( PredType )
 
-import Var             ( Id, TyVar )
-import Name            ( NamedThing(..), Name )
-import BasicTypes      ( Arity )
-import Unique          ( Unique, Uniquable(..) )
+import Var
+import Name
+import BasicTypes
+import Unique
+import Util
 import Outputable
+import FastString
+
+import qualified Data.Data as Data
 \end{code}
 
 %************************************************************************
@@ -36,31 +44,34 @@ 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
 
-       classOpStuff :: [ClassOpItem],          -- Ordered by tag
+        classATs     :: [TyCon],       -- Associated type families
 
-       classTyCon :: TyCon             -- The data type constructor for dictionaries
-  }                                    -- of this class
+       classOpStuff :: [ClassOpItem],  -- Ordered by tag
 
-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])]
+       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 ClassOpItem = (Id, DefMeth)
        -- Selector function; contains unfolding
        -- Default-method info
 
 data DefMeth = NoDefMeth               -- No default method
-            | DefMeth                  -- A polymorphic default method
+            | DefMeth Name             -- A polymorphic default method
             | GenDefMeth               -- A generic default method
              deriving Eq  
 \end{code}
@@ -71,11 +82,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 +95,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}
@@ -108,16 +121,20 @@ classMethods :: Class -> [Id]
 classMethods (Class {classOpStuff = op_stuff})
   = [op_sel | (op_sel, _) <- op_stuff]
 
+classTvsFds :: Class -> ([TyVar], [FunDep TyVar])
 classTvsFds c
   = (classTyVars c, classFunDeps c)
 
+classBigSig :: Class -> ([TyVar], [PredType], [Id], [ClassOpItem])
 classBigSig (Class {classTyVars = tyvars, classSCTheta = sc_theta, 
                    classSCSels = sc_sels, classOpStuff = op_stuff})
   = (tyvars, sc_theta, sc_sels, op_stuff)
+
+classExtraBigSig :: Class -> ([TyVar], [FunDep TyVar], [PredType], [Id], [TyCon], [ClassOpItem])
 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}
 
 
@@ -156,9 +173,24 @@ instance Show Class where
     showsPrec p c = showsPrecSDoc p (ppr c)
 
 instance Outputable DefMeth where
-    ppr DefMeth     =  text "{- has default method -}"
-    ppr GenDefMeth  =  text "{- has generic method -}"
+    ppr (DefMeth n) =  ptext (sLit "Default method") <+> ppr n
+    ppr GenDefMeth  =  ptext (sLit "Generic default 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 pprFunDep fds))
+
+pprFunDep :: Outputable a => FunDep a -> SDoc
+pprFunDep (us, vs) = hsep [interppSP us, ptext (sLit "->"), interppSP vs]
+
+instance Data.Typeable Class where
+    typeOf _ = Data.mkTyConApp (Data.mkTyCon "Class") []
+
+instance Data.Data Class where
+    -- don't traverse?
+    toConstr _   = abstractConstr "Class"
+    gunfold _ _  = error "gunfold"
+    dataTypeOf _ = mkNoRepType "Class"
+\end{code}