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}