aa95f13ac3a8b8accd0152ab8a0220548df3fd32
[ghc.git] / compiler / types / Class.hs
1 -- (c) The University of Glasgow 2006
2 -- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3 --
4 -- The @Class@ datatype
5
6 {-# LANGUAGE CPP #-}
7
8 module Class (
9 Class,
10 ClassOpItem,
11 ClassATItem(..),
12 ClassMinimalDef,
13 DefMethInfo, pprDefMethInfo,
14
15 FunDep, pprFundeps, pprFunDep,
16
17 mkClass, mkAbstractClass, classTyVars, classArity,
18 classKey, className, classATs, classATItems, classTyCon, classMethods,
19 classOpItems, classBigSig, classExtraBigSig, classTvsFds, classSCTheta,
20 classAllSelIds, classSCSelId, classMinimalDef, classHasFds,
21 isAbstractClass,
22 ) where
23
24 #include "HsVersions.h"
25
26 import GhcPrelude
27
28 import {-# SOURCE #-} TyCon ( TyCon )
29 import {-# SOURCE #-} TyCoRep ( Type, PredType, pprType )
30 import Var
31 import Name
32 import BasicTypes
33 import Unique
34 import Util
35 import SrcLoc
36 import Outputable
37 import BooleanFormula (BooleanFormula, mkTrue)
38
39 import qualified Data.Data as Data
40
41 {-
42 ************************************************************************
43 * *
44 \subsection[Class-basic]{@Class@: basic definition}
45 * *
46 ************************************************************************
47
48 A @Class@ corresponds to a Greek kappa in the static semantics:
49 -}
50
51 data Class
52 = Class {
53 classTyCon :: TyCon, -- The data type constructor for
54 -- dictionaries of this class
55 -- See Note [ATyCon for classes] in TyCoRep
56
57 className :: Name, -- Just the cached name of the TyCon
58 classKey :: Unique, -- Cached unique of TyCon
59
60 classTyVars :: [TyVar], -- The class kind and type variables;
61 -- identical to those of the TyCon
62 -- If you want visibility info, look at the classTyCon
63 -- This field is redundant because it's duplicated in the
64 -- classTyCon, but classTyVars is used quite often, so maybe
65 -- it's a bit faster to cache it here
66
67 classFunDeps :: [FunDep TyVar], -- The functional dependencies
68
69 classBody :: ClassBody -- Superclasses, ATs, methods
70
71 }
72
73 -- | e.g.
74 --
75 -- > class C a b c | a b -> c, a c -> b where...
76 --
77 -- Here fun-deps are [([a,b],[c]), ([a,c],[b])]
78 --
79 -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow'',
80
81 -- For details on above see note [Api annotations] in ApiAnnotation
82 type FunDep a = ([a],[a])
83
84 type ClassOpItem = (Id, DefMethInfo)
85 -- Selector function; contains unfolding
86 -- Default-method info
87
88 type DefMethInfo = Maybe (Name, DefMethSpec Type)
89 -- Nothing No default method
90 -- Just ($dm, VanillaDM) A polymorphic default method, name $dm
91 -- Just ($gm, GenericDM ty) A generic default method, name $gm, type ty
92 -- The generic dm type is *not* quantified
93 -- over the class variables; ie has the
94 -- class variables free
95
96 data ClassATItem
97 = ATI TyCon -- See Note [Associated type tyvar names]
98 (Maybe (Type, SrcSpan))
99 -- Default associated type (if any) from this template
100 -- Note [Associated type defaults]
101
102 type ClassMinimalDef = BooleanFormula Name -- Required methods
103
104 data ClassBody
105 = AbstractClass
106 | ConcreteClass {
107 -- Superclasses: eg: (F a ~ b, F b ~ G a, Eq a, Show b)
108 -- We need value-level selectors for both the dictionary
109 -- superclasses and the equality superclasses
110 classSCThetaStuff :: [PredType], -- Immediate superclasses,
111 classSCSels :: [Id], -- Selector functions to extract the
112 -- superclasses from a
113 -- dictionary of this class
114 -- Associated types
115 classATStuff :: [ClassATItem], -- Associated type families
116
117 -- Class operations (methods, not superclasses)
118 classOpStuff :: [ClassOpItem], -- Ordered by tag
119
120 -- Minimal complete definition
121 classMinimalDefStuff :: ClassMinimalDef
122 }
123 -- TODO: maybe super classes should be allowed in abstract class definitions
124
125 classMinimalDef :: Class -> ClassMinimalDef
126 classMinimalDef Class{ classBody = ConcreteClass{ classMinimalDefStuff = d } } = d
127 classMinimalDef _ = mkTrue -- TODO: make sure this is the right direction
128
129 {-
130 Note [Associated type defaults]
131 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
132 The following is an example of associated type defaults:
133 class C a where
134 data D a r
135
136 type F x a b :: *
137 type F p q r = (p,q)->r -- Default
138
139 Note that
140
141 * The TyCons for the associated types *share type variables* with the
142 class, so that we can tell which argument positions should be
143 instantiated in an instance decl. (The first for 'D', the second
144 for 'F'.)
145
146 * We can have default definitions only for *type* families,
147 not data families
148
149 * In the default decl, the "patterns" should all be type variables,
150 but (in the source language) they don't need to be the same as in
151 the 'type' decl signature or the class. It's more like a
152 free-standing 'type instance' declaration.
153
154 * HOWEVER, in the internal ClassATItem we rename the RHS to match the
155 tyConTyVars of the family TyCon. So in the example above we'd get
156 a ClassATItem of
157 ATI F ((x,a) -> b)
158 So the tyConTyVars of the family TyCon bind the free vars of
159 the default Type rhs
160
161 The @mkClass@ function fills in the indirect superclasses.
162
163 The SrcSpan is for the entire original declaration.
164 -}
165
166 mkClass :: Name -> [TyVar]
167 -> [FunDep TyVar]
168 -> [PredType] -> [Id]
169 -> [ClassATItem]
170 -> [ClassOpItem]
171 -> ClassMinimalDef
172 -> TyCon
173 -> Class
174
175 mkClass cls_name tyvars fds super_classes superdict_sels at_stuff
176 op_stuff mindef tycon
177 = Class { classKey = nameUnique cls_name,
178 className = cls_name,
179 -- NB: tyConName tycon = cls_name,
180 -- But it takes a module loop to assert it here
181 classTyVars = tyvars,
182 classFunDeps = fds,
183 classBody = ConcreteClass {
184 classSCThetaStuff = super_classes,
185 classSCSels = superdict_sels,
186 classATStuff = at_stuff,
187 classOpStuff = op_stuff,
188 classMinimalDefStuff = mindef
189 },
190 classTyCon = tycon }
191
192 mkAbstractClass :: Name -> [TyVar]
193 -> [FunDep TyVar]
194 -> TyCon
195 -> Class
196
197 mkAbstractClass cls_name tyvars fds tycon
198 = Class { classKey = nameUnique cls_name,
199 className = cls_name,
200 -- NB: tyConName tycon = cls_name,
201 -- But it takes a module loop to assert it here
202 classTyVars = tyvars,
203 classFunDeps = fds,
204 classBody = AbstractClass,
205 classTyCon = tycon }
206
207 {-
208 Note [Associated type tyvar names]
209 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
210 The TyCon of an associated type should use the same variable names as its
211 parent class. Thus
212 class C a b where
213 type F b x a :: *
214 We make F use the same Name for 'a' as C does, and similary 'b'.
215
216 The reason for this is when checking instances it's easier to match
217 them up, to ensure they match. Eg
218 instance C Int [d] where
219 type F [d] x Int = ....
220 we should make sure that the first and third args match the instance
221 header.
222
223 Having the same variables for class and tycon is also used in checkValidRoles
224 (in TcTyClsDecls) when checking a class's roles.
225
226
227 ************************************************************************
228 * *
229 \subsection[Class-selectors]{@Class@: simple selectors}
230 * *
231 ************************************************************************
232
233 The rest of these functions are just simple selectors.
234 -}
235
236 classArity :: Class -> Arity
237 classArity clas = length (classTyVars clas)
238 -- Could memoise this
239
240 classAllSelIds :: Class -> [Id]
241 -- Both superclass-dictionary and method selectors
242 classAllSelIds c@(Class { classBody = ConcreteClass { classSCSels = sc_sels }})
243 = sc_sels ++ classMethods c
244 classAllSelIds c = ASSERT( null (classMethods c) ) []
245
246 classSCSelId :: Class -> Int -> Id
247 -- Get the n'th superclass selector Id
248 -- where n is 0-indexed, and counts
249 -- *all* superclasses including equalities
250 classSCSelId (Class { classBody = ConcreteClass { classSCSels = sc_sels } }) n
251 = ASSERT( n >= 0 && lengthExceeds sc_sels n )
252 sc_sels !! n
253 classSCSelId c n = pprPanic "classSCSelId" (ppr c <+> ppr n)
254
255 classMethods :: Class -> [Id]
256 classMethods (Class { classBody = ConcreteClass { classOpStuff = op_stuff } })
257 = [op_sel | (op_sel, _) <- op_stuff]
258 classMethods _ = []
259
260 classOpItems :: Class -> [ClassOpItem]
261 classOpItems (Class { classBody = ConcreteClass { classOpStuff = op_stuff }})
262 = op_stuff
263 classOpItems _ = []
264
265 classATs :: Class -> [TyCon]
266 classATs (Class { classBody = ConcreteClass { classATStuff = at_stuff } })
267 = [tc | ATI tc _ <- at_stuff]
268 classATs _ = []
269
270 classATItems :: Class -> [ClassATItem]
271 classATItems (Class { classBody = ConcreteClass { classATStuff = at_stuff }})
272 = at_stuff
273 classATItems _ = []
274
275 classSCTheta :: Class -> [PredType]
276 classSCTheta (Class { classBody = ConcreteClass { classSCThetaStuff = theta_stuff }})
277 = theta_stuff
278 classSCTheta _ = []
279
280 classTvsFds :: Class -> ([TyVar], [FunDep TyVar])
281 classTvsFds c = (classTyVars c, classFunDeps c)
282
283 classHasFds :: Class -> Bool
284 classHasFds (Class { classFunDeps = fds }) = not (null fds)
285
286 classBigSig :: Class -> ([TyVar], [PredType], [Id], [ClassOpItem])
287 classBigSig (Class {classTyVars = tyvars,
288 classBody = AbstractClass})
289 = (tyvars, [], [], [])
290 classBigSig (Class {classTyVars = tyvars,
291 classBody = ConcreteClass {
292 classSCThetaStuff = sc_theta,
293 classSCSels = sc_sels,
294 classOpStuff = op_stuff
295 }})
296 = (tyvars, sc_theta, sc_sels, op_stuff)
297
298 classExtraBigSig :: Class -> ([TyVar], [FunDep TyVar], [PredType], [Id], [ClassATItem], [ClassOpItem])
299 classExtraBigSig (Class {classTyVars = tyvars, classFunDeps = fundeps,
300 classBody = AbstractClass})
301 = (tyvars, fundeps, [], [], [], [])
302 classExtraBigSig (Class {classTyVars = tyvars, classFunDeps = fundeps,
303 classBody = ConcreteClass {
304 classSCThetaStuff = sc_theta, classSCSels = sc_sels,
305 classATStuff = ats, classOpStuff = op_stuff
306 }})
307 = (tyvars, fundeps, sc_theta, sc_sels, ats, op_stuff)
308
309 isAbstractClass :: Class -> Bool
310 isAbstractClass Class{ classBody = AbstractClass } = True
311 isAbstractClass _ = False
312
313 {-
314 ************************************************************************
315 * *
316 \subsection[Class-instances]{Instance declarations for @Class@}
317 * *
318 ************************************************************************
319
320 We compare @Classes@ by their keys (which include @Uniques@).
321 -}
322
323 instance Eq Class where
324 c1 == c2 = classKey c1 == classKey c2
325 c1 /= c2 = classKey c1 /= classKey c2
326
327 instance Uniquable Class where
328 getUnique c = classKey c
329
330 instance NamedThing Class where
331 getName clas = className clas
332
333 instance Outputable Class where
334 ppr c = ppr (getName c)
335
336 pprDefMethInfo :: DefMethInfo -> SDoc
337 pprDefMethInfo Nothing = empty -- No default method
338 pprDefMethInfo (Just (n, VanillaDM)) = text "Default method" <+> ppr n
339 pprDefMethInfo (Just (n, GenericDM ty)) = text "Generic default method"
340 <+> ppr n <+> dcolon <+> pprType ty
341
342 pprFundeps :: Outputable a => [FunDep a] -> SDoc
343 pprFundeps [] = empty
344 pprFundeps fds = hsep (vbar : punctuate comma (map pprFunDep fds))
345
346 pprFunDep :: Outputable a => FunDep a -> SDoc
347 pprFunDep (us, vs) = hsep [interppSP us, arrow, interppSP vs]
348
349 instance Data.Data Class where
350 -- don't traverse?
351 toConstr _ = abstractConstr "Class"
352 gunfold _ _ = error "gunfold"
353 dataTypeOf _ = mkNoRepType "Class"