\begin{code}
module Class (
- Class, ClassOpItem, ClassPred, ClassContext, FunDep,
+ Class, ClassOpItem, FunDep,
+ DefMeth (..),
- mkClass, classTyVars,
- classKey, className, classSelIds, classTyCon,
- classBigSig, classExtraBigSig, classInstEnv, classTvsFds
+ 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}
%************************************************************************
classTyVars :: [TyVar], -- The class type variables
classFunDeps :: [FunDep TyVar], -- The functional dependencies
- classSCTheta :: [(Class,[Type])], -- Immediate superclasses, and the
+ 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
- classInstEnv :: InstEnv, -- All the instances of this class
-
classTyCon :: TyCon -- The data type constructor for dictionaries
} -- of this class
-type ClassPred = (Class, [Type])
-type ClassContext = [ClassPred]
-
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, -- Selector function; contains unfolding
- Id, -- Default methods
- Bool) -- True <=> an explicit default method was
- -- supplied in the class decl
+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]
-> [([TyVar], [TyVar])]
- -> [(Class,[Type])] -> [Id]
- -> [(Id, Id, Bool)]
+ -> [PredType] -> [Id]
+ -> [ClassOpItem]
-> TyCon
- -> InstEnv
-> Class
mkClass name tyvars fds super_classes superdict_sels
- op_stuff tycon class_insts
+ op_stuff tycon
= Class { classKey = getUnique name,
className = name,
classTyVars = tyvars,
classSCTheta = super_classes,
classSCSels = superdict_sels,
classOpStuff = op_stuff,
- classInstEnv = class_insts,
classTyCon = tycon }
\end{code}
The rest of these functions are just simple selectors.
\begin{code}
-classSelIds (Class {classSCSels = sc_sels, classOpStuff = op_stuff})
- = sc_sels ++ [op_sel | (op_sel, _, _) <- op_stuff]
+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)
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}