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, needsDataDeclCtxtClassKeys,
  20         cCallishClassKeys, isNoDictClass,
  21         isNumericClass, isStandardClass, isCcallishClass,
  22
  23         GenClassOp(..), ClassOp(..),
  24         mkClassOp,
  25         classOpTag, classOpString,
  26         classOpLocalType,
  27
  28         ClassInstEnv(..)
  29     ) where
  30
  31 CHK_Ubiq() -- debugging consistency check
  32
  33 IMPORT_DELOOPER(TyLoop)
  34
  35 import TyCon            ( TyCon )
  36 import TyVar            ( TyVar(..), GenTyVar )
  37 import Usage            ( GenUsage, Usage(..), UVar(..) )
  38
  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 )
  45 import Util
  46 \end{code}
  47
  48 %************************************************************************
  49 %*                                                                      *
  50 \subsection[Class-basic]{@Class@: basic definition}
  51 %*                                                                      *
  52 %************************************************************************
  53
  54 A @Class@ corresponds to a Greek kappa in the static semantics:
  55
  56 The parameterisation wrt tyvar and uvar is only necessary to
  57 get appropriately general instances of Ord3 for GenType.
  58
  59 \begin{code}
  60 data GenClassOp ty
  61   = ClassOp     FAST_STRING -- The operation name
  62
  63                 Int     -- Unique within a class; starts at 1
  64
  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.
  69
  70 data GenClass tyvar uvar
  71   = Class
  72         Unique          -- Key for fast comparison
  73         Name
  74
  75         tyvar           -- The class type variable
  76
  77         [GenClass tyvar uvar]   -- Immediate superclasses, and the
  78         [Id]                    -- corresponding selector functions to
  79                                 -- extract them from a dictionary of this
  80                                 -- class
  81
  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
  91                           -- types.
  92
  93         ClassInstEnv      -- Gives details of all the instances of this class
  94
  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.)
 104
 105 type Class        = GenClass TyVar UVar
 106 type ClassOp      = GenClassOp Type
 107
 108 type ClassInstEnv = MatchEnv Type Id            -- The Ids are dfuns
 109 \end{code}
 110
 111 The @mkClass@ function fills in the indirect superclasses.
 112
 113 \begin{code}
 114 mkClass :: Unique -> Name -> TyVar
 115         -> [Class] -> [Id]
 116         -> [ClassOp] -> [Id] -> [Id]
 117         -> ClassInstEnv
 118         -> Class
 119
 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
 125                 class_insts
 126                 trans_clos
 127   where
 128     trans_clos :: [(Class,[Class])]
 129     trans_clos = transitiveClosure succ (==) [ (clas, []) | clas <- super_classes ]
 130
 131     succ (clas@(Class _ _ _ super_classes _ _ _ _ _ _), links)
 132       = [(super, (clas:links)) | super <- super_classes]
 133 \end{code}
 134
 135 %************************************************************************
 136 %*                                                                      *
 137 \subsection[Class-selectors]{@Class@: simple selectors}
 138 %*                                                                      *
 139 %************************************************************************
 140
 141 The rest of these functions are just simple selectors.
 142
 143 \begin{code}
 144 classKey (Class key _ _ _ _ _ _ _ _ _) = key
 145 classOps (Class _ _ _ _ _ ops _ _ _ _) = ops
 146 classSelIds (Class _ _ _ _ _ _ sels _ _ _) = sels
 147
 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
 154
 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)
 158
 159 classBigSig (Class _ _ tyvar super_classes sdsels ops sels defms _ _)
 160   = (tyvar, super_classes, sdsels, ops, sels, defms)
 161
 162 classInstEnv (Class _ _ _ _ _ _ _ _ inst_env _) = inst_env
 163 \end{code}
 164
 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.
 169
 170 \begin{code}
 171 isSuperClassOf :: Class -> Class -> Maybe [Class]
 172 clas `isSuperClassOf` (Class _ _ _ _ _ _ _ _ _ links) = assocMaybe links clas
 173 \end{code}
 174
 175 %************************************************************************
 176 %*                                                                      *
 177 \subsection[Class-std-groups]{Standard groups of Prelude classes}
 178 %*                                                                      *
 179 %************************************************************************
 180
 181 @derivableClassKeys@ is also used in checking \tr{deriving} constructs
 182 (@TcDeriv@).
 183
 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.
 187
 188 \begin{code}
 189 isNumericClass, isStandardClass :: Class -> Bool
 190
 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"
 197
 198 numericClassKeys
 199   = [ numClassKey
 200     , realClassKey
 201     , integralClassKey
 202     , fractionalClassKey
 203     , floatingClassKey
 204     , realFracClassKey
 205     , realFloatClassKey
 206     ]
 207
 208 derivableClassKeys
 209   = [ eqClassKey
 210     , ordClassKey
 211     , enumClassKey
 212     , evalClassKey
 213     , boundedClassKey
 214     , showClassKey
 215     , readClassKey
 216     , ixClassKey
 217     ]
 218
 219 needsDataDeclCtxtClassKeys -- see comments in TcDeriv
 220   = [ readClassKey
 221     ]
 222
 223 cCallishClassKeys = [ cCallableClassKey, cReturnableClassKey ]
 224
 225 standardClassKeys
 226   = derivableClassKeys ++ numericClassKeys ++ cCallishClassKeys
 227     --
 228     -- We have to have "CCallable" and "CReturnable" in the standard
 229     -- classes, so that if you go...
 230     --
 231     --      _ccall_ foo ... 93{-numeric literal-} ...
 232     --
 233     -- ... it can do The Right Thing on the 93.
 234
 235 noDictClassKeys         -- These classes are used only for type annotations;
 236                         -- they are not implemented by dictionaries, ever.
 237   = cCallishClassKeys
 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
 243         -- in the end.
 244 \end{code}
 245
 246 %************************************************************************
 247 %*                                                                      *
 248 \subsection[Class-instances]{Instance declarations for @Class@}
 249 %*                                                                      *
 250 %************************************************************************
 251
 252 We compare @Classes@ by their keys (which include @Uniques@).
 253
 254 \begin{code}
 255 instance Ord3 (GenClass tyvar uvar) where
 256   cmp (Class k1 _ _ _ _ _ _ _ _ _) (Class k2 _ _ _ _ _ _ _ _ _)  = cmp k1 k2
 257
 258 instance Eq (GenClass tyvar uvar) where
 259     (Class k1 _ _ _ _ _ _ _ _ _) == (Class k2 _ _ _ _ _ _ _ _ _) = k1 == k2
 260     (Class k1 _ _ _ _ _ _ _ _ _) /= (Class k2 _ _ _ _ _ _ _ _ _) = k1 /= k2
 261
 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 }
 268 \end{code}
 269
 270 \begin{code}
 271 instance Uniquable (GenClass tyvar uvar) where
 272     uniqueOf (Class u _ _ _ _ _ _ _ _ _) = u
 273
 274 instance NamedThing (GenClass tyvar uvar) where
 275     getName (Class _ n _ _ _ _ _ _ _ _) = n
 276 \end{code}
 277
 278
 279 %************************************************************************
 280 %*                                                                      *
 281 \subsection[ClassOp-basic]{@ClassOp@: type and basic functions}
 282 %*                                                                      *
 283 %************************************************************************
 284
 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.
 289
 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
 292 declaration
 293 \begin{pseudocode}
 294         class Foo a where
 295                 op :: Ord b => a -> b -> a
 296 \end{pseudocode}
 297 the type recorded for @op@ in the @ClassOp@ list of the @Class@ object is
 298 just
 299         $\forall \beta.~
 300                 @Ord@~\beta \Rightarrow
 301                 \alpha \rightarrow \beta \rightarrow alpha$
 302
 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
 305 ``full'' type
 306
 307         $\forall \alpha \forall \beta.~
 308                 @Foo@~\alpha \Rightarrow
 309                 ~@Ord@~\beta \Rightarrow \alpha
 310                 \rightarrow \beta \rightarrow alpha$
 311
 312 ******************************************************************
 313 **** That is, the type variables of a class op selector
 314 ***  are all at the outer level.
 315 ******************************************************************
 316
 317 \begin{code}
 318 mkClassOp :: FAST_STRING -> Int -> ty -> GenClassOp ty
 319 mkClassOp name tag ty = ClassOp name tag ty
 320
 321 classOpTag :: GenClassOp ty -> Int
 322 classOpTag    (ClassOp _ tag _) = tag
 323
 324 classOpString :: GenClassOp ty -> FAST_STRING
 325 classOpString (ClassOp str _ _) = str
 326
 327 classOpLocalType :: GenClassOp ty -> ty {-SigmaType-}
 328 classOpLocalType (ClassOp _ _ ty) = ty
 329 \end{code}
 330
 331 Rather unsavoury ways of getting ClassOp tags:
 332 \begin{code}
 333 classOpTagByString :: Class -> FAST_STRING -> Int
 334
 335 classOpTagByString clas op
 336   = go (map classOpString (classOps clas)) 1
 337   where
 338     go (n:ns) tag = if n == op
 339                     then tag
 340                     else go ns (tag+1)
 341 #ifdef DEBUG
 342     go []     tag = pprPanic "classOpTagByString:" (ppCat (ppPStr op : map (ppPStr . classOpString) (classOps clas)))
 343 #endif
 344 \end{code}
 345
 346 %************************************************************************
 347 %*                                                                      *
 348 \subsection[ClassOp-instances]{Instance declarations for @ClassOp@}
 349 %*                                                                      *
 350 %************************************************************************
 351
 352 @ClassOps@ are compared by their tags.
 353
 354 \begin{code}
 355 instance Eq (GenClassOp ty) where
 356     (ClassOp _ i1 _) == (ClassOp _ i2 _) = i1 == i2
 357     (ClassOp _ i1 _) /= (ClassOp _ i2 _) = i1 == i2
 358
 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)
 365 \end{code}