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, classSelIds, classDictArgTys,
  14         classSuperDictSelId, classDefaultMethodId,
  15         classBigSig, classInstEnv,
  16         isSuperClassOf,
  17         classOpTagByOccName,
  18
  19         SYN_IE(ClassInstEnv)
  20     ) where
  21
  22 CHK_Ubiq() -- debugging consistency check
  23
  24 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
  25 IMPORT_DELOOPER(TyLoop)
  26 IMPORT_DELOOPER(IdLoop)
  27 #else
  28 import {-# SOURCE #-} Id        ( Id, idType, idName )
  29 import {-# SOURCE #-} Type
  30 import {-# SOURCE #-} TysWiredIn
  31 import {-# SOURCE #-} TysPrim
  32 #endif
  33
  34 #if __GLASGOW_HASKELL__ >= 202
  35 import Name
  36 #endif
  37
  38 import TyCon            ( TyCon )
  39 import TyVar            ( SYN_IE(TyVar), GenTyVar )
  40 import Usage            ( GenUsage, SYN_IE(Usage), SYN_IE(UVar) )
  41
  42 import MatchEnv         ( MatchEnv )
  43 import Maybes           ( assocMaybe )
  44 import Name             ( changeUnique, Name, OccName, occNameString )
  45 import Unique           -- Keys for built-in classes
  46 import Pretty           ( Doc, hsep, ptext )
  47 import SrcLoc           ( SrcLoc )
  48 import Outputable
  49 import Util
  50 \end{code}
  51
  52 %************************************************************************
  53 %*                                                                      *
  54 \subsection[Class-basic]{@Class@: basic definition}
  55 %*                                                                      *
  56 %************************************************************************
  57
  58 A @Class@ corresponds to a Greek kappa in the static semantics:
  59
  60 The parameterisation wrt tyvar and uvar is only necessary to
  61 get appropriately general instances of Ord3 for GenType.
  62
  63 \begin{code}
  64 data GenClass tyvar uvar
  65   = Class
  66         Unique          -- Key for fast comparison
  67         Name
  68
  69         tyvar           -- The class type variable
  70
  71         [GenClass tyvar uvar]   -- Immediate superclasses, and the
  72         [Id]                    -- corresponding selector functions to
  73                                 -- extract them from a dictionary of this
  74                                 -- class
  75
  76         [Id]                              --     * selector functions
  77         [Maybe Id]                        --     * default methods
  78                           -- They are all ordered by tag.  The
  79                           -- selector ids are less innocent than they
  80                           -- look, because their IdInfos contains
  81                           -- suitable specialisation information.  In
  82                           -- particular, constant methods are
  83                           -- instances of selectors at suitably simple
  84                           -- types.
  85
  86         ClassInstEnv      -- Gives details of all the instances of this class
  87
  88         [(GenClass tyvar uvar, [GenClass tyvar uvar])]
  89                           -- Indirect superclasses;
  90                           --   (k,[k1,...,kn]) means that
  91                           --   k is an immediate superclass of k1
  92                           --   k1 is an immediate superclass of k2
  93                           --   ... and kn is an immediate superclass
  94                           -- of this class.  (This is all redundant
  95                           -- information, since it can be derived from
  96                           -- the superclass information above.)
  97
  98 type Class        = GenClass TyVar UVar
  99
 100 type ClassInstEnv = MatchEnv Type Id            -- The Ids are dfuns
 101 \end{code}
 102
 103 The @mkClass@ function fills in the indirect superclasses.
 104
 105 \begin{code}
 106 mkClass :: Unique -> Name -> TyVar
 107         -> [Class] -> [Id]
 108         -> [Id] -> [Maybe Id]
 109         -> ClassInstEnv
 110         -> Class
 111
 112 mkClass uniq full_name tyvar super_classes superdict_sels
 113         dict_sels defms class_insts
 114   = Class uniq (changeUnique full_name uniq) tyvar
 115                 super_classes superdict_sels
 116                 dict_sels defms
 117                 class_insts
 118                 trans_clos
 119   where
 120     trans_clos :: [(Class,[Class])]
 121     trans_clos = transitiveClosure succ (==) [ (clas, []) | clas <- super_classes ]
 122
 123     succ (clas@(Class _ _ _ super_classes _ _ _ _ _), links)
 124       = [(super, (clas:links)) | super <- super_classes]
 125 \end{code}
 126
 127 %************************************************************************
 128 %*                                                                      *
 129 \subsection[Class-selectors]{@Class@: simple selectors}
 130 %*                                                                      *
 131 %************************************************************************
 132
 133 The rest of these functions are just simple selectors.
 134
 135 \begin{code}
 136 classKey (Class key _ _ _ _ _ _ _ _) = key
 137 classSelIds (Class _ _ _ _ _ sels _ _ _) = sels
 138
 139 classDefaultMethodId (Class _ _ _ _ _ _ defm_ids _ _) idx
 140   = defm_ids !! idx
 141
 142 classSuperDictSelId (Class _ _ _ scs scsel_ids _ _ _ _) super_clas
 143   = assoc "classSuperDictSelId" (scs `zip` scsel_ids) super_clas
 144
 145 classBigSig (Class _ _ tyvar super_classes sdsels sels defms _ _)
 146   = (tyvar, super_classes, sdsels, sels, defms)
 147
 148 classInstEnv (Class _ _ _ _ _ _ _ inst_env _) = inst_env
 149
 150 classDictArgTys :: Class -> Type -> [Type]      -- Types of components of the dictionary (C ty)
 151 classDictArgTys (Class _ _ _ _ sc_sel_ids meth_sel_ids _ _ _) ty
 152   = map mk_arg_ty (sc_sel_ids ++ meth_sel_ids)
 153   where
 154     mk_arg_ty id = case splitRhoTy (applyTy (idType id) ty) of
 155                         (sel_theta, meth_ty) -> ASSERT( length sel_theta == 1 )
 156                                                 meth_ty
 157
 158 classOpTagByOccName clas occ
 159   = go (classSelIds clas) 1
 160   where
 161     go (sel_id : sel_ids) tag
 162             | getOccName (idName sel_id) == occ = tag
 163             | otherwise                         = go sel_ids (tag+1)
 164     go [] _ = pprPanic "classOpTagByOccName"
 165                 (hsep [ppr PprDebug (getName clas), ppr PprDebug occ])
 166 \end{code}
 167
 168 @a `isSuperClassOf` b@ returns @Nothing@ if @a@ is not a superclass of
 169 @b@, but if it is, it returns $@Just@~[k_1,\ldots,k_n]$, where the
 170 $k_1,\ldots,k_n$ are exactly as described in the definition of the
 171 @GenClass@ constructor above.
 172
 173 \begin{code}
 174 isSuperClassOf :: Class -> Class -> Maybe [Class]
 175 clas `isSuperClassOf` (Class _ _ _ _ _ _ _ _ links) = assocMaybe links clas
 176 \end{code}
 177
 178 %************************************************************************
 179 %*                                                                      *
 180 \subsection[Class-instances]{Instance declarations for @Class@}
 181 %*                                                                      *
 182 %************************************************************************
 183
 184 We compare @Classes@ by their keys (which include @Uniques@).
 185
 186 \begin{code}
 187 instance Ord3 (GenClass tyvar uvar) where
 188   cmp (Class k1 _ _ _ _ _ _ _ _) (Class k2 _ _ _ _ _ _ _ _)  = cmp k1 k2
 189
 190 instance Eq (GenClass tyvar uvar) where
 191     (Class k1 _ _ _ _ _ _ _ _) == (Class k2 _ _ _ _ _ _ _ _) = k1 == k2
 192     (Class k1 _ _ _ _ _ _ _ _) /= (Class k2 _ _ _ _ _ _ _ _) = k1 /= k2
 193
 194 instance Ord (GenClass tyvar uvar) where
 195     (Class k1 _ _ _ _ _ _ _ _) <= (Class k2 _ _ _ _ _ _ _ _) = k1 <= k2
 196     (Class k1 _ _ _ _ _ _ _ _) <  (Class k2 _ _ _ _ _ _ _ _) = k1 <  k2
 197     (Class k1 _ _ _ _ _ _ _ _) >= (Class k2 _ _ _ _ _ _ _ _) = k1 >= k2
 198     (Class k1 _ _ _ _ _ _ _ _) >  (Class k2 _ _ _ _ _ _ _ _) = k1 >  k2
 199     _tagCmp a b = case cmp a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
 200 \end{code}
 201
 202 \begin{code}
 203 instance Uniquable (GenClass tyvar uvar) where
 204     uniqueOf (Class u _ _ _ _ _ _ _ _) = u
 205
 206 instance NamedThing (GenClass tyvar uvar) where
 207     getName (Class _ n _ _ _ _ _ _ _) = n
 208 \end{code}
 209
 210