2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
4 \section[Class]{The @Class@ datatype}
7 #include "HsVersions.h"
10 Class(..), -- must be *NON*-abstract so UniTyFuns can see it
13 getClassKey, getClassOps,
14 getSuperDictSelId, getClassOpId, getDefaultMethodId,
16 getClassSig, getClassBigSig, getClassInstEnv,
17 --UNUSED: getClassDefaultMethodsInfo,
22 isNumericClass, isStandardClass, --UNUSED: isDerivableClass,
24 ClassOp(..), -- must be non-abstract so UniTyFuns can see them
26 getClassOpTag, getClassOpString,
27 --UNUSED: getClassOpSig,
30 -- and to make the interface self-sufficient...
31 Id, InstTemplate, Maybe, Name, FullName, TyVarTemplate,
35 import Id ( getIdSpecialisation, Id )
37 import InstEnv ( ClassInstEnv(..), MatchEnv(..) )
38 import Maybes ( assocMaybe, Maybe(..) )
39 import Name ( Name(..), ShortName )
40 import NameTypes ( FullName, SrcLoc )
42 import Outputable -- class for printing, forcing
43 import TyCon ( TyCon, Arity(..)
44 IF_ATTACK_PRAGMAS(COMMA cmpTyCon)
46 import TyVar ( TyVarTemplate )
47 import Unique -- class key stuff
48 import UniType ( UniType, ThetaType(..), TauType(..)
49 IF_ATTACK_PRAGMAS(COMMA cmpUniType)
51 import UniTyFuns ( splitType, pprClassOp
52 IF_ATTACK_PRAGMAS(COMMA pprUniType COMMA pprTyCon)
57 %************************************************************************
59 \subsection[Class-basic]{@Class@: basic definition}
61 %************************************************************************
63 A @Class@ corresponds to a Greek kappa in the static semantics:
68 Unique{-ClassKey-}-- Key for fast comparison
71 TyVarTemplate -- The class type variable
73 [Class] [Id] -- Immediate superclasses, and the
74 -- corresponding selector functions to
75 -- extract them from a dictionary of this
78 [ClassOp] -- The * class operations
79 [Id] -- * selector functions
80 [Id] -- * default methods
81 -- They are all ordered by tag. The
82 -- selector ids are less innocent than they
83 -- look, because their IdInfos contains
84 -- suitable specialisation information. In
85 -- particular, constant methods are
86 -- instances of selectors at suitably simple
89 ClassInstEnv -- Gives details of all the instances of this class
91 [(Class,[Class])] -- Indirect superclasses;
92 -- (k,[k1,...,kn]) means that
93 -- k is an immediate superclass of k1
94 -- k1 is an immediate superclass of k2
95 -- ... and kn is an immediate superclass
96 -- of this class. (This is all redundant
97 -- information, since it can be derived from
98 -- the superclass information above.)
101 The @mkClass@ function fills in the indirect superclasses.
104 mkClass :: Name -> TyVarTemplate
106 -> [ClassOp] -> [Id] -> [Id]
110 mkClass name tyvar super_classes superdict_sels
111 class_ops dict_sels defms class_insts
112 = MkClass key full_name tyvar
113 super_classes superdict_sels
114 class_ops dict_sels defms
118 (key,full_name) = case name of
119 OtherClass uniq full_name _ -> (uniq, full_name)
120 PreludeClass key full_name -> (key, full_name)
122 trans_clos :: [(Class,[Class])]
123 trans_clos = transitiveClosure succ (==) [ (clas, []) | clas <- super_classes ]
125 succ (clas@(MkClass _ _ _ super_classes _ _ _ _ _ _), links)
126 = [(super, (clas:links)) | super <- super_classes]
129 %************************************************************************
131 \subsection[Class-selectors]{@Class@: simple selectors}
133 %************************************************************************
135 The rest of these functions are just simple selectors.
138 getClassKey (MkClass key _ _ _ _ _ _ _ _ _) = key
140 getClassOps (MkClass _ _ _ _ _ ops _ _ _ _) = ops
142 getSuperDictSelId (MkClass _ _ _ scs scsel_ids _ _ _ _ _) super_clas
143 = assoc "getSuperDictSelId" (scs `zip` scsel_ids) super_clas
145 getClassOpId (MkClass _ _ _ _ _ ops op_ids _ _ _) op
146 = op_ids !! (getClassOpTag op - 1)
148 getDefaultMethodId (MkClass _ _ _ _ _ ops _ defm_ids _ _) op
149 = defm_ids !! (getClassOpTag op - 1)
151 getConstMethodId (MkClass _ _ _ _ _ ops op_ids _ _ _) op ty
152 = -- constant-method info is hidden in the IdInfo of
153 -- the class-op id (as mentioned up above).
155 sel_id = op_ids !! (getClassOpTag op - 1)
157 case (lookupConstMethodId (getIdSpecialisation sel_id) ty) of
159 Nothing -> error (ppShow 80 (ppAboves [
160 ppCat [ppStr "ERROR: getConstMethodId:", ppr PprDebug op, ppr PprDebug ty, ppr PprDebug ops, ppr PprDebug op_ids, ppr PprDebug sel_id],
161 ppStr "(This can arise if an interface pragma refers to an instance",
162 ppStr "but there is no imported interface which *defines* that instance.",
163 ppStr "The info above, however ugly, should indicate what else you need to import."
166 getClassSig :: Class -> (TyVarTemplate, [Class], [ClassOp])
168 getClassSig (MkClass _ _ tyvar super_classes _ ops _ _ _ _)
169 = (tyvar, super_classes, ops)
171 getClassBigSig (MkClass _ _ tyvar super_classes sdsels ops sels defms _ _)
172 = (tyvar, super_classes, sdsels, ops, sels, defms)
174 getClassInstEnv (MkClass _ _ _ _ _ _ _ _ inst_env _) = inst_env
176 --UNUSED: getClassDefaultMethodsInfo (MkClass _ _ _ _ _ _ _ defms _ _) = defms
179 @a `isSuperClassOf` b@ returns @Nothing@ if @a@ is not a superclass of
180 @b@, but if it is, it returns $@Just@~[k_1,\ldots,k_n]$, where the
181 $k_1,\ldots,k_n$ are exactly as described in the definition of the
182 @MkClass@ constructor above.
185 isSuperClassOf :: Class -> Class -> Maybe [Class]
187 clas `isSuperClassOf` (MkClass _ _ _ _ _ _ _ _ _ links) = assocMaybe links clas
190 %************************************************************************
192 \subsection[Class-std-groups]{Standard groups of Prelude classes}
194 %************************************************************************
196 @derivableClassKeys@ is also used in checking \tr{deriving} constructs
199 NOTE: @Eq@ and @Text@ do need to appear in @standardClasses@
200 even though every numeric class has these two as a superclass,
201 because the list of ambiguous dictionaries hasn't been simplified.
204 isNumericClass, isStandardClass {-UNUSED:, isDerivableClass-} :: Class -> Bool
206 isNumericClass (MkClass key _ _ _ _ _ _ _ _ _) = key `is_elem` numericClassKeys
207 isStandardClass (MkClass key _ _ _ _ _ _ _ _ _) = key `is_elem` standardClassKeys
208 --isDerivableClass (MkClass key _ _ _ _ _ _ _ _ _) = key `is_elem` derivableClassKeys
210 is_elem = isIn "is_X_Class"
227 -- ToDo: add binaryClass
230 = derivableClassKeys ++ numericClassKeys
231 ++ [ cCallableClassKey, cReturnableClassKey ]
233 -- We have to have "_CCallable" and "_CReturnable" in the standard
234 -- classes, so that if you go...
236 -- _ccall_ foo ... 93{-numeric literal-} ...
238 -- ... it can do The Right Thing on the 93.
241 %************************************************************************
243 \subsection[Class-instances]{Instance declarations for @Class@}
245 %************************************************************************
247 We compare @Classes@ by their keys (which include @Uniques@).
250 cmpClass (MkClass k1 _ _ _ _ _ _ _ _ _) (MkClass k2 _ _ _ _ _ _ _ _ _)
253 instance Eq Class where
254 (MkClass k1 _ _ _ _ _ _ _ _ _) == (MkClass k2 _ _ _ _ _ _ _ _ _) = k1 == k2
255 (MkClass k1 _ _ _ _ _ _ _ _ _) /= (MkClass k2 _ _ _ _ _ _ _ _ _) = k1 /= k2
257 instance Ord Class where
258 (MkClass k1 _ _ _ _ _ _ _ _ _) <= (MkClass k2 _ _ _ _ _ _ _ _ _) = k1 <= k2
259 (MkClass k1 _ _ _ _ _ _ _ _ _) < (MkClass k2 _ _ _ _ _ _ _ _ _) = k1 < k2
260 (MkClass k1 _ _ _ _ _ _ _ _ _) >= (MkClass k2 _ _ _ _ _ _ _ _ _) = k1 >= k2
261 (MkClass k1 _ _ _ _ _ _ _ _ _) > (MkClass k2 _ _ _ _ _ _ _ _ _) = k1 > k2
262 #ifdef __GLASGOW_HASKELL__
263 _tagCmp a b = case cmpClass a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
268 instance NamedThing Class where
269 getExportFlag (MkClass _ n _ _ _ _ _ _ _ _) = getExportFlag n
270 isLocallyDefined (MkClass _ n _ _ _ _ _ _ _ _) = isLocallyDefined n
271 getOrigName (MkClass _ n _ _ _ _ _ _ _ _) = getOrigName n
272 getOccurrenceName (MkClass _ n _ _ _ _ _ _ _ _) = getOccurrenceName n
273 getInformingModules (MkClass _ n _ _ _ _ _ _ _ _) = getInformingModules n
274 getSrcLoc (MkClass _ n _ _ _ _ _ _ _ _) = getSrcLoc n
275 fromPreludeCore (MkClass _ n _ _ _ _ _ _ _ _) = fromPreludeCore n
277 getTheUnique = panic "NamedThing.Class.getTheUnique"
278 hasType = panic "NamedThing.Class.hasType"
279 getType = panic "NamedThing.Class.getType"
282 And the usual output stuff:
284 instance Outputable Class where
285 -- we use pprIfaceClass for printing in interfaces
287 {- ppr sty@PprShowAll (MkClass u n _ _ _ ops _ _ _ _)
288 = ppCat [ppr sty n, pprUnique u, ppr sty ops]
290 ppr sty (MkClass u n _ _ _ _ _ _ _ _) = ppr sty n
293 %************************************************************************
295 \subsection[ClassOp-basic]{@ClassOp@: type and basic functions}
297 %************************************************************************
301 = MkClassOp FAST_STRING -- The operation name
303 Int -- Unique within a class; starts at 1
305 UniType -- Type; the class tyvar is free (you can find
306 -- it from the class). This means that a
307 -- ClassOp doesn't make much sense outside the
308 -- context of its parent class.
311 A @ClassOp@ represents a a class operation. From it and its parent
312 class we can construct the dictionary-selector @Id@ for the
313 operation/superclass dictionary, and the @Id@ for its default method.
314 It appears in a list inside the @Class@ object.
316 The type of a method in a @ClassOp@ object is its local type; that is,
317 without the overloading of the class itself. For example, in the
321 op :: Ord b => a -> b -> a
323 the type recorded for @op@ in the @ClassOp@ list of the @Class@ object is
326 @Ord@~\beta \Rightarrow
327 \alpha \rightarrow \beta \rightarrow alpha$
329 (where $\alpha$ is the class type variable recorded in the @Class@
330 object). Of course, the type of @op@ recorded in the GVE will be its
333 $\forall \alpha \forall \beta.~
334 @Foo@~\alpha \Rightarrow
335 ~@Ord@~\beta \Rightarrow \alpha
336 \rightarrow \beta \rightarrow alpha$
338 ******************************************************************
339 **** That is, the type variables of a class op selector
340 *** are all at the outer level.
341 ******************************************************************
344 mkClassOp = MkClassOp
346 getClassOpTag :: ClassOp -> Int
347 getClassOpTag (MkClassOp _ tag _) = tag
349 getClassOpString :: ClassOp -> FAST_STRING
350 getClassOpString (MkClassOp str _ _) = str
353 getClassOpSig :: ClassOp -> ([TyVarTemplate], ThetaType, TauType)
354 getClassOpSig (MkClassOp _ _ ty) = splitType ty
357 getClassOpLocalType :: ClassOp -> UniType {-SigmaType-}
358 getClassOpLocalType (MkClassOp _ _ ty) = ty
361 %************************************************************************
363 \subsection[ClassOp-instances]{Instance declarations for @ClassOp@}
365 %************************************************************************
367 @ClassOps@ are compared by their tags.
370 instance Eq ClassOp where
371 (MkClassOp _ i1 _) == (MkClassOp _ i2 _) = i1 == i2
372 (MkClassOp _ i1 _) /= (MkClassOp _ i2 _) = i1 == i2
374 instance Ord ClassOp where
375 (MkClassOp _ i1 _) <= (MkClassOp _ i2 _) = i1 <= i2
376 (MkClassOp _ i1 _) < (MkClassOp _ i2 _) = i1 < i2
377 (MkClassOp _ i1 _) >= (MkClassOp _ i2 _) = i1 >= i2
378 (MkClassOp _ i1 _) > (MkClassOp _ i2 _) = i1 > i2
379 -- ToDo: something for _tagCmp? (WDP 94/10)
382 And the usual output stuff:
384 instance Outputable ClassOp where