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

diff --git a/compiler/types/Class.lhs b/compiler/types/Class.lhs
index dc7cd91..d9e44e5 100644
--- a/compiler/types/Class.lhs
+++ b/compiler/types/Class.lhs
@@ -9,15 +9,18 @@ The @Class@ datatype
 module Class (
 	Class, ClassOpItem, 
 	DefMeth (..),
+	defMethSpecOfDefMeth,
 
 	FunDep,	pprFundeps, pprFunDep,
 
-	mkClass, classTyVars, classArity,
-	classKey, className, classATs, classSelIds, classTyCon, classMethods,
-	classOpItems,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 )
 import {-# SOURCE #-} TypeRep	( PredType )
@@ -50,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
@@ -72,8 +81,18 @@ type ClassOpItem = (Id, DefMeth)
 
 data DefMeth = NoDefMeth 		-- No default method
 	     | DefMeth Name  		-- A polymorphic default method
-	     | GenDefMeth 		-- A generic 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.
@@ -81,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}
 
 %************************************************************************
@@ -113,16 +133,28 @@ 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
+classOpItems (Class { classOpStuff = op_stuff})
+  = op_stuff
 
 classTvsFds :: Class -> ([TyVar], [FunDep TyVar])
 classTvsFds c
@@ -176,9 +208,9 @@ instance Show Class where
     showsPrec p c = showsPrecSDoc p (ppr c)
 
 instance Outputable DefMeth where
-    ppr (DefMeth n) =  ptext (sLit "Default method") <+> ppr n
-    ppr GenDefMeth  =  ptext (sLit "Generic default 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