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, classGlobalIds,
  14         classSuperDictSelId, classOpId, classDefaultMethodId,
  15         classSig, classBigSig, classInstEnv,
  16         isSuperClassOf,
  17         classOpTagByOccName, classOpTagByOccName_maybe,
  18
  19         GenClassOp(..), SYN_IE(ClassOp),
  20         mkClassOp,
  21         classOpTag, classOpString,
  22         classOpLocalType,
  23
  24         SYN_IE(ClassInstEnv)
  25     ) where
  26
  27 CHK_Ubiq() -- debugging consistency check
  28
  29 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
  30 IMPORT_DELOOPER(TyLoop)
  31 #else
  32 import {-# SOURCE #-} Id
  33 import {-# SOURCE #-} Type
  34 import {-# SOURCE #-} TysWiredIn
  35 import {-# SOURCE #-} TysPrim
  36 #endif
  37
  38 #if __GLASGOW_HASKELL__ >= 202
  39 import Name
  40 #endif
  41
  42 import TyCon            ( TyCon )
  43 import TyVar            ( SYN_IE(TyVar), GenTyVar )
  44 import Usage            ( GenUsage, SYN_IE(Usage), SYN_IE(UVar) )
  45
  46 import MatchEnv         ( MatchEnv )
  47 import Maybes           ( assocMaybe )
  48 import Name             ( changeUnique, Name, OccName, occNameString )
  49 import Outputable
  50 import Unique           -- Keys for built-in classes
  51 import UniqFM           ( SYN_IE(Uniquable))
  52 import Pretty           ( Doc, hsep, ptext )
  53 import SrcLoc           ( SrcLoc )
  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 The parameterisation wrt tyvar and uvar is only necessary to
  66 get appropriately general instances of Ord3 for GenType.
  67
  68 \begin{code}
  69 data GenClassOp ty
  70   = ClassOp     OccName -- The operation name
  71
  72                 Int     -- Unique within a class; starts at 1
  73
  74                 ty      -- Type; the class tyvar is free (you can find
  75                         -- it from the class). This means that a
  76                         -- ClassOp doesn't make much sense outside the
  77                         -- context of its parent class.
  78
  79 data GenClass tyvar uvar
  80   = Class
  81         Unique          -- Key for fast comparison
  82         Name
  83
  84         tyvar           -- The class type variable
  85
  86         [GenClass tyvar uvar]   -- Immediate superclasses, and the
  87         [Id]                    -- corresponding selector functions to
  88                                 -- extract them from a dictionary of this
  89                                 -- class
  90
  91         [GenClassOp (GenType tyvar uvar)] -- The * class operations
  92         [Id]                              --     * selector functions
  93         [Id]                              --     * default methods
  94                           -- They are all ordered by tag.  The
  95                           -- selector ids are less innocent than they
  96                           -- look, because their IdInfos contains
  97                           -- suitable specialisation information.  In
  98                           -- particular, constant methods are
  99                           -- instances of selectors at suitably simple
 100                           -- types.
 101
 102         ClassInstEnv      -- Gives details of all the instances of this class
 103
 104         [(GenClass tyvar uvar, [GenClass tyvar uvar])]
 105                           -- Indirect superclasses;
 106                           --   (k,[k1,...,kn]) means that
 107                           --   k is an immediate superclass of k1
 108                           --   k1 is an immediate superclass of k2
 109                           --   ... and kn is an immediate superclass
 110                           -- of this class.  (This is all redundant
 111                           -- information, since it can be derived from
 112                           -- the superclass information above.)
 113
 114 type Class        = GenClass TyVar UVar
 115 type ClassOp      = GenClassOp Type
 116
 117 type ClassInstEnv = MatchEnv Type Id            -- The Ids are dfuns
 118 \end{code}
 119
 120 The @mkClass@ function fills in the indirect superclasses.
 121
 122 \begin{code}
 123 mkClass :: Unique -> Name -> TyVar
 124         -> [Class] -> [Id]
 125         -> [ClassOp] -> [Id] -> [Id]
 126         -> ClassInstEnv
 127         -> Class
 128
 129 mkClass uniq full_name tyvar super_classes superdict_sels
 130         class_ops dict_sels defms class_insts
 131   = Class uniq (changeUnique full_name uniq) tyvar
 132                 super_classes superdict_sels
 133                 class_ops dict_sels defms
 134                 class_insts
 135                 trans_clos
 136   where
 137     trans_clos :: [(Class,[Class])]
 138     trans_clos = transitiveClosure succ (==) [ (clas, []) | clas <- super_classes ]
 139
 140     succ (clas@(Class _ _ _ super_classes _ _ _ _ _ _), links)
 141       = [(super, (clas:links)) | super <- super_classes]
 142 \end{code}
 143
 144 %************************************************************************
 145 %*                                                                      *
 146 \subsection[Class-selectors]{@Class@: simple selectors}
 147 %*                                                                      *
 148 %************************************************************************
 149
 150 The rest of these functions are just simple selectors.
 151
 152 \begin{code}
 153 classKey (Class key _ _ _ _ _ _ _ _ _) = key
 154 classOps (Class _ _ _ _ _ ops _ _ _ _) = ops
 155 classGlobalIds (Class _ _ _ _ _ _ sels defm_ids _ _) = sels ++ defm_ids
 156
 157 classOpId (Class _ _ _ _ _ ops op_ids _ _ _) op
 158   = op_ids !! (classOpTag op - 1)
 159
 160 classDefaultMethodId (Class _ _ _ _ _ ops _ defm_ids _ _) idx
 161   = defm_ids !! idx
 162
 163 classSuperDictSelId (Class _ _ _ scs scsel_ids _ _ _ _ _) super_clas
 164   = assoc "classSuperDictSelId" (scs `zip` scsel_ids) super_clas
 165
 166 classSig :: GenClass t u -> (t, [GenClass t u], [GenClassOp (GenType t u)])
 167 classSig (Class _ _ tyvar super_classes _ ops _ _ _ _)
 168   = (tyvar, super_classes, ops)
 169
 170 classBigSig (Class _ _ tyvar super_classes sdsels ops sels defms _ _)
 171   = (tyvar, super_classes, sdsels, ops, sels, defms)
 172
 173 classInstEnv (Class _ _ _ _ _ _ _ _ inst_env _) = inst_env
 174 \end{code}
 175
 176 @a `isSuperClassOf` b@ returns @Nothing@ if @a@ is not a superclass of
 177 @b@, but if it is, it returns $@Just@~[k_1,\ldots,k_n]$, where the
 178 $k_1,\ldots,k_n$ are exactly as described in the definition of the
 179 @GenClass@ constructor above.
 180
 181 \begin{code}
 182 isSuperClassOf :: Class -> Class -> Maybe [Class]
 183 clas `isSuperClassOf` (Class _ _ _ _ _ _ _ _ _ links) = assocMaybe links clas
 184 \end{code}
 185
 186 %************************************************************************
 187 %*                                                                      *
 188 \subsection[Class-instances]{Instance declarations for @Class@}
 189 %*                                                                      *
 190 %************************************************************************
 191
 192 We compare @Classes@ by their keys (which include @Uniques@).
 193
 194 \begin{code}
 195 instance Ord3 (GenClass tyvar uvar) where
 196   cmp (Class k1 _ _ _ _ _ _ _ _ _) (Class k2 _ _ _ _ _ _ _ _ _)  = cmp k1 k2
 197
 198 instance Eq (GenClass tyvar uvar) where
 199     (Class k1 _ _ _ _ _ _ _ _ _) == (Class k2 _ _ _ _ _ _ _ _ _) = k1 == k2
 200     (Class k1 _ _ _ _ _ _ _ _ _) /= (Class k2 _ _ _ _ _ _ _ _ _) = k1 /= k2
 201
 202 instance Ord (GenClass tyvar uvar) where
 203     (Class k1 _ _ _ _ _ _ _ _ _) <= (Class k2 _ _ _ _ _ _ _ _ _) = k1 <= k2
 204     (Class k1 _ _ _ _ _ _ _ _ _) <  (Class k2 _ _ _ _ _ _ _ _ _) = k1 <  k2
 205     (Class k1 _ _ _ _ _ _ _ _ _) >= (Class k2 _ _ _ _ _ _ _ _ _) = k1 >= k2
 206     (Class k1 _ _ _ _ _ _ _ _ _) >  (Class k2 _ _ _ _ _ _ _ _ _) = k1 >  k2
 207     _tagCmp a b = case cmp a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
 208 \end{code}
 209
 210 \begin{code}
 211 instance Uniquable (GenClass tyvar uvar) where
 212     uniqueOf (Class u _ _ _ _ _ _ _ _ _) = u
 213
 214 instance NamedThing (GenClass tyvar uvar) where
 215     getName (Class _ n _ _ _ _ _ _ _ _) = n
 216
 217 instance NamedThing (GenClassOp ty) where
 218     getOccName (ClassOp occ _ _) = occ
 219 \end{code}
 220
 221
 222 %************************************************************************
 223 %*                                                                      *
 224 \subsection[ClassOp-basic]{@ClassOp@: type and basic functions}
 225 %*                                                                      *
 226 %************************************************************************
 227
 228 A @ClassOp@ represents a a class operation.  From it and its parent
 229 class we can construct the dictionary-selector @Id@ for the
 230 operation/superclass dictionary, and the @Id@ for its default method.
 231 It appears in a list inside the @Class@ object.
 232
 233 The type of a method in a @ClassOp@ object is its local type; that is,
 234 without the overloading of the class itself.  For example, in the
 235 declaration
 236 \begin{pseudocode}
 237         class Foo a where
 238                 op :: Ord b => a -> b -> a
 239 \end{pseudocode}
 240 the type recorded for @op@ in the @ClassOp@ list of the @Class@ object is
 241 just
 242         $\forall \beta.~
 243                 @Ord@~\beta \Rightarrow
 244                 \alpha \rightarrow \beta \rightarrow alpha$
 245
 246 (where $\alpha$ is the class type variable recorded in the @Class@
 247 object).  Of course, the type of @op@ recorded in the GVE will be its
 248 ``full'' type
 249
 250         $\forall \alpha \forall \beta.~
 251                 @Foo@~\alpha \Rightarrow
 252                 ~@Ord@~\beta \Rightarrow \alpha
 253                 \rightarrow \beta \rightarrow alpha$
 254
 255 ******************************************************************
 256 **** That is, the type variables of a class op selector
 257 ***  are all at the outer level.
 258 ******************************************************************
 259
 260 \begin{code}
 261 mkClassOp :: OccName -> Int -> ty -> GenClassOp ty
 262 mkClassOp name tag ty = ClassOp name tag ty
 263
 264 classOpTag :: GenClassOp ty -> Int
 265 classOpTag    (ClassOp _ tag _) = tag
 266
 267 classOpString :: GenClassOp ty -> FAST_STRING
 268 classOpString (ClassOp occ _ _) = occNameString occ
 269
 270 classOpLocalType :: GenClassOp ty -> ty {-SigmaType-}
 271 classOpLocalType (ClassOp _ _ ty) = ty
 272 \end{code}
 273
 274 Rather unsavoury ways of getting ClassOp tags:
 275 \begin{code}
 276 classOpTagByOccName_maybe :: Class -> OccName -> Maybe Int
 277 classOpTagByOccName       :: Class -> OccName -> Int
 278
 279 classOpTagByOccName clas op
 280   = case (classOpTagByOccName_maybe clas op) of
 281       Just tag -> tag
 282 #ifdef DEBUG
 283       Nothing  -> pprPanic "classOpTagByOccName:" (hsep (ppr PprDebug op : map (ptext . classOpString) (classOps clas)))
 284 #endif
 285
 286 classOpTagByOccName_maybe clas op
 287   = go (classOps clas) 1
 288   where
 289     go []                     _   = Nothing
 290     go (ClassOp occ _ _ : ns) tag = if occ == op
 291                                     then Just tag
 292                                     else go ns (tag+1)
 293 \end{code}
 294
 295 %************************************************************************
 296 %*                                                                      *
 297 \subsection[ClassOp-instances]{Instance declarations for @ClassOp@}
 298 %*                                                                      *
 299 %************************************************************************
 300
 301 @ClassOps@ are compared by their tags.
 302
 303 \begin{code}
 304 instance Eq (GenClassOp ty) where
 305     (ClassOp _ i1 _) == (ClassOp _ i2 _) = i1 == i2
 306     (ClassOp _ i1 _) /= (ClassOp _ i2 _) = i1 == i2
 307
 308 instance Ord (GenClassOp ty) where
 309     (ClassOp _ i1 _) <= (ClassOp _ i2 _) = i1 <= i2
 310     (ClassOp _ i1 _) <  (ClassOp _ i2 _) = i1 <  i2
 311     (ClassOp _ i1 _) >= (ClassOp _ i2 _) = i1 >= i2
 312     (ClassOp _ i1 _) >  (ClassOp _ i2 _) = i1 >  i2
 313     -- ToDo: something for _tagCmp? (WDP 94/10)
 314 \end{code}