2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
14 FunDep, pprFundeps, pprFunDep,
16 mkClass, classTyVars, classArity,
17 classKey, className, classATs, classSelIds, classTyCon, classMethods, classOpItems,
18 classBigSig, classExtraBigSig, classTvsFds, classSCTheta
23 import {-# SOURCE #-} TyCon ( TyCon )
24 import {-# SOURCE #-} TypeRep ( PredType )
34 import qualified Data.Data as Data
37 %************************************************************************
39 \subsection[Class-basic]{@Class@: basic definition}
41 %************************************************************************
43 A @Class@ corresponds to a Greek kappa in the static semantics:
48 classKey :: Unique, -- Key for fast comparison
51 classTyVars :: [TyVar], -- The class type variables
52 classFunDeps :: [FunDep TyVar], -- The functional dependencies
54 classSCTheta :: [PredType], -- Immediate superclasses, and the
55 classSCSels :: [Id], -- corresponding selector functions
56 -- to extract them from a dictionary
59 classATs :: [TyCon], -- Associated type families
61 classOpStuff :: [ClassOpItem], -- Ordered by tag
63 classTyCon :: TyCon -- The data type constructor for
64 -- dictionaries of this class
67 type FunDep a = ([a],[a]) -- e.g. class C a b c | a b -> c, a c -> b where...
68 -- Here fun-deps are [([a,b],[c]), ([a,c],[b])]
70 type ClassOpItem = (Id, DefMeth)
71 -- Selector function; contains unfolding
72 -- Default-method info
74 data DefMeth = NoDefMeth -- No default method
75 | DefMeth Name -- A polymorphic default method
76 | GenDefMeth -- A generic default method
79 -- | Convert a `DefMethSpec` to a `DefMeth`, which discards the name field in
80 -- the `DefMeth` constructor of the `DefMeth`.
81 defMethSpecOfDefMeth :: DefMeth -> DefMethSpec
82 defMethSpecOfDefMeth meth
85 DefMeth _ -> VanillaDM
86 GenDefMeth -> GenericDM
90 The @mkClass@ function fills in the indirect superclasses.
93 mkClass :: Name -> [TyVar]
94 -> [([TyVar], [TyVar])]
101 mkClass name tyvars fds super_classes superdict_sels ats
103 = Class { classKey = getUnique name,
105 classTyVars = tyvars,
107 classSCTheta = super_classes,
108 classSCSels = superdict_sels,
110 classOpStuff = op_stuff,
114 %************************************************************************
116 \subsection[Class-selectors]{@Class@: simple selectors}
118 %************************************************************************
120 The rest of these functions are just simple selectors.
123 classArity :: Class -> Arity
124 classArity clas = length (classTyVars clas)
125 -- Could memoise this
127 classSelIds :: Class -> [Id]
128 classSelIds c@(Class {classSCSels = sc_sels})
129 = sc_sels ++ classMethods c
131 classMethods :: Class -> [Id]
132 classMethods (Class {classOpStuff = op_stuff})
133 = [op_sel | (op_sel, _) <- op_stuff]
135 classOpItems :: Class -> [ClassOpItem]
136 classOpItems (Class { classOpStuff = op_stuff})
139 classTvsFds :: Class -> ([TyVar], [FunDep TyVar])
141 = (classTyVars c, classFunDeps c)
143 classBigSig :: Class -> ([TyVar], [PredType], [Id], [ClassOpItem])
144 classBigSig (Class {classTyVars = tyvars, classSCTheta = sc_theta,
145 classSCSels = sc_sels, classOpStuff = op_stuff})
146 = (tyvars, sc_theta, sc_sels, op_stuff)
148 classExtraBigSig :: Class -> ([TyVar], [FunDep TyVar], [PredType], [Id], [TyCon], [ClassOpItem])
149 classExtraBigSig (Class {classTyVars = tyvars, classFunDeps = fundeps,
150 classSCTheta = sc_theta, classSCSels = sc_sels,
151 classATs = ats, classOpStuff = op_stuff})
152 = (tyvars, fundeps, sc_theta, sc_sels, ats, op_stuff)
156 %************************************************************************
158 \subsection[Class-instances]{Instance declarations for @Class@}
160 %************************************************************************
162 We compare @Classes@ by their keys (which include @Uniques@).
165 instance Eq Class where
166 c1 == c2 = classKey c1 == classKey c2
167 c1 /= c2 = classKey c1 /= classKey c2
169 instance Ord Class where
170 c1 <= c2 = classKey c1 <= classKey c2
171 c1 < c2 = classKey c1 < classKey c2
172 c1 >= c2 = classKey c1 >= classKey c2
173 c1 > c2 = classKey c1 > classKey c2
174 compare c1 c2 = classKey c1 `compare` classKey c2
178 instance Uniquable Class where
179 getUnique c = classKey c
181 instance NamedThing Class where
182 getName clas = className clas
184 instance Outputable Class where
185 ppr c = ppr (getName c)
187 instance Show Class where
188 showsPrec p c = showsPrecSDoc p (ppr c)
190 instance Outputable DefMeth where
191 ppr (DefMeth n) = ptext (sLit "Default method") <+> ppr n
192 ppr GenDefMeth = ptext (sLit "Generic default method")
193 ppr NoDefMeth = empty -- No default method
195 pprFundeps :: Outputable a => [FunDep a] -> SDoc
196 pprFundeps [] = empty
197 pprFundeps fds = hsep (ptext (sLit "|") : punctuate comma (map pprFunDep fds))
199 pprFunDep :: Outputable a => FunDep a -> SDoc
200 pprFunDep (us, vs) = hsep [interppSP us, ptext (sLit "->"), interppSP vs]
202 instance Data.Typeable Class where
203 typeOf _ = Data.mkTyConApp (Data.mkTyCon "Class") []
205 instance Data.Data Class where
207 toConstr _ = abstractConstr "Class"
208 gunfold _ _ = error "gunfold"
209 dataTypeOf _ = mkNoRepType "Class"