\begin{code}
module Class (
- Class,
+ Class, ClassOpItem, FunDep,
+ DefMeth (..),
- mkClass,
- classKey, classSelIds, classTyCon,
- classSuperClassTheta,
- classBigSig, classInstEnv
+ mkClass, classTyVars, classArity,
+ classKey, className, classSelIds, classTyCon, classMethods,
+ classBigSig, classExtraBigSig, classTvsFds, classSCTheta
) where
#include "HsVersions.h"
import {-# SOURCE #-} TyCon ( TyCon )
-import {-# SOURCE #-} TypeRep ( Type )
-import {-# SOURCE #-} InstEnv ( InstEnv )
+import {-# SOURCE #-} TypeRep ( PredType )
import Var ( Id, TyVar )
import Name ( NamedThing(..), Name )
+import BasicTypes ( Arity )
import Unique ( Unique, Uniquable(..) )
import Outputable
-import Util
\end{code}
%************************************************************************
\begin{code}
data Class
- = Class
- Unique -- Key for fast comparison
- Name
-
- [TyVar] -- The class type variables
-
- [(Class,[Type])] -- Immediate superclasses, and the
- [Id] -- corresponding selector functions to
- -- extract them from a dictionary of this
- -- class
-
- [Id] -- * selector functions
- [Maybe Id] -- * default methods
- -- They are all ordered by tag. The
- -- selector ids contain unfoldings.
-
- InstEnv -- All the instances of this class
-
- TyCon -- The data type constructor for dictionaries
- -- of this class
+ = Class {
+ 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])]
+
+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
+ deriving Eq
\end{code}
The @mkClass@ function fills in the indirect superclasses.
\begin{code}
mkClass :: Name -> [TyVar]
- -> [(Class,[Type])] -> [Id]
- -> [Id] -> [Maybe Id]
+ -> [([TyVar], [TyVar])]
+ -> [PredType] -> [Id]
+ -> [ClassOpItem]
-> TyCon
- -> InstEnv
-> Class
-mkClass name tyvars super_classes superdict_sels
- dict_sels defms tycon class_insts
- = Class (getUnique name) name tyvars
- super_classes superdict_sels
- dict_sels defms
- class_insts
- tycon
+mkClass name tyvars fds super_classes superdict_sels
+ op_stuff tycon
+ = Class { classKey = getUnique name,
+ className = name,
+ classTyVars = tyvars,
+ classFunDeps = fds,
+ classSCTheta = super_classes,
+ classSCSels = superdict_sels,
+ classOpStuff = op_stuff,
+ classTyCon = tycon }
\end{code}
%************************************************************************
The rest of these functions are just simple selectors.
\begin{code}
-classKey (Class key _ _ _ _ _ _ _ _) = key
-classSuperClassTheta (Class _ _ _ scs _ _ _ _ _) = scs
-classSelIds (Class _ _ _ _ sc_sels op_sels _ _ _) = sc_sels ++ op_sels
-classTyCon (Class _ _ _ _ _ _ _ _ tc) = tc
-classInstEnv (Class _ _ _ _ _ _ _ env _) = env
-
-classBigSig (Class _ _ tyvars super_classes sdsels sels defms _ _)
- = (tyvars, super_classes, sdsels, sels, defms)
+classArity :: Class -> Arity
+classArity clas = length (classTyVars clas)
+ -- Could memoise this
+
+classSelIds :: Class -> [Id]
+classSelIds c@(Class {classSCSels = sc_sels})
+ = sc_sels ++ classMethods c
+
+classMethods :: Class -> [Id]
+classMethods (Class {classOpStuff = op_stuff})
+ = [op_sel | (op_sel, _) <- op_stuff]
+
+classTvsFds c
+ = (classTyVars c, classFunDeps c)
+
+classBigSig (Class {classTyVars = tyvars, classSCTheta = sc_theta,
+ classSCSels = sc_sels, classOpStuff = op_stuff})
+ = (tyvars, sc_theta, sc_sels, op_stuff)
+classExtraBigSig (Class {classTyVars = tyvars, classFunDeps = fundeps,
+ classSCTheta = sc_theta, classSCSels = sc_sels,
+ classOpStuff = op_stuff})
+ = (tyvars, fundeps, sc_theta, sc_sels, op_stuff)
\end{code}
getUnique c = classKey c
instance NamedThing Class where
- getName (Class _ n _ _ _ _ _ _ _) = n
+ 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 = text "{- has default method -}"
+ ppr GenDefMeth = text "{- has generic method -}"
+ ppr NoDefMeth = empty -- No default method
\end{code}