Implement QuantifiedConstraints
[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, classSCSelIds, 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 cls_sc_theta :: [PredType], -- Immediate superclasses,
111 cls_sc_sel_ids :: [Id], -- Selector functions to extract the
112 -- superclasses from a
113 -- dictionary of this class
114 -- Associated types
115 cls_ats :: [ClassATItem], -- Associated type families
116
117 -- Class operations (methods, not superclasses)
118 cls_ops :: [ClassOpItem], -- Ordered by tag
119
120 -- Minimal complete definition
121 cls_min_def :: ClassMinimalDef
122 }
123 -- TODO: maybe super classes should be allowed in abstract class definitions
124
125 classMinimalDef :: Class -> ClassMinimalDef
126 classMinimalDef Class{ classBody = ConcreteClass{ cls_min_def = 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 cls_sc_theta = super_classes,
185 cls_sc_sel_ids = superdict_sels,
186 cls_ats = at_stuff,
187 cls_ops = op_stuff,
188 cls_min_def = 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 { cls_sc_sel_ids = sc_sels }})
243 = sc_sels ++ classMethods c
244 classAllSelIds c = ASSERT( null (classMethods c) ) []
245
246 classSCSelIds :: Class -> [Id]
247 -- Both superclass-dictionary and method selectors
248 classSCSelIds (Class { classBody = ConcreteClass { cls_sc_sel_ids = sc_sels }})
249 = sc_sels
250 classSCSelIds c = ASSERT( null (classMethods c) ) []
251
252 classSCSelId :: Class -> Int -> Id
253 -- Get the n'th superclass selector Id
254 -- where n is 0-indexed, and counts
255 -- *all* superclasses including equalities
256 classSCSelId (Class { classBody = ConcreteClass { cls_sc_sel_ids = sc_sels } }) n
257 = ASSERT( n >= 0 && lengthExceeds sc_sels n )
258 sc_sels !! n
259 classSCSelId c n = pprPanic "classSCSelId" (ppr c <+> ppr n)
260
261 classMethods :: Class -> [Id]
262 classMethods (Class { classBody = ConcreteClass { cls_ops = op_stuff } })
263 = [op_sel | (op_sel, _) <- op_stuff]
264 classMethods _ = []
265
266 classOpItems :: Class -> [ClassOpItem]
267 classOpItems (Class { classBody = ConcreteClass { cls_ops = op_stuff }})
268 = op_stuff
269 classOpItems _ = []
270
271 classATs :: Class -> [TyCon]
272 classATs (Class { classBody = ConcreteClass { cls_ats = at_stuff } })
273 = [tc | ATI tc _ <- at_stuff]
274 classATs _ = []
275
276 classATItems :: Class -> [ClassATItem]
277 classATItems (Class { classBody = ConcreteClass { cls_ats = at_stuff }})
278 = at_stuff
279 classATItems _ = []
280
281 classSCTheta :: Class -> [PredType]
282 classSCTheta (Class { classBody = ConcreteClass { cls_sc_theta = theta_stuff }})
283 = theta_stuff
284 classSCTheta _ = []
285
286 classTvsFds :: Class -> ([TyVar], [FunDep TyVar])
287 classTvsFds c = (classTyVars c, classFunDeps c)
288
289 classHasFds :: Class -> Bool
290 classHasFds (Class { classFunDeps = fds }) = not (null fds)
291
292 classBigSig :: Class -> ([TyVar], [PredType], [Id], [ClassOpItem])
293 classBigSig (Class {classTyVars = tyvars,
294 classBody = AbstractClass})
295 = (tyvars, [], [], [])
296 classBigSig (Class {classTyVars = tyvars,
297 classBody = ConcreteClass {
298 cls_sc_theta = sc_theta,
299 cls_sc_sel_ids = sc_sels,
300 cls_ops = op_stuff
301 }})
302 = (tyvars, sc_theta, sc_sels, op_stuff)
303
304 classExtraBigSig :: Class -> ([TyVar], [FunDep TyVar], [PredType], [Id], [ClassATItem], [ClassOpItem])
305 classExtraBigSig (Class {classTyVars = tyvars, classFunDeps = fundeps,
306 classBody = AbstractClass})
307 = (tyvars, fundeps, [], [], [], [])
308 classExtraBigSig (Class {classTyVars = tyvars, classFunDeps = fundeps,
309 classBody = ConcreteClass {
310 cls_sc_theta = sc_theta, cls_sc_sel_ids = sc_sels,
311 cls_ats = ats, cls_ops = op_stuff
312 }})
313 = (tyvars, fundeps, sc_theta, sc_sels, ats, op_stuff)
314
315 isAbstractClass :: Class -> Bool
316 isAbstractClass Class{ classBody = AbstractClass } = True
317 isAbstractClass _ = False
318
319 {-
320 ************************************************************************
321 * *
322 \subsection[Class-instances]{Instance declarations for @Class@}
323 * *
324 ************************************************************************
325
326 We compare @Classes@ by their keys (which include @Uniques@).
327 -}
328
329 instance Eq Class where
330 c1 == c2 = classKey c1 == classKey c2
331 c1 /= c2 = classKey c1 /= classKey c2
332
333 instance Uniquable Class where
334 getUnique c = classKey c
335
336 instance NamedThing Class where
337 getName clas = className clas
338
339 instance Outputable Class where
340 ppr c = ppr (getName c)
341
342 pprDefMethInfo :: DefMethInfo -> SDoc
343 pprDefMethInfo Nothing = empty -- No default method
344 pprDefMethInfo (Just (n, VanillaDM)) = text "Default method" <+> ppr n
345 pprDefMethInfo (Just (n, GenericDM ty)) = text "Generic default method"
346 <+> ppr n <+> dcolon <+> pprType ty
347
348 pprFundeps :: Outputable a => [FunDep a] -> SDoc
349 pprFundeps [] = empty
350 pprFundeps fds = hsep (vbar : punctuate comma (map pprFunDep fds))
351
352 pprFunDep :: Outputable a => FunDep a -> SDoc
353 pprFunDep (us, vs) = hsep [interppSP us, arrow, interppSP vs]
354
355 instance Data.Data Class where
356 -- don't traverse?
357 toConstr _ = abstractConstr "Class"
358 gunfold _ _ = error "gunfold"
359 dataTypeOf _ = mkNoRepType "Class"