[project @ 1996-01-08 20:28:12 by partain]
[ghc.git] / ghc / compiler / uniType / Class.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
3 %
4 \section[Class]{The @Class@ datatype}
5
6 \begin{code}
7 #include "HsVersions.h"
8
9 module Class (
10         Class(..),      -- must be *NON*-abstract so UniTyFuns can see it
11
12         mkClass,
13         getClassKey, getClassOps,
14         getSuperDictSelId, getClassOpId, getDefaultMethodId,
15         getConstMethodId,
16         getClassSig, getClassBigSig, getClassInstEnv,
17 --UNUSED: getClassDefaultMethodsInfo,
18         isSuperClassOf,
19         cmpClass,
20
21         derivableClassKeys,
22         isNumericClass, isStandardClass, --UNUSED: isDerivableClass,
23
24         ClassOp(..),    -- must be non-abstract so UniTyFuns can see them
25         mkClassOp,
26         getClassOpTag, getClassOpString,
27 --UNUSED: getClassOpSig,
28         getClassOpLocalType,
29
30         -- and to make the interface self-sufficient...
31         Id, InstTemplate, Maybe, Name, FullName, TyVarTemplate,
32         UniType, Unique
33     ) where
34
35 import Id               ( getIdSpecialisation, Id )
36 import IdInfo
37 import InstEnv          ( ClassInstEnv(..), MatchEnv(..) )
38 import Maybes           ( assocMaybe, Maybe(..) )
39 import Name             ( Name(..), ShortName )
40 import NameTypes        ( FullName, SrcLoc )
41 import Pretty
42 import Outputable       -- class for printing, forcing
43 import TyCon            ( TyCon, Arity(..)
44                           IF_ATTACK_PRAGMAS(COMMA cmpTyCon)
45                         )
46 import TyVar            ( TyVarTemplate )
47 import Unique           -- class key stuff
48 import UniType          ( UniType, ThetaType(..), TauType(..)
49                           IF_ATTACK_PRAGMAS(COMMA cmpUniType)
50                         )
51 import UniTyFuns        ( splitType, pprClassOp
52                           IF_ATTACK_PRAGMAS(COMMA pprUniType COMMA pprTyCon)
53                         )
54 import Util
55 \end{code}
56
57 %************************************************************************
58 %*                                                                      *
59 \subsection[Class-basic]{@Class@: basic definition}
60 %*                                                                      *
61 %************************************************************************
62
63 A @Class@ corresponds to a Greek kappa in the static semantics:
64
65 \begin{code}
66 data Class
67   = MkClass 
68         Unique{-ClassKey-}-- Key for fast comparison
69         FullName
70
71         TyVarTemplate     -- The class type variable
72
73         [Class] [Id]      -- Immediate superclasses, and the
74                           -- corresponding selector functions to
75                           -- extract them from a dictionary of this
76                           -- class
77
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
87                           -- types.
88
89         ClassInstEnv      -- Gives details of all the instances of this class
90
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.)
99 \end{code}
100
101 The @mkClass@ function fills in the indirect superclasses.
102
103 \begin{code}
104 mkClass :: Name -> TyVarTemplate
105         -> [Class] -> [Id]
106         -> [ClassOp] -> [Id] -> [Id]
107         -> ClassInstEnv
108         -> Class
109
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
115                 class_insts
116                 trans_clos
117   where
118     (key,full_name) = case name of
119                         OtherClass  uniq full_name _ -> (uniq, full_name)
120                         PreludeClass key full_name   -> (key,  full_name)
121
122     trans_clos :: [(Class,[Class])]
123     trans_clos = transitiveClosure succ (==) [ (clas, []) | clas <- super_classes ]
124
125     succ (clas@(MkClass _ _ _ super_classes _ _ _ _ _ _), links) 
126       = [(super, (clas:links)) | super <- super_classes]
127 \end{code}
128
129 %************************************************************************
130 %*                                                                      *
131 \subsection[Class-selectors]{@Class@: simple selectors}
132 %*                                                                      *
133 %************************************************************************
134
135 The rest of these functions are just simple selectors.
136
137 \begin{code}
138 getClassKey (MkClass key _ _ _ _ _ _ _ _ _) = key
139
140 getClassOps (MkClass _ _ _ _ _ ops _ _ _ _) = ops
141
142 getSuperDictSelId (MkClass _ _ _ scs scsel_ids _ _ _ _ _) super_clas
143   = assoc "getSuperDictSelId" (scs `zip` scsel_ids) super_clas
144
145 getClassOpId (MkClass _ _ _ _ _ ops op_ids _ _ _) op
146   = op_ids !! (getClassOpTag op - 1)
147
148 getDefaultMethodId (MkClass _ _ _ _ _ ops _ defm_ids _ _) op
149   = defm_ids !! (getClassOpTag op - 1)
150
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).
154     let
155         sel_id = op_ids !! (getClassOpTag op - 1)
156     in
157     case (lookupConstMethodId (getIdSpecialisation sel_id) ty) of
158       Just xx -> xx
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."
164         ]))
165
166 getClassSig :: Class -> (TyVarTemplate, [Class], [ClassOp])
167
168 getClassSig (MkClass _ _ tyvar super_classes _ ops _ _ _ _)
169   = (tyvar, super_classes, ops)
170
171 getClassBigSig (MkClass _ _ tyvar super_classes sdsels ops sels defms _ _)
172   = (tyvar, super_classes, sdsels, ops, sels, defms)
173
174 getClassInstEnv (MkClass _ _ _ _ _ _ _ _ inst_env _) = inst_env
175
176 --UNUSED: getClassDefaultMethodsInfo (MkClass _ _ _ _ _ _ _ defms _ _) = defms
177 \end{code}
178
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.
183
184 \begin{code}
185 isSuperClassOf :: Class -> Class -> Maybe [Class]
186
187 clas `isSuperClassOf` (MkClass _ _ _ _ _ _ _ _ _ links) = assocMaybe links clas
188 \end{code}
189
190 %************************************************************************
191 %*                                                                      *
192 \subsection[Class-std-groups]{Standard groups of Prelude classes}
193 %*                                                                      *
194 %************************************************************************
195
196 @derivableClassKeys@ is also used in checking \tr{deriving} constructs
197 (@TcDeriv@).
198
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.
202
203 \begin{code}
204 isNumericClass, isStandardClass {-UNUSED:, isDerivableClass-} :: Class -> Bool
205
206 isNumericClass   (MkClass key _ _ _ _ _ _ _ _ _) = key `is_elem` numericClassKeys
207 isStandardClass  (MkClass key _ _ _ _ _ _ _ _ _) = key `is_elem` standardClassKeys
208 --isDerivableClass (MkClass key _ _ _ _ _ _ _ _ _) = key `is_elem` derivableClassKeys
209
210 is_elem = isIn "is_X_Class"
211
212 numericClassKeys
213   = [ numClassKey, 
214       realClassKey, 
215       integralClassKey, 
216       fractionalClassKey, 
217       floatingClassKey, 
218       realFracClassKey, 
219       realFloatClassKey ]
220
221 derivableClassKeys
222   = [ eqClassKey, 
223       textClassKey, 
224       ordClassKey, 
225       enumClassKey, 
226       ixClassKey ]
227       -- ToDo: add binaryClass
228
229 standardClassKeys
230   = derivableClassKeys ++ numericClassKeys
231     ++ [ cCallableClassKey, cReturnableClassKey ]
232     --
233     -- We have to have "_CCallable" and "_CReturnable" in the standard
234     -- classes, so that if you go...
235     --
236     --      _ccall_ foo ... 93{-numeric literal-} ...
237     --
238     -- ... it can do The Right Thing on the 93.
239 \end{code}
240
241 %************************************************************************
242 %*                                                                      *
243 \subsection[Class-instances]{Instance declarations for @Class@}
244 %*                                                                      *
245 %************************************************************************
246
247 We compare @Classes@ by their keys (which include @Uniques@).
248
249 \begin{code}
250 cmpClass (MkClass k1 _ _ _ _ _ _ _ _ _) (MkClass k2 _ _ _ _ _ _ _ _ _)
251   = cmpUnique k1 k2
252
253 instance Eq Class where
254     (MkClass k1 _ _ _ _ _ _ _ _ _) == (MkClass k2 _ _ _ _ _ _ _ _ _) = k1 == k2
255     (MkClass k1 _ _ _ _ _ _ _ _ _) /= (MkClass k2 _ _ _ _ _ _ _ _ _) = k1 /= k2
256
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 }
264 #endif
265 \end{code}
266
267 \begin{code}
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
276
277     getTheUnique = panic "NamedThing.Class.getTheUnique"
278     hasType      = panic "NamedThing.Class.hasType"
279     getType      = panic "NamedThing.Class.getType"
280 \end{code}
281
282 And the usual output stuff:
283 \begin{code}
284 instance Outputable Class where
285     -- we use pprIfaceClass for printing in interfaces
286
287 {-  ppr sty@PprShowAll (MkClass u n _ _ _ ops _ _ _ _)
288       = ppCat [ppr sty n, pprUnique u, ppr sty ops]
289 -}
290     ppr sty (MkClass u n _ _ _ _ _ _ _ _) = ppr sty n
291 \end{code}
292
293 %************************************************************************
294 %*                                                                      *
295 \subsection[ClassOp-basic]{@ClassOp@: type and basic functions}
296 %*                                                                      *
297 %************************************************************************
298
299 \begin{code}
300 data ClassOp
301   = MkClassOp   FAST_STRING -- The operation name
302
303                 Int     -- Unique within a class; starts at 1
304
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.
309 \end{code}
310
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.
315
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
318 declaration
319 \begin{pseudocode}
320         class Foo a where
321                 op :: Ord b => a -> b -> a
322 \end{pseudocode}
323 the type recorded for @op@ in the @ClassOp@ list of the @Class@ object is
324 just 
325         $\forall \beta.~
326                 @Ord@~\beta \Rightarrow 
327                 \alpha \rightarrow \beta \rightarrow alpha$ 
328
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
331 ``full'' type
332
333         $\forall \alpha \forall \beta.~ 
334                 @Foo@~\alpha \Rightarrow
335                 ~@Ord@~\beta \Rightarrow \alpha
336                 \rightarrow \beta \rightarrow alpha$
337
338 ******************************************************************
339 **** That is, the type variables of a class op selector
340 ***  are all at the outer level.
341 ******************************************************************
342
343 \begin{code}
344 mkClassOp = MkClassOp
345
346 getClassOpTag :: ClassOp -> Int
347 getClassOpTag    (MkClassOp _ tag _) = tag
348
349 getClassOpString :: ClassOp -> FAST_STRING
350 getClassOpString (MkClassOp str _ _) = str
351
352 {- UNUSED:
353 getClassOpSig :: ClassOp -> ([TyVarTemplate], ThetaType, TauType)
354 getClassOpSig (MkClassOp _ _ ty) = splitType ty
355 -}
356
357 getClassOpLocalType :: ClassOp -> UniType {-SigmaType-}
358 getClassOpLocalType (MkClassOp _ _ ty) = ty
359 \end{code}
360
361 %************************************************************************
362 %*                                                                      *
363 \subsection[ClassOp-instances]{Instance declarations for @ClassOp@}
364 %*                                                                      *
365 %************************************************************************
366
367 @ClassOps@ are compared by their tags.
368
369 \begin{code}
370 instance Eq ClassOp where
371     (MkClassOp _ i1 _) == (MkClassOp _ i2 _) = i1 == i2
372     (MkClassOp _ i1 _) /= (MkClassOp _ i2 _) = i1 == i2
373
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)
380 \end{code}
381
382 And the usual output stuff:
383 \begin{code}
384 instance Outputable ClassOp where
385     ppr = pprClassOp
386 \end{code}