%
% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
The @Class@ datatype
\begin{code}
module Class (
Class, ClassOpItem,
DefMeth (..),
defMethSpecOfDefMeth,
FunDep, pprFundeps, pprFunDep,
mkClass, classTyVars, classArity, classSCNEqs,
classKey, className, classATs, classTyCon, classMethods,
classOpItems, classBigSig, classExtraBigSig, classTvsFds, classSCTheta,
classAllSelIds, classSCSelId
) where
#include "Typeable.h"
#include "HsVersions.h"
import TyCon ( TyCon )
import TypeRep ( PredType )
import Var
import Name
import BasicTypes
import Unique
import Util
import Outputable
import FastString
import qualified Data.Data as Data
\end{code}
%************************************************************************
%* *
\subsection[Class-basic]{@Class@: basic definition}
%* *
%************************************************************************
A @Class@ corresponds to a Greek kappa in the static semantics:
\begin{code}
data Class
= Class {
classKey :: Unique,
className :: Name,
classTyVars :: [TyVar],
classFunDeps :: [FunDep TyVar],
classSCTheta :: [PredType],
classSCNEqs :: Int,
classSCSels :: [Id],
classATs :: [TyCon],
classOpStuff :: [ClassOpItem],
classTyCon :: TyCon
}
type FunDep a = ([a],[a])
type ClassOpItem = (Id, DefMeth)
data DefMeth = NoDefMeth
| DefMeth Name
| GenDefMeth
deriving Eq
defMethSpecOfDefMeth :: DefMeth -> DefMethSpec
defMethSpecOfDefMeth meth
= case meth of
NoDefMeth -> NoDM
DefMeth _ -> VanillaDM
GenDefMeth -> GenericDM
\end{code}
The @mkClass@ function fills in the indirect superclasses.
\begin{code}
mkClass :: Name -> [TyVar]
-> [([TyVar], [TyVar])]
-> [PredType] -> Int -> [Id]
-> [TyCon]
-> [ClassOpItem]
-> TyCon
-> Class
mkClass name tyvars fds super_classes n_eqs superdict_sels ats
op_stuff tycon
= Class { classKey = getUnique name,
className = name,
classTyVars = tyvars,
classFunDeps = fds,
classSCTheta = super_classes,
classSCNEqs = n_eqs,
classSCSels = superdict_sels,
classATs = ats,
classOpStuff = op_stuff,
classTyCon = tycon }
\end{code}
%************************************************************************
%* *
\subsection[Class-selectors]{@Class@: simple selectors}
%* *
%************************************************************************
The rest of these functions are just simple selectors.
\begin{code}
classArity :: Class -> Arity
classArity clas = length (classTyVars clas)
classAllSelIds :: Class -> [Id]
classAllSelIds c@(Class {classSCSels = sc_sels})
= sc_sels ++ classMethods c
classSCSelId :: Class -> Int -> Id
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
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,
classATs = ats, classOpStuff = op_stuff})
= (tyvars, fundeps, sc_theta, sc_sels, ats, op_stuff)
\end{code}
%************************************************************************
%* *
\subsection[Class-instances]{Instance declarations for @Class@}
%* *
%************************************************************************
We compare @Classes@ by their keys (which include @Uniques@).
\begin{code}
instance Eq Class where
c1 == c2 = classKey c1 == classKey c2
c1 /= c2 = classKey c1 /= classKey c2
instance Ord Class where
c1 <= c2 = classKey c1 <= classKey c2
c1 < c2 = classKey c1 < classKey c2
c1 >= c2 = classKey c1 >= classKey c2
c1 > c2 = classKey c1 > classKey c2
compare c1 c2 = classKey c1 `compare` classKey c2
\end{code}
\begin{code}
instance Uniquable Class where
getUnique c = classKey c
instance NamedThing Class where
getName clas = className clas
instance Outputable Class where
ppr c = ppr (getName c)
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
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
toConstr _ = abstractConstr "Class"
gunfold _ _ = error "gunfold"
dataTypeOf _ = mkNoRepType "Class"
\end{code}