2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
13 FunDep, pprFundeps, pprFunDep,
15 mkClass, classTyVars, classArity,
16 classKey, className, classATs, classSelIds, classTyCon, classMethods,
17 classOpItems,classBigSig, classExtraBigSig, classTvsFds, classSCTheta
22 import {-# SOURCE #-} TyCon ( TyCon )
23 import {-# SOURCE #-} TypeRep ( PredType )
33 import qualified Data.Data as Data
36 %************************************************************************
38 \subsection[Class-basic]{@Class@: basic definition}
40 %************************************************************************
42 A @Class@ corresponds to a Greek kappa in the static semantics:
47 classKey :: Unique, -- Key for fast comparison
50 classTyVars :: [TyVar], -- The class type variables
51 classFunDeps :: [FunDep TyVar], -- The functional dependencies
53 classSCTheta :: [PredType], -- Immediate superclasses, and the
54 classSCSels :: [Id], -- corresponding selector functions
55 -- to extract them from a dictionary
58 classATs :: [TyCon], -- Associated type families
60 classOpStuff :: [ClassOpItem], -- Ordered by tag
62 classTyCon :: TyCon -- The data type constructor for
63 -- dictionaries of this class
66 type FunDep a = ([a],[a]) -- e.g. class C a b c | a b -> c, a c -> b where...
67 -- Here fun-deps are [([a,b],[c]), ([a,c],[b])]
69 type ClassOpItem = (Id, DefMeth)
70 -- Selector function; contains unfolding
71 -- Default-method info
73 data DefMeth = NoDefMeth -- No default method
74 | DefMeth Name -- A polymorphic default method
75 | GenDefMeth -- A generic default method
79 The @mkClass@ function fills in the indirect superclasses.
82 mkClass :: Name -> [TyVar]
83 -> [([TyVar], [TyVar])]
90 mkClass name tyvars fds super_classes superdict_sels ats
92 = Class { classKey = getUnique name,
96 classSCTheta = super_classes,
97 classSCSels = superdict_sels,
99 classOpStuff = op_stuff,
103 %************************************************************************
105 \subsection[Class-selectors]{@Class@: simple selectors}
107 %************************************************************************
109 The rest of these functions are just simple selectors.
112 classArity :: Class -> Arity
113 classArity clas = length (classTyVars clas)
114 -- Could memoise this
116 classSelIds :: Class -> [Id]
117 classSelIds c@(Class {classSCSels = sc_sels})
118 = sc_sels ++ classMethods c
120 classMethods :: Class -> [Id]
121 classMethods (Class {classOpStuff = op_stuff})
122 = [op_sel | (op_sel, _) <- op_stuff]
124 classOpItems :: Class -> [ClassOpItem]
125 classOpItems (Class {classOpStuff = op_stuff}) = op_stuff
127 classTvsFds :: Class -> ([TyVar], [FunDep TyVar])
129 = (classTyVars c, classFunDeps c)
131 classBigSig :: Class -> ([TyVar], [PredType], [Id], [ClassOpItem])
132 classBigSig (Class {classTyVars = tyvars, classSCTheta = sc_theta,
133 classSCSels = sc_sels, classOpStuff = op_stuff})
134 = (tyvars, sc_theta, sc_sels, op_stuff)
136 classExtraBigSig :: Class -> ([TyVar], [FunDep TyVar], [PredType], [Id], [TyCon], [ClassOpItem])
137 classExtraBigSig (Class {classTyVars = tyvars, classFunDeps = fundeps,
138 classSCTheta = sc_theta, classSCSels = sc_sels,
139 classATs = ats, classOpStuff = op_stuff})
140 = (tyvars, fundeps, sc_theta, sc_sels, ats, op_stuff)
144 %************************************************************************
146 \subsection[Class-instances]{Instance declarations for @Class@}
148 %************************************************************************
150 We compare @Classes@ by their keys (which include @Uniques@).
153 instance Eq Class where
154 c1 == c2 = classKey c1 == classKey c2
155 c1 /= c2 = classKey c1 /= classKey c2
157 instance Ord Class where
158 c1 <= c2 = classKey c1 <= classKey c2
159 c1 < c2 = classKey c1 < classKey c2
160 c1 >= c2 = classKey c1 >= classKey c2
161 c1 > c2 = classKey c1 > classKey c2
162 compare c1 c2 = classKey c1 `compare` classKey c2
166 instance Uniquable Class where
167 getUnique c = classKey c
169 instance NamedThing Class where
170 getName clas = className clas
172 instance Outputable Class where
173 ppr c = ppr (getName c)
175 instance Show Class where
176 showsPrec p c = showsPrecSDoc p (ppr c)
178 instance Outputable DefMeth where
179 ppr (DefMeth n) = ptext (sLit "Default method") <+> ppr n
180 ppr GenDefMeth = ptext (sLit "Generic default method")
181 ppr NoDefMeth = empty -- No default method
183 pprFundeps :: Outputable a => [FunDep a] -> SDoc
184 pprFundeps [] = empty
185 pprFundeps fds = hsep (ptext (sLit "|") : punctuate comma (map pprFunDep fds))
187 pprFunDep :: Outputable a => FunDep a -> SDoc
188 pprFunDep (us, vs) = hsep [interppSP us, ptext (sLit "->"), interppSP vs]
190 instance Data.Typeable Class where
191 typeOf _ = Data.mkTyConApp (Data.mkTyCon "Class") []
193 instance Data.Data Class where
195 toConstr _ = abstractConstr "Class"
196 gunfold _ _ = error "gunfold"
197 dataTypeOf _ = mkNoRepType "Class"