2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
15 mkClass, classTyVars, classArity,
16 classKey, className, classATs, classSelIds, classTyCon, classMethods,
17 classBigSig, classExtraBigSig, classTvsFds, classSCTheta
20 #include "HsVersions.h"
22 import {-# SOURCE #-} TyCon ( TyCon )
23 import {-# SOURCE #-} TypeRep ( PredType )
32 %************************************************************************
34 \subsection[Class-basic]{@Class@: basic definition}
36 %************************************************************************
38 A @Class@ corresponds to a Greek kappa in the static semantics:
43 classKey :: Unique, -- Key for fast comparison
46 classTyVars :: [TyVar], -- The class type variables
47 classFunDeps :: [FunDep TyVar], -- The functional dependencies
49 classSCTheta :: [PredType], -- Immediate superclasses, and the
50 classSCSels :: [Id], -- corresponding selector functions
51 -- to extract them from a dictionary
54 classATs :: [TyCon], -- Associated type families
56 classOpStuff :: [ClassOpItem], -- Ordered by tag
58 classTyCon :: TyCon -- The data type constructor for
59 -- dictionaries of this class
62 type FunDep a = ([a],[a]) -- e.g. class C a b c | a b -> c, a c -> b where...
63 -- Here fun-deps are [([a,b],[c]), ([a,c],[b])]
65 type ClassOpItem = (Id, DefMeth)
66 -- Selector function; contains unfolding
67 -- Default-method info
69 data DefMeth = NoDefMeth -- No default method
70 | DefMeth -- A polymorphic default method
71 | GenDefMeth -- A generic default method
75 The @mkClass@ function fills in the indirect superclasses.
78 mkClass :: Name -> [TyVar]
79 -> [([TyVar], [TyVar])]
86 mkClass name tyvars fds super_classes superdict_sels ats
88 = Class { classKey = getUnique name,
92 classSCTheta = super_classes,
93 classSCSels = superdict_sels,
95 classOpStuff = op_stuff,
99 %************************************************************************
101 \subsection[Class-selectors]{@Class@: simple selectors}
103 %************************************************************************
105 The rest of these functions are just simple selectors.
108 classArity :: Class -> Arity
109 classArity clas = length (classTyVars clas)
110 -- Could memoise this
112 classSelIds :: Class -> [Id]
113 classSelIds c@(Class {classSCSels = sc_sels})
114 = sc_sels ++ classMethods c
116 classMethods :: Class -> [Id]
117 classMethods (Class {classOpStuff = op_stuff})
118 = [op_sel | (op_sel, _) <- op_stuff]
120 classTvsFds :: Class -> ([TyVar], [FunDep TyVar])
122 = (classTyVars c, classFunDeps c)
124 classBigSig :: Class -> ([TyVar], [PredType], [Id], [ClassOpItem])
125 classBigSig (Class {classTyVars = tyvars, classSCTheta = sc_theta,
126 classSCSels = sc_sels, classOpStuff = op_stuff})
127 = (tyvars, sc_theta, sc_sels, op_stuff)
129 classExtraBigSig :: Class -> ([TyVar], [FunDep TyVar], [PredType], [Id], [TyCon], [ClassOpItem])
130 classExtraBigSig (Class {classTyVars = tyvars, classFunDeps = fundeps,
131 classSCTheta = sc_theta, classSCSels = sc_sels,
132 classATs = ats, classOpStuff = op_stuff})
133 = (tyvars, fundeps, sc_theta, sc_sels, ats, op_stuff)
137 %************************************************************************
139 \subsection[Class-instances]{Instance declarations for @Class@}
141 %************************************************************************
143 We compare @Classes@ by their keys (which include @Uniques@).
146 instance Eq Class where
147 c1 == c2 = classKey c1 == classKey c2
148 c1 /= c2 = classKey c1 /= classKey c2
150 instance Ord Class where
151 c1 <= c2 = classKey c1 <= classKey c2
152 c1 < c2 = classKey c1 < classKey c2
153 c1 >= c2 = classKey c1 >= classKey c2
154 c1 > c2 = classKey c1 > classKey c2
155 compare c1 c2 = classKey c1 `compare` classKey c2
159 instance Uniquable Class where
160 getUnique c = classKey c
162 instance NamedThing Class where
163 getName clas = className clas
165 instance Outputable Class where
166 ppr c = ppr (getName c)
168 instance Show Class where
169 showsPrec p c = showsPrecSDoc p (ppr c)
171 instance Outputable DefMeth where
172 ppr DefMeth = text "{- has default method -}"
173 ppr GenDefMeth = text "{- has generic method -}"
174 ppr NoDefMeth = empty -- No default method
176 pprFundeps :: Outputable a => [FunDep a] -> SDoc
177 pprFundeps [] = empty
178 pprFundeps fds = hsep (ptext SLIT("|") : punctuate comma (map ppr_fd fds))
180 ppr_fd (us, vs) = hsep [interppSP us, ptext SLIT("->"),