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