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, classSCNEqs,
17 classKey, className, classATs, classTyCon, classMethods,
18 classOpItems, classBigSig, classExtraBigSig, classTvsFds, classSCTheta,
19 classAllSelIds, classSCSelId
23 #include "HsVersions.h"
25 import {-# SOURCE #-} TyCon ( TyCon )
26 import {-# SOURCE #-} TypeRep ( PredType )
36 import qualified Data.Data as Data
39 %************************************************************************
41 \subsection[Class-basic]{@Class@: basic definition}
43 %************************************************************************
45 A @Class@ corresponds to a Greek kappa in the static semantics:
50 classKey :: Unique, -- Key for fast comparison
53 classTyVars :: [TyVar], -- The class type variables
54 classFunDeps :: [FunDep TyVar], -- The functional dependencies
56 -- Superclasses: eg: (F a ~ b, F b ~ G a, Eq a, Show b)
57 -- We need value-level selectors for the dictionary
58 -- superclasses, but not for the equality superclasses
59 classSCTheta :: [PredType], -- Immediate superclasses,
60 --- *with equalities first*
61 classSCNEqs :: Int, -- How many equalities
62 classSCSels :: [Id], -- Selector functions to extract the
63 -- *dictionary* superclasses from a
64 -- dictionary of this class
66 classATs :: [TyCon], -- Associated type families
69 classOpStuff :: [ClassOpItem], -- Ordered by tag
71 classTyCon :: TyCon -- The data type constructor for
72 -- dictionaries of this class
75 type FunDep a = ([a],[a]) -- e.g. class C a b c | a b -> c, a c -> b where...
76 -- Here fun-deps are [([a,b],[c]), ([a,c],[b])]
78 type ClassOpItem = (Id, DefMeth)
79 -- Selector function; contains unfolding
80 -- Default-method info
82 data DefMeth = NoDefMeth -- No default method
83 | DefMeth Name -- A polymorphic default method
84 | GenDefMeth -- A generic default method
87 -- | Convert a `DefMethSpec` to a `DefMeth`, which discards the name field in
88 -- the `DefMeth` constructor of the `DefMeth`.
89 defMethSpecOfDefMeth :: DefMeth -> DefMethSpec
90 defMethSpecOfDefMeth meth
93 DefMeth _ -> VanillaDM
94 GenDefMeth -> GenericDM
98 The @mkClass@ function fills in the indirect superclasses.
101 mkClass :: Name -> [TyVar]
102 -> [([TyVar], [TyVar])]
103 -> [PredType] -> Int -> [Id]
109 mkClass name tyvars fds super_classes n_eqs superdict_sels ats
111 = Class { classKey = getUnique name,
113 classTyVars = tyvars,
115 classSCTheta = super_classes,
117 classSCSels = superdict_sels,
119 classOpStuff = op_stuff,
123 %************************************************************************
125 \subsection[Class-selectors]{@Class@: simple selectors}
127 %************************************************************************
129 The rest of these functions are just simple selectors.
132 classArity :: Class -> Arity
133 classArity clas = length (classTyVars clas)
134 -- Could memoise this
136 classAllSelIds :: Class -> [Id]
137 -- Both superclass-dictionary and method selectors
138 classAllSelIds c@(Class {classSCSels = sc_sels})
139 = sc_sels ++ classMethods c
141 classSCSelId :: Class -> Int -> Id
142 -- Get the n'th superclass selector Id
143 -- where n is 0-indexed, and counts
144 -- *all* superclasses including equalities
145 classSCSelId (Class { classSCNEqs = n_eqs, classSCSels = sc_sels }) n
146 = ASSERT( sc_sel_index >= 0 && sc_sel_index < length sc_sels )
147 sc_sels !! sc_sel_index
149 sc_sel_index = n - n_eqs -- 0-index into classSCSels
151 classMethods :: Class -> [Id]
152 classMethods (Class {classOpStuff = op_stuff})
153 = [op_sel | (op_sel, _) <- op_stuff]
155 classOpItems :: Class -> [ClassOpItem]
156 classOpItems (Class { classOpStuff = op_stuff})
159 classTvsFds :: Class -> ([TyVar], [FunDep TyVar])
161 = (classTyVars c, classFunDeps c)
163 classBigSig :: Class -> ([TyVar], [PredType], [Id], [ClassOpItem])
164 classBigSig (Class {classTyVars = tyvars, classSCTheta = sc_theta,
165 classSCSels = sc_sels, classOpStuff = op_stuff})
166 = (tyvars, sc_theta, sc_sels, op_stuff)
168 classExtraBigSig :: Class -> ([TyVar], [FunDep TyVar], [PredType], [Id], [TyCon], [ClassOpItem])
169 classExtraBigSig (Class {classTyVars = tyvars, classFunDeps = fundeps,
170 classSCTheta = sc_theta, classSCSels = sc_sels,
171 classATs = ats, classOpStuff = op_stuff})
172 = (tyvars, fundeps, sc_theta, sc_sels, ats, op_stuff)
176 %************************************************************************
178 \subsection[Class-instances]{Instance declarations for @Class@}
180 %************************************************************************
182 We compare @Classes@ by their keys (which include @Uniques@).
185 instance Eq Class where
186 c1 == c2 = classKey c1 == classKey c2
187 c1 /= c2 = classKey c1 /= classKey c2
189 instance Ord Class where
190 c1 <= c2 = classKey c1 <= classKey c2
191 c1 < c2 = classKey c1 < classKey c2
192 c1 >= c2 = classKey c1 >= classKey c2
193 c1 > c2 = classKey c1 > classKey c2
194 compare c1 c2 = classKey c1 `compare` classKey c2
198 instance Uniquable Class where
199 getUnique c = classKey c
201 instance NamedThing Class where
202 getName clas = className clas
204 instance Outputable Class where
205 ppr c = ppr (getName c)
207 instance Show Class where
208 showsPrec p c = showsPrecSDoc p (ppr c)
210 instance Outputable DefMeth where
211 ppr (DefMeth n) = ptext (sLit "Default method") <+> ppr n
212 ppr GenDefMeth = ptext (sLit "Generic default method")
213 ppr NoDefMeth = empty -- No default method
215 pprFundeps :: Outputable a => [FunDep a] -> SDoc
216 pprFundeps [] = empty
217 pprFundeps fds = hsep (ptext (sLit "|") : punctuate comma (map pprFunDep fds))
219 pprFunDep :: Outputable a => FunDep a -> SDoc
220 pprFunDep (us, vs) = hsep [interppSP us, ptext (sLit "->"), interppSP vs]
222 instance Data.Typeable Class where
223 typeOf _ = Data.mkTyConApp (Data.mkTyCon "Class") []
225 instance Data.Data Class where
227 toConstr _ = abstractConstr "Class"
228 gunfold _ _ = error "gunfold"
229 dataTypeOf _ = mkNoRepType "Class"