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