X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypes%2FClass.lhs;h=d9e44e591c4553700c0a969cb1d4da19e851e037;hp=051bef165cfa39567082b97977d5ec9d4312fe19;hb=7b5b3b0cab463e108a0132435a28ef19d17cb32b;hpb=56bcc14f7e3038a36992ce3b490e9e805f08da37

diff --git a/compiler/types/Class.lhs b/compiler/types/Class.lhs
index 051bef1..d9e44e5 100644
--- a/compiler/types/Class.lhs
+++ b/compiler/types/Class.lhs
@@ -9,14 +9,17 @@ The @Class@ datatype
 module Class (
 	Class, ClassOpItem, 
 	DefMeth (..),
+	defMethSpecOfDefMeth,
 
-	FunDep,	pprFundeps,
+	FunDep,	pprFundeps, pprFunDep,
 
-	mkClass, classTyVars, classArity,
-	classKey, className, classATs, classSelIds, classTyCon, classMethods,
-	classBigSig, classExtraBigSig, classTvsFds, classSCTheta
+	mkClass, classTyVars, classArity, classSCNEqs,
+	classKey, className, classATs, classTyCon, classMethods,
+	classOpItems, classBigSig, classExtraBigSig, classTvsFds, classSCTheta,
+        classAllSelIds, classSCSelId
     ) where
 
+#include "Typeable.h"
 #include "HsVersions.h"
 
 import {-# SOURCE #-} TyCon	( TyCon )
@@ -26,7 +29,11 @@ import Var
 import Name
 import BasicTypes
 import Unique
+import Util
 import Outputable
+import FastString
+
+import qualified Data.Data as Data
 \end{code}
 
 %************************************************************************
@@ -46,13 +53,19 @@ data Class
 	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
-
+	-- Superclasses: eg: (F a ~ b, F b ~ G a, Eq a, Show b)
+        -- We need value-level selectors for the dictionary 
+	-- superclasses, but not for the equality superclasses
+	classSCTheta :: [PredType],	-- Immediate superclasses, 
+		     			---   *with equalities first*
+        classSCNEqs  :: Int,		-- How many equalities
+	classSCSels  :: [Id],		-- Selector functions to extract the
+		     			--   *dictionary* superclasses from a 
+					--   dictionary of this class
+	-- Associated types
         classATs     :: [TyCon],	-- Associated type families
 
+        -- Class operations
 	classOpStuff :: [ClassOpItem],	-- Ordered by tag
 
 	classTyCon :: TyCon		-- The data type constructor for
@@ -67,9 +80,19 @@ type ClassOpItem = (Id, DefMeth)
 	-- Default-method info
 
 data DefMeth = NoDefMeth 		-- No default method
-	     | DefMeth  		-- A polymorphic default method
-	     | GenDefMeth 		-- A generic default method
+	     | DefMeth Name  		-- A polymorphic default method
+	     | GenDefMeth Name 		-- A generic default method
              deriving Eq  
+
+-- | Convert a `DefMethSpec` to a `DefMeth`, which discards the name field in
+--   the `DefMeth` constructor of the `DefMeth`.
+defMethSpecOfDefMeth :: DefMeth -> DefMethSpec
+defMethSpecOfDefMeth meth
+ = case meth of
+	NoDefMeth	-> NoDM
+	DefMeth _	-> VanillaDM
+	GenDefMeth _	-> GenericDM
+
 \end{code}
 
 The @mkClass@ function fills in the indirect superclasses.
@@ -77,23 +100,24 @@ The @mkClass@ function fills in the indirect superclasses.
 \begin{code}
 mkClass :: Name -> [TyVar]
 	-> [([TyVar], [TyVar])]
-	-> [PredType] -> [Id]
+	-> [PredType] -> Int -> [Id]
 	-> [TyCon]
 	-> [ClassOpItem]
 	-> TyCon
 	-> Class
 
-mkClass name tyvars fds super_classes superdict_sels ats 
+mkClass name tyvars fds super_classes n_eqs superdict_sels ats 
 	op_stuff tycon
-  = Class {	classKey = getUnique name, 
-		className = name,
-		classTyVars = tyvars,
+  = Class {	classKey     = getUnique name, 
+		className    = name,
+		classTyVars  = tyvars,
 		classFunDeps = fds,
 		classSCTheta = super_classes,
-		classSCSels = superdict_sels,
-		classATs = ats,
+                classSCNEqs  = n_eqs,
+		classSCSels  = superdict_sels,
+		classATs     = ats,
 		classOpStuff = op_stuff,
-		classTyCon = tycon }
+		classTyCon   = tycon }
 \end{code}
 
 %************************************************************************
@@ -109,14 +133,29 @@ classArity :: Class -> Arity
 classArity clas = length (classTyVars clas)
 	-- Could memoise this
 
-classSelIds :: Class -> [Id]
-classSelIds c@(Class {classSCSels = sc_sels})
+classAllSelIds :: Class -> [Id]
+-- Both superclass-dictionary and method selectors
+classAllSelIds c@(Class {classSCSels = sc_sels})
   = sc_sels ++ classMethods c
 
+classSCSelId :: Class -> Int -> Id
+-- Get the n'th superclass selector Id
+-- where n is 0-indexed, and counts 
+--    *all* superclasses including equalities
+classSCSelId (Class { classSCNEqs = n_eqs, classSCSels = sc_sels }) n
+  = ASSERT( sc_sel_index >= 0 && sc_sel_index < length sc_sels )
+    sc_sels !! sc_sel_index
+  where
+    sc_sel_index = n - n_eqs	-- 0-index into classSCSels
+
 classMethods :: Class -> [Id]
 classMethods (Class {classOpStuff = op_stuff})
   = [op_sel | (op_sel, _) <- op_stuff]
 
+classOpItems :: Class -> [ClassOpItem]
+classOpItems (Class { classOpStuff = op_stuff})
+  = op_stuff
+
 classTvsFds :: Class -> ([TyVar], [FunDep TyVar])
 classTvsFds c
   = (classTyVars c, classFunDeps c)
@@ -169,15 +208,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 NoDefMeth   =  empty   -- No default method
+    ppr (DefMeth n)    =  ptext (sLit "Default method") <+> ppr n
+    ppr (GenDefMeth n) =  ptext (sLit "Generic default method") <+> ppr n
+    ppr NoDefMeth      =  empty   -- No default method
 
 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]
+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}