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, cCallishClassKeys,
20 isNumericClass, isStandardClass, isCcallishClass,
22 GenClassOp(..), ClassOp(..),
24 classOpTag, classOpString,
30 CHK_Ubiq() -- debugging consistency check
34 import TyCon ( TyCon )
35 import TyVar ( TyVar(..), GenTyVar )
36 import Usage ( GenUsage, Usage(..), UVar(..) )
38 import Maybes ( assocMaybe, Maybe )
39 import Name ( changeUnique )
40 import Unique -- Keys for built-in classes
41 import Pretty ( Pretty(..), ppCat{-ToDo:rm-}, ppPStr{-ditto-} )
42 import PprStyle ( PprStyle )
43 import SrcLoc ( SrcLoc )
47 %************************************************************************
49 \subsection[Class-basic]{@Class@: basic definition}
51 %************************************************************************
53 A @Class@ corresponds to a Greek kappa in the static semantics:
55 The parameterisation wrt tyvar and uvar is only necessary to
56 get appropriately general instances of Ord3 for GenType.
60 = ClassOp FAST_STRING -- The operation name
62 Int -- Unique within a class; starts at 1
64 ty -- Type; the class tyvar is free (you can find
65 -- it from the class). This means that a
66 -- ClassOp doesn't make much sense outside the
67 -- context of its parent class.
69 data GenClass tyvar uvar
71 Unique -- Key for fast comparison
74 tyvar -- The class type variable
76 [GenClass tyvar uvar] -- Immediate superclasses, and the
77 [Id] -- corresponding selector functions to
78 -- extract them from a dictionary of this
81 [GenClassOp (GenType tyvar uvar)] -- The * class operations
82 [Id] -- * selector functions
83 [Id] -- * default methods
84 -- They are all ordered by tag. The
85 -- selector ids are less innocent than they
86 -- look, because their IdInfos contains
87 -- suitable specialisation information. In
88 -- particular, constant methods are
89 -- instances of selectors at suitably simple
92 ClassInstEnv -- Gives details of all the instances of this class
94 [(GenClass tyvar uvar, [GenClass tyvar uvar])]
95 -- Indirect superclasses;
96 -- (k,[k1,...,kn]) means that
97 -- k is an immediate superclass of k1
98 -- k1 is an immediate superclass of k2
99 -- ... and kn is an immediate superclass
100 -- of this class. (This is all redundant
101 -- information, since it can be derived from
102 -- the superclass information above.)
104 type Class = GenClass TyVar UVar
105 type ClassOp = GenClassOp Type
107 type ClassInstEnv = MatchEnv Type Id -- The Ids are dfuns
110 The @mkClass@ function fills in the indirect superclasses.
113 mkClass :: Unique -> Name -> TyVar
115 -> [ClassOp] -> [Id] -> [Id]
119 mkClass uniq full_name tyvar super_classes superdict_sels
120 class_ops dict_sels defms class_insts
121 = Class uniq (changeUnique full_name uniq) tyvar
122 super_classes superdict_sels
123 class_ops dict_sels defms
127 trans_clos :: [(Class,[Class])]
128 trans_clos = transitiveClosure succ (==) [ (clas, []) | clas <- super_classes ]
130 succ (clas@(Class _ _ _ super_classes _ _ _ _ _ _), links)
131 = [(super, (clas:links)) | super <- super_classes]
134 %************************************************************************
136 \subsection[Class-selectors]{@Class@: simple selectors}
138 %************************************************************************
140 The rest of these functions are just simple selectors.
143 classKey (Class key _ _ _ _ _ _ _ _ _) = key
144 classOps (Class _ _ _ _ _ ops _ _ _ _) = ops
145 classSelIds (Class _ _ _ _ _ _ sels _ _ _) = sels
147 classOpId (Class _ _ _ _ _ ops op_ids _ _ _) op
148 = op_ids !! (classOpTag op - 1)
149 classDefaultMethodId (Class _ _ _ _ _ ops _ defm_ids _ _) op
150 = defm_ids !! (classOpTag op - 1)
151 classSuperDictSelId (Class _ _ _ scs scsel_ids _ _ _ _ _) super_clas
152 = assoc "classSuperDictSelId" (scs `zip` scsel_ids) super_clas
154 classSig :: GenClass t u -> (t, [GenClass t u], [GenClassOp (GenType t u)])
155 classSig (Class _ _ tyvar super_classes _ ops _ _ _ _)
156 = (tyvar, super_classes, ops)
158 classBigSig (Class _ _ tyvar super_classes sdsels ops sels defms _ _)
159 = (tyvar, super_classes, sdsels, ops, sels, defms)
161 classInstEnv (Class _ _ _ _ _ _ _ _ inst_env _) = inst_env
164 @a `isSuperClassOf` b@ returns @Nothing@ if @a@ is not a superclass of
165 @b@, but if it is, it returns $@Just@~[k_1,\ldots,k_n]$, where the
166 $k_1,\ldots,k_n$ are exactly as described in the definition of the
167 @GenClass@ constructor above.
170 isSuperClassOf :: Class -> Class -> Maybe [Class]
171 clas `isSuperClassOf` (Class _ _ _ _ _ _ _ _ _ links) = assocMaybe links clas
174 %************************************************************************
176 \subsection[Class-std-groups]{Standard groups of Prelude classes}
178 %************************************************************************
180 @derivableClassKeys@ is also used in checking \tr{deriving} constructs
183 NOTE: @Eq@ and @Text@ do need to appear in @standardClasses@
184 even though every numeric class has these two as a superclass,
185 because the list of ambiguous dictionaries hasn't been simplified.
188 isNumericClass, isStandardClass :: Class -> Bool
190 isNumericClass (Class key _ _ _ _ _ _ _ _ _) = --pprTrace "isNum:" (ppCat (map pprUnique (key : numericClassKeys ))) $
191 key `is_elem` numericClassKeys
192 isStandardClass (Class key _ _ _ _ _ _ _ _ _) = key `is_elem` standardClassKeys
193 isCcallishClass (Class key _ _ _ _ _ _ _ _ _) = key `is_elem` cCallishClassKeys
194 is_elem = isIn "is_X_Class"
214 cCallishClassKeys = [ cCallableClassKey, cReturnableClassKey ]
217 = derivableClassKeys ++ numericClassKeys ++ cCallishClassKeys
219 -- We have to have "CCallable" and "CReturnable" in the standard
220 -- classes, so that if you go...
222 -- _ccall_ foo ... 93{-numeric literal-} ...
224 -- ... it can do The Right Thing on the 93.
227 %************************************************************************
229 \subsection[Class-instances]{Instance declarations for @Class@}
231 %************************************************************************
233 We compare @Classes@ by their keys (which include @Uniques@).
236 instance Ord3 (GenClass tyvar uvar) where
237 cmp (Class k1 _ _ _ _ _ _ _ _ _) (Class k2 _ _ _ _ _ _ _ _ _) = cmp k1 k2
239 instance Eq (GenClass tyvar uvar) where
240 (Class k1 _ _ _ _ _ _ _ _ _) == (Class k2 _ _ _ _ _ _ _ _ _) = k1 == k2
241 (Class k1 _ _ _ _ _ _ _ _ _) /= (Class k2 _ _ _ _ _ _ _ _ _) = k1 /= k2
243 instance Ord (GenClass tyvar uvar) where
244 (Class k1 _ _ _ _ _ _ _ _ _) <= (Class k2 _ _ _ _ _ _ _ _ _) = k1 <= k2
245 (Class k1 _ _ _ _ _ _ _ _ _) < (Class k2 _ _ _ _ _ _ _ _ _) = k1 < k2
246 (Class k1 _ _ _ _ _ _ _ _ _) >= (Class k2 _ _ _ _ _ _ _ _ _) = k1 >= k2
247 (Class k1 _ _ _ _ _ _ _ _ _) > (Class k2 _ _ _ _ _ _ _ _ _) = k1 > k2
248 _tagCmp a b = case cmp a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
252 instance Uniquable (GenClass tyvar uvar) where
253 uniqueOf (Class u _ _ _ _ _ _ _ _ _) = u
255 instance NamedThing (GenClass tyvar uvar) where
256 getName (Class _ n _ _ _ _ _ _ _ _) = n
260 %************************************************************************
262 \subsection[ClassOp-basic]{@ClassOp@: type and basic functions}
264 %************************************************************************
266 A @ClassOp@ represents a a class operation. From it and its parent
267 class we can construct the dictionary-selector @Id@ for the
268 operation/superclass dictionary, and the @Id@ for its default method.
269 It appears in a list inside the @Class@ object.
271 The type of a method in a @ClassOp@ object is its local type; that is,
272 without the overloading of the class itself. For example, in the
276 op :: Ord b => a -> b -> a
278 the type recorded for @op@ in the @ClassOp@ list of the @Class@ object is
281 @Ord@~\beta \Rightarrow
282 \alpha \rightarrow \beta \rightarrow alpha$
284 (where $\alpha$ is the class type variable recorded in the @Class@
285 object). Of course, the type of @op@ recorded in the GVE will be its
288 $\forall \alpha \forall \beta.~
289 @Foo@~\alpha \Rightarrow
290 ~@Ord@~\beta \Rightarrow \alpha
291 \rightarrow \beta \rightarrow alpha$
293 ******************************************************************
294 **** That is, the type variables of a class op selector
295 *** are all at the outer level.
296 ******************************************************************
299 mkClassOp :: FAST_STRING -> Int -> ty -> GenClassOp ty
300 mkClassOp name tag ty = ClassOp name tag ty
302 classOpTag :: GenClassOp ty -> Int
303 classOpTag (ClassOp _ tag _) = tag
305 classOpString :: GenClassOp ty -> FAST_STRING
306 classOpString (ClassOp str _ _) = str
308 classOpLocalType :: GenClassOp ty -> ty {-SigmaType-}
309 classOpLocalType (ClassOp _ _ ty) = ty
312 Rather unsavoury ways of getting ClassOp tags:
314 classOpTagByString :: Class -> FAST_STRING -> Int
316 classOpTagByString clas op
317 = go (map classOpString (classOps clas)) 1
319 go (n:ns) tag = if n == op
323 go [] tag = pprPanic "classOpTagByString:" (ppCat (ppPStr op : map (ppPStr . classOpString) (classOps clas)))
327 %************************************************************************
329 \subsection[ClassOp-instances]{Instance declarations for @ClassOp@}
331 %************************************************************************
333 @ClassOps@ are compared by their tags.
336 instance Eq (GenClassOp ty) where
337 (ClassOp _ i1 _) == (ClassOp _ i2 _) = i1 == i2
338 (ClassOp _ i1 _) /= (ClassOp _ i2 _) = i1 == i2
340 instance Ord (GenClassOp ty) where
341 (ClassOp _ i1 _) <= (ClassOp _ i2 _) = i1 <= i2
342 (ClassOp _ i1 _) < (ClassOp _ i2 _) = i1 < i2
343 (ClassOp _ i1 _) >= (ClassOp _ i2 _) = i1 >= i2
344 (ClassOp _ i1 _) > (ClassOp _ i2 _) = i1 > i2
345 -- ToDo: something for _tagCmp? (WDP 94/10)