X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypes%2FClass.lhs;h=d9e44e591c4553700c0a969cb1d4da19e851e037;hp=016ce1bfbed54ee6096c2d588f72417780ea15ab;hb=7b5b3b0cab463e108a0132435a28ef19d17cb32b;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1 diff --git a/compiler/types/Class.lhs b/compiler/types/Class.lhs index 016ce1b..d9e44e5 100644 --- a/compiler/types/Class.lhs +++ b/compiler/types/Class.lhs @@ -1,28 +1,39 @@ % +% (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 (..), + defMethSpecOfDefMeth, + + FunDep, pprFundeps, pprFunDep, - mkClass, classTyVars, classArity, - classKey, className, 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 ) 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,33 +47,52 @@ 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 - - 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 - - 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])] + classTyVars :: [TyVar], -- The class type variables + classFunDeps :: [FunDep TyVar], -- The functional dependencies + + -- 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 + -- 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 - | 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. @@ -70,21 +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 +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, + classSCNEqs = n_eqs, + classSCSels = superdict_sels, + classATs = ats, classOpStuff = op_stuff, - classTyCon = tycon } + classTyCon = tycon } \end{code} %************************************************************************ @@ -100,24 +133,43 @@ 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) +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 +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 -\end{code} + 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 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}