ghc/compiler/types/Class.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[Class]{The @Class@ datatype}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module Class (
  10         GenClass(..), Class(..),
  11
  12         mkClass,
  13         classKey, classOps, classSelIds,
  14         classSuperDictSelId, classOpId, classDefaultMethodId,
  15         classSig, classBigSig, classInstEnv,
  16         isSuperClassOf,
  17         classOpTagByString,
  18
  19         derivableClassKeys, cCallishClassKeys,
  20         isNumericClass, isStandardClass, isCcallishClass,
  21
  22         GenClassOp(..), ClassOp(..),
  23         mkClassOp,
  24         classOpTag, classOpString,
  25         classOpLocalType,
  26
  27         ClassInstEnv(..)
  28     ) where
  29
  30 CHK_Ubiq() -- debugging consistency check
  31
  32 import TyLoop
  33
  34 import TyCon            ( TyCon )
  35 import TyVar            ( TyVar(..), GenTyVar )
  36 import Usage            ( GenUsage, Usage(..), UVar(..) )
  37
  38 import Maybes           ( assocMaybe, Maybe )
  39 import Unique           -- Keys for built-in classes
  40 import Pretty           ( Pretty(..), ppCat{-ToDo:rm-}, ppPStr{-ditto-} )
  41 import PprStyle         ( PprStyle )
  42 import SrcLoc           ( SrcLoc )
  43 import Util
  44 \end{code}
  45
  46 %************************************************************************
  47 %*                                                                      *
  48 \subsection[Class-basic]{@Class@: basic definition}
  49 %*                                                                      *
  50 %************************************************************************
  51
  52 A @Class@ corresponds to a Greek kappa in the static semantics:
  53
  54 The parameterisation wrt tyvar and uvar is only necessary to
  55 get appropriately general instances of Ord3 for GenType.
  56
  57 \begin{code}
  58 data GenClassOp ty
  59   = ClassOp     FAST_STRING -- The operation name
  60
  61                 Int     -- Unique within a class; starts at 1
  62
  63                 ty      -- Type; the class tyvar is free (you can find
  64                         -- it from the class). This means that a
  65                         -- ClassOp doesn't make much sense outside the
  66                         -- context of its parent class.
  67
  68 data GenClass tyvar uvar
  69   = Class
  70         Unique          -- Key for fast comparison
  71         Name
  72
  73         tyvar           -- The class type variable
  74
  75         [GenClass tyvar uvar]   -- Immediate superclasses, and the
  76         [Id]                    -- corresponding selector functions to
  77                                 -- extract them from a dictionary of this
  78                                 -- class
  79
  80         [GenClassOp (GenType tyvar uvar)] -- The * class operations
  81         [Id]                              --     * selector functions
  82         [Id]                              --     * default methods
  83                           -- They are all ordered by tag.  The
  84                           -- selector ids are less innocent than they
  85                           -- look, because their IdInfos contains
  86                           -- suitable specialisation information.  In
  87                           -- particular, constant methods are
  88                           -- instances of selectors at suitably simple
  89                           -- types.
  90
  91         ClassInstEnv      -- Gives details of all the instances of this class
  92
  93         [(GenClass tyvar uvar, [GenClass tyvar uvar])]
  94                           -- Indirect superclasses;
  95                           --   (k,[k1,...,kn]) means that
  96                           --   k is an immediate superclass of k1
  97                           --   k1 is an immediate superclass of k2
  98                           --   ... and kn is an immediate superclass
  99                           -- of this class.  (This is all redundant
 100                           -- information, since it can be derived from
 101                           -- the superclass information above.)
 102
 103 type Class        = GenClass TyVar UVar
 104 type ClassOp      = GenClassOp Type
 105
 106 type ClassInstEnv = MatchEnv Type Id            -- The Ids are dfuns
 107 \end{code}
 108
 109 The @mkClass@ function fills in the indirect superclasses.
 110
 111 \begin{code}
 112 mkClass :: Unique -> Name -> TyVar
 113         -> [Class] -> [Id]
 114         -> [ClassOp] -> [Id] -> [Id]
 115         -> ClassInstEnv
 116         -> Class
 117
 118 mkClass uniq full_name tyvar super_classes superdict_sels
 119         class_ops dict_sels defms class_insts
 120   = Class uniq full_name tyvar
 121                 super_classes superdict_sels
 122                 class_ops dict_sels defms
 123                 class_insts
 124                 trans_clos
 125   where
 126     trans_clos :: [(Class,[Class])]
 127     trans_clos = transitiveClosure succ (==) [ (clas, []) | clas <- super_classes ]
 128
 129     succ (clas@(Class _ _ _ super_classes _ _ _ _ _ _), links)
 130       = [(super, (clas:links)) | super <- super_classes]
 131 \end{code}
 132
 133 %************************************************************************
 134 %*                                                                      *
 135 \subsection[Class-selectors]{@Class@: simple selectors}
 136 %*                                                                      *
 137 %************************************************************************
 138
 139 The rest of these functions are just simple selectors.
 140
 141 \begin{code}
 142 classKey (Class key _ _ _ _ _ _ _ _ _) = key
 143 classOps (Class _ _ _ _ _ ops _ _ _ _) = ops
 144 classSelIds (Class _ _ _ _ _ _ sels _ _ _) = sels
 145
 146 classOpId (Class _ _ _ _ _ ops op_ids _ _ _) op
 147   = op_ids !! (classOpTag op - 1)
 148 classDefaultMethodId (Class _ _ _ _ _ ops _ defm_ids _ _) op
 149   = defm_ids !! (classOpTag op - 1)
 150 classSuperDictSelId (Class _ _ _ scs scsel_ids _ _ _ _ _) super_clas
 151   = assoc "classSuperDictSelId" (scs `zip` scsel_ids) super_clas
 152
 153 classSig :: GenClass t u -> (t, [GenClass t u], [GenClassOp (GenType t u)])
 154 classSig (Class _ _ tyvar super_classes _ ops _ _ _ _)
 155   = (tyvar, super_classes, ops)
 156
 157 classBigSig (Class _ _ tyvar super_classes sdsels ops sels defms _ _)
 158   = (tyvar, super_classes, sdsels, ops, sels, defms)
 159
 160 classInstEnv (Class _ _ _ _ _ _ _ _ inst_env _) = inst_env
 161 \end{code}
 162
 163 @a `isSuperClassOf` b@ returns @Nothing@ if @a@ is not a superclass of
 164 @b@, but if it is, it returns $@Just@~[k_1,\ldots,k_n]$, where the
 165 $k_1,\ldots,k_n$ are exactly as described in the definition of the
 166 @GenClass@ constructor above.
 167
 168 \begin{code}
 169 isSuperClassOf :: Class -> Class -> Maybe [Class]
 170 clas `isSuperClassOf` (Class _ _ _ _ _ _ _ _ _ links) = assocMaybe links clas
 171 \end{code}
 172
 173 %************************************************************************
 174 %*                                                                      *
 175 \subsection[Class-std-groups]{Standard groups of Prelude classes}
 176 %*                                                                      *
 177 %************************************************************************
 178
 179 @derivableClassKeys@ is also used in checking \tr{deriving} constructs
 180 (@TcDeriv@).
 181
 182 NOTE: @Eq@ and @Text@ do need to appear in @standardClasses@
 183 even though every numeric class has these two as a superclass,
 184 because the list of ambiguous dictionaries hasn't been simplified.
 185
 186 \begin{code}
 187 isNumericClass, isStandardClass :: Class -> Bool
 188
 189 isNumericClass   (Class key _ _ _ _ _ _ _ _ _) = --pprTrace "isNum:" (ppCat (map pprUnique (key : numericClassKeys ))) $
 190                                                  key `is_elem` numericClassKeys
 191 isStandardClass  (Class key _ _ _ _ _ _ _ _ _) = key `is_elem` standardClassKeys
 192 isCcallishClass  (Class key _ _ _ _ _ _ _ _ _) = key `is_elem` cCallishClassKeys
 193 is_elem = isIn "is_X_Class"
 194
 195 numericClassKeys
 196   = [ numClassKey,
 197       realClassKey,
 198       integralClassKey,
 199       fractionalClassKey,
 200       floatingClassKey,
 201       realFracClassKey,
 202       realFloatClassKey ]
 203
 204 derivableClassKeys
 205   = [ eqClassKey,
 206       showClassKey,
 207       ordClassKey,
 208       boundedClassKey,
 209       enumClassKey,
 210       ixClassKey,
 211       readClassKey ]
 212
 213 cCallishClassKeys = [ cCallableClassKey, cReturnableClassKey ]
 214
 215 standardClassKeys
 216   = derivableClassKeys ++ numericClassKeys ++ cCallishClassKeys
 217     --
 218     -- We have to have "CCallable" and "CReturnable" in the standard
 219     -- classes, so that if you go...
 220     --
 221     --      _ccall_ foo ... 93{-numeric literal-} ...
 222     --
 223     -- ... it can do The Right Thing on the 93.
 224 \end{code}
 225
 226 %************************************************************************
 227 %*                                                                      *
 228 \subsection[Class-instances]{Instance declarations for @Class@}
 229 %*                                                                      *
 230 %************************************************************************
 231
 232 We compare @Classes@ by their keys (which include @Uniques@).
 233
 234 \begin{code}
 235 instance Ord3 (GenClass tyvar uvar) where
 236   cmp (Class k1 _ _ _ _ _ _ _ _ _) (Class k2 _ _ _ _ _ _ _ _ _)
 237     = cmp k1 k2
 238
 239 instance Eq (GenClass tyvar uvar) where
 240     (Class k1 _ _ _ _ _ _ _ _ _) == (Class k2 _ _ _ _ _ _ _ _ _) = k1 == k2
 241     (Class k1 _ _ _ _ _ _ _ _ _) /= (Class k2 _ _ _ _ _ _ _ _ _) = k1 /= k2
 242
 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 }
 249 \end{code}
 250
 251 \begin{code}
 252 instance Uniquable (GenClass tyvar uvar) where
 253     uniqueOf (Class u _ _ _ _ _ _ _ _ _) = u
 254
 255 instance NamedThing (GenClass tyvar uvar) where
 256     getName (Class _ n _ _ _ _ _ _ _ _) = n
 257 \end{code}
 258
 259
 260 %************************************************************************
 261 %*                                                                      *
 262 \subsection[ClassOp-basic]{@ClassOp@: type and basic functions}
 263 %*                                                                      *
 264 %************************************************************************
 265
 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.
 270
 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
 273 declaration
 274 \begin{pseudocode}
 275         class Foo a where
 276                 op :: Ord b => a -> b -> a
 277 \end{pseudocode}
 278 the type recorded for @op@ in the @ClassOp@ list of the @Class@ object is
 279 just
 280         $\forall \beta.~
 281                 @Ord@~\beta \Rightarrow
 282                 \alpha \rightarrow \beta \rightarrow alpha$
 283
 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
 286 ``full'' type
 287
 288         $\forall \alpha \forall \beta.~
 289                 @Foo@~\alpha \Rightarrow
 290                 ~@Ord@~\beta \Rightarrow \alpha
 291                 \rightarrow \beta \rightarrow alpha$
 292
 293 ******************************************************************
 294 **** That is, the type variables of a class op selector
 295 ***  are all at the outer level.
 296 ******************************************************************
 297
 298 \begin{code}
 299 mkClassOp :: FAST_STRING -> Int -> ty -> GenClassOp ty
 300 mkClassOp name tag ty = ClassOp name tag ty
 301
 302 classOpTag :: GenClassOp ty -> Int
 303 classOpTag    (ClassOp _ tag _) = tag
 304
 305 classOpString :: GenClassOp ty -> FAST_STRING
 306 classOpString (ClassOp str _ _) = str
 307
 308 classOpLocalType :: GenClassOp ty -> ty {-SigmaType-}
 309 classOpLocalType (ClassOp _ _ ty) = ty
 310 \end{code}
 311
 312 Rather unsavoury ways of getting ClassOp tags:
 313 \begin{code}
 314 classOpTagByString :: Class -> FAST_STRING -> Int
 315
 316 classOpTagByString clas op
 317   = go (map classOpString (classOps clas)) 1
 318   where
 319     go (n:ns) tag = if n == op
 320                     then tag
 321                     else go ns (tag+1)
 322 #ifdef DEBUG
 323     go []     tag = pprPanic "classOpTagByString:" (ppCat (ppPStr op : map (ppPStr . classOpString) (classOps clas)))
 324 #endif
 325 \end{code}
 326
 327 %************************************************************************
 328 %*                                                                      *
 329 \subsection[ClassOp-instances]{Instance declarations for @ClassOp@}
 330 %*                                                                      *
 331 %************************************************************************
 332
 333 @ClassOps@ are compared by their tags.
 334
 335 \begin{code}
 336 instance Eq (GenClassOp ty) where
 337     (ClassOp _ i1 _) == (ClassOp _ i2 _) = i1 == i2
 338     (ClassOp _ i1 _) /= (ClassOp _ i2 _) = i1 == i2
 339
 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)
 346 \end{code}