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