2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[Class]{The @Class@ datatype}
7 #include "HsVersions.h"
10 GenClass(..), Class(..),
13 classKey, classOps, classSelIds,
14 classSuperDictSelId, classOpId, classDefaultMethodId,
15 classSig, classBigSig, classInstEnv,
19 derivableClassKeys, needsDataDeclCtxtClassKeys,
20 cCallishClassKeys, isNoDictClass,
21 isNumericClass, isStandardClass, isCcallishClass,
23 GenClassOp(..), ClassOp(..),
25 classOpTag, classOpString,
31 CHK_Ubiq() -- debugging consistency check
33 IMPORT_DELOOPER(TyLoop)
35 import TyCon ( TyCon )
36 import TyVar ( TyVar(..), GenTyVar )
37 import Usage ( GenUsage, Usage(..), UVar(..) )
39 import Maybes ( assocMaybe, Maybe )
40 import Name ( changeUnique )
41 import Unique -- Keys for built-in classes
42 import Pretty ( Pretty(..), ppCat{-ToDo:rm-}, ppPStr{-ditto-} )
43 import PprStyle ( PprStyle )
44 import SrcLoc ( SrcLoc )
48 %************************************************************************
50 \subsection[Class-basic]{@Class@: basic definition}
52 %************************************************************************
54 A @Class@ corresponds to a Greek kappa in the static semantics:
56 The parameterisation wrt tyvar and uvar is only necessary to
57 get appropriately general instances of Ord3 for GenType.
61 = ClassOp FAST_STRING -- The operation name
63 Int -- Unique within a class; starts at 1
65 ty -- Type; the class tyvar is free (you can find
66 -- it from the class). This means that a
67 -- ClassOp doesn't make much sense outside the
68 -- context of its parent class.
70 data GenClass tyvar uvar
72 Unique -- Key for fast comparison
75 tyvar -- The class type variable
77 [GenClass tyvar uvar] -- Immediate superclasses, and the
78 [Id] -- corresponding selector functions to
79 -- extract them from a dictionary of this
82 [GenClassOp (GenType tyvar uvar)] -- The * class operations
83 [Id] -- * selector functions
84 [Id] -- * default methods
85 -- They are all ordered by tag. The
86 -- selector ids are less innocent than they
87 -- look, because their IdInfos contains
88 -- suitable specialisation information. In
89 -- particular, constant methods are
90 -- instances of selectors at suitably simple
93 ClassInstEnv -- Gives details of all the instances of this class
95 [(GenClass tyvar uvar, [GenClass tyvar uvar])]
96 -- Indirect superclasses;
97 -- (k,[k1,...,kn]) means that
98 -- k is an immediate superclass of k1
99 -- k1 is an immediate superclass of k2
100 -- ... and kn is an immediate superclass
101 -- of this class. (This is all redundant
102 -- information, since it can be derived from
103 -- the superclass information above.)
105 type Class = GenClass TyVar UVar
106 type ClassOp = GenClassOp Type
108 type ClassInstEnv = MatchEnv Type Id -- The Ids are dfuns
111 The @mkClass@ function fills in the indirect superclasses.
114 mkClass :: Unique -> Name -> TyVar
116 -> [ClassOp] -> [Id] -> [Id]
120 mkClass uniq full_name tyvar super_classes superdict_sels
121 class_ops dict_sels defms class_insts
122 = Class uniq (changeUnique full_name uniq) tyvar
123 super_classes superdict_sels
124 class_ops dict_sels defms
128 trans_clos :: [(Class,[Class])]
129 trans_clos = transitiveClosure succ (==) [ (clas, []) | clas <- super_classes ]
131 succ (clas@(Class _ _ _ super_classes _ _ _ _ _ _), links)
132 = [(super, (clas:links)) | super <- super_classes]
135 %************************************************************************
137 \subsection[Class-selectors]{@Class@: simple selectors}
139 %************************************************************************
141 The rest of these functions are just simple selectors.
144 classKey (Class key _ _ _ _ _ _ _ _ _) = key
145 classOps (Class _ _ _ _ _ ops _ _ _ _) = ops
146 classSelIds (Class _ _ _ _ _ _ sels _ _ _) = sels
148 classOpId (Class _ _ _ _ _ ops op_ids _ _ _) op
149 = op_ids !! (classOpTag op - 1)
150 classDefaultMethodId (Class _ _ _ _ _ ops _ defm_ids _ _) op
151 = defm_ids !! (classOpTag op - 1)
152 classSuperDictSelId (Class _ _ _ scs scsel_ids _ _ _ _ _) super_clas
153 = assoc "classSuperDictSelId" (scs `zip` scsel_ids) super_clas
155 classSig :: GenClass t u -> (t, [GenClass t u], [GenClassOp (GenType t u)])
156 classSig (Class _ _ tyvar super_classes _ ops _ _ _ _)
157 = (tyvar, super_classes, ops)
159 classBigSig (Class _ _ tyvar super_classes sdsels ops sels defms _ _)
160 = (tyvar, super_classes, sdsels, ops, sels, defms)
162 classInstEnv (Class _ _ _ _ _ _ _ _ inst_env _) = inst_env
165 @a `isSuperClassOf` b@ returns @Nothing@ if @a@ is not a superclass of
166 @b@, but if it is, it returns $@Just@~[k_1,\ldots,k_n]$, where the
167 $k_1,\ldots,k_n$ are exactly as described in the definition of the
168 @GenClass@ constructor above.
171 isSuperClassOf :: Class -> Class -> Maybe [Class]
172 clas `isSuperClassOf` (Class _ _ _ _ _ _ _ _ _ links) = assocMaybe links clas
175 %************************************************************************
177 \subsection[Class-std-groups]{Standard groups of Prelude classes}
179 %************************************************************************
181 @derivableClassKeys@ is also used in checking \tr{deriving} constructs
184 NOTE: @Eq@ and @Text@ do need to appear in @standardClasses@
185 even though every numeric class has these two as a superclass,
186 because the list of ambiguous dictionaries hasn't been simplified.
189 isNumericClass, isStandardClass :: Class -> Bool
191 isNumericClass (Class key _ _ _ _ _ _ _ _ _) = --pprTrace "isNum:" (ppCat (map pprUnique (key : numericClassKeys ))) $
192 key `is_elem` numericClassKeys
193 isStandardClass (Class key _ _ _ _ _ _ _ _ _) = key `is_elem` standardClassKeys
194 isCcallishClass (Class key _ _ _ _ _ _ _ _ _) = key `is_elem` cCallishClassKeys
195 isNoDictClass (Class key _ _ _ _ _ _ _ _ _) = key `is_elem` noDictClassKeys
196 is_elem = isIn "is_X_Class"
219 needsDataDeclCtxtClassKeys -- see comments in TcDeriv
223 cCallishClassKeys = [ cCallableClassKey, cReturnableClassKey ]
226 = derivableClassKeys ++ numericClassKeys ++ cCallishClassKeys
228 -- We have to have "CCallable" and "CReturnable" in the standard
229 -- classes, so that if you go...
231 -- _ccall_ foo ... 93{-numeric literal-} ...
233 -- ... it can do The Right Thing on the 93.
235 noDictClassKeys -- These classes are used only for type annotations;
236 -- they are not implemented by dictionaries, ever.
238 -- I used to think that class Eval belonged in here, but
239 -- we really want functions with type (Eval a => ...) and that
240 -- means that we really want to pass a placeholder for an Eval
241 -- dictionary. The unit tuple is what we'll get if we leave things
242 -- alone, and that'll do for now. Could arrange to drop that parameter
246 %************************************************************************
248 \subsection[Class-instances]{Instance declarations for @Class@}
250 %************************************************************************
252 We compare @Classes@ by their keys (which include @Uniques@).
255 instance Ord3 (GenClass tyvar uvar) where
256 cmp (Class k1 _ _ _ _ _ _ _ _ _) (Class k2 _ _ _ _ _ _ _ _ _) = cmp k1 k2
258 instance Eq (GenClass tyvar uvar) where
259 (Class k1 _ _ _ _ _ _ _ _ _) == (Class k2 _ _ _ _ _ _ _ _ _) = k1 == k2
260 (Class k1 _ _ _ _ _ _ _ _ _) /= (Class k2 _ _ _ _ _ _ _ _ _) = k1 /= k2
262 instance Ord (GenClass tyvar uvar) where
263 (Class k1 _ _ _ _ _ _ _ _ _) <= (Class k2 _ _ _ _ _ _ _ _ _) = k1 <= k2
264 (Class k1 _ _ _ _ _ _ _ _ _) < (Class k2 _ _ _ _ _ _ _ _ _) = k1 < k2
265 (Class k1 _ _ _ _ _ _ _ _ _) >= (Class k2 _ _ _ _ _ _ _ _ _) = k1 >= k2
266 (Class k1 _ _ _ _ _ _ _ _ _) > (Class k2 _ _ _ _ _ _ _ _ _) = k1 > k2
267 _tagCmp a b = case cmp a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
271 instance Uniquable (GenClass tyvar uvar) where
272 uniqueOf (Class u _ _ _ _ _ _ _ _ _) = u
274 instance NamedThing (GenClass tyvar uvar) where
275 getName (Class _ n _ _ _ _ _ _ _ _) = n
279 %************************************************************************
281 \subsection[ClassOp-basic]{@ClassOp@: type and basic functions}
283 %************************************************************************
285 A @ClassOp@ represents a a class operation. From it and its parent
286 class we can construct the dictionary-selector @Id@ for the
287 operation/superclass dictionary, and the @Id@ for its default method.
288 It appears in a list inside the @Class@ object.
290 The type of a method in a @ClassOp@ object is its local type; that is,
291 without the overloading of the class itself. For example, in the
295 op :: Ord b => a -> b -> a
297 the type recorded for @op@ in the @ClassOp@ list of the @Class@ object is
300 @Ord@~\beta \Rightarrow
301 \alpha \rightarrow \beta \rightarrow alpha$
303 (where $\alpha$ is the class type variable recorded in the @Class@
304 object). Of course, the type of @op@ recorded in the GVE will be its
307 $\forall \alpha \forall \beta.~
308 @Foo@~\alpha \Rightarrow
309 ~@Ord@~\beta \Rightarrow \alpha
310 \rightarrow \beta \rightarrow alpha$
312 ******************************************************************
313 **** That is, the type variables of a class op selector
314 *** are all at the outer level.
315 ******************************************************************
318 mkClassOp :: FAST_STRING -> Int -> ty -> GenClassOp ty
319 mkClassOp name tag ty = ClassOp name tag ty
321 classOpTag :: GenClassOp ty -> Int
322 classOpTag (ClassOp _ tag _) = tag
324 classOpString :: GenClassOp ty -> FAST_STRING
325 classOpString (ClassOp str _ _) = str
327 classOpLocalType :: GenClassOp ty -> ty {-SigmaType-}
328 classOpLocalType (ClassOp _ _ ty) = ty
331 Rather unsavoury ways of getting ClassOp tags:
333 classOpTagByString :: Class -> FAST_STRING -> Int
335 classOpTagByString clas op
336 = go (map classOpString (classOps clas)) 1
338 go (n:ns) tag = if n == op
342 go [] tag = pprPanic "classOpTagByString:" (ppCat (ppPStr op : map (ppPStr . classOpString) (classOps clas)))
346 %************************************************************************
348 \subsection[ClassOp-instances]{Instance declarations for @ClassOp@}
350 %************************************************************************
352 @ClassOps@ are compared by their tags.
355 instance Eq (GenClassOp ty) where
356 (ClassOp _ i1 _) == (ClassOp _ i2 _) = i1 == i2
357 (ClassOp _ i1 _) /= (ClassOp _ i2 _) = i1 == i2
359 instance Ord (GenClassOp ty) where
360 (ClassOp _ i1 _) <= (ClassOp _ i2 _) = i1 <= i2
361 (ClassOp _ i1 _) < (ClassOp _ i2 _) = i1 < i2
362 (ClassOp _ i1 _) >= (ClassOp _ i2 _) = i1 >= i2
363 (ClassOp _ i1 _) > (ClassOp _ i2 _) = i1 > i2
364 -- ToDo: something for _tagCmp? (WDP 94/10)