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