ghc/compiler/types/Class.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[Class]{The @Class@ datatype}
   5
   6 \begin{code}
   7 module Class (
   8         Class, ClassOpItem, FunDep,
   9         DefMeth (..),
  10
  11         mkClass, classTyVars, classArity,
  12         classKey, className, classSelIds, classTyCon,
  13         classBigSig, classExtraBigSig, classTvsFds, classSCTheta,
  14         classHasFDs
  15     ) where
  16
  17 #include "HsVersions.h"
  18
  19 import {-# SOURCE #-} TyCon     ( TyCon )
  20 import {-# SOURCE #-} TypeRep   ( PredType )
  21
  22 import Var              ( Id, TyVar )
  23 import Name             ( NamedThing(..), Name )
  24 import BasicTypes       ( Arity )
  25 import Unique           ( Unique, Uniquable(..) )
  26 import Outputable
  27 import Util             ( notNull )
  28 \end{code}
  29
  30 %************************************************************************
  31 %*                                                                      *
  32 \subsection[Class-basic]{@Class@: basic definition}
  33 %*                                                                      *
  34 %************************************************************************
  35
  36 A @Class@ corresponds to a Greek kappa in the static semantics:
  37
  38 \begin{code}
  39 data Class
  40   = Class {
  41         classKey  :: Unique,                    -- Key for fast comparison
  42         className :: Name,
  43
  44         classTyVars  :: [TyVar],                -- The class type variables
  45         classFunDeps :: [FunDep TyVar],         -- The functional dependencies
  46
  47         classSCTheta :: [PredType],             -- Immediate superclasses, and the
  48         classSCSels  :: [Id],                   -- corresponding selector functions to
  49                                                 -- extract them from a dictionary of this
  50                                                 -- class
  51
  52         classOpStuff :: [ClassOpItem],          -- Ordered by tag
  53
  54         classTyCon :: TyCon             -- The data type constructor for dictionaries
  55   }                                     -- of this class
  56
  57 type FunDep a     = ([a],[a])   --  e.g. class C a b c |  a b -> c, a c -> b  where ...
  58                                 --  Here fun-deps are [([a,b],[c]), ([a,c],[b])]
  59
  60 type ClassOpItem = (Id, DefMeth)
  61         -- Selector function; contains unfolding
  62         -- Default-method info
  63
  64 data DefMeth = NoDefMeth                -- No default method
  65              | DefMeth                  -- A polymorphic default method
  66              | GenDefMeth               -- A generic default method
  67              deriving Eq
  68 \end{code}
  69
  70 The @mkClass@ function fills in the indirect superclasses.
  71
  72 \begin{code}
  73 mkClass :: Name -> [TyVar]
  74         -> [([TyVar], [TyVar])]
  75         -> [PredType] -> [Id]
  76         -> [ClassOpItem]
  77         -> TyCon
  78         -> Class
  79
  80 mkClass name tyvars fds super_classes superdict_sels
  81         op_stuff tycon
  82   = Class {     classKey = getUnique name,
  83                 className = name,
  84                 classTyVars = tyvars,
  85                 classFunDeps = fds,
  86                 classSCTheta = super_classes,
  87                 classSCSels = superdict_sels,
  88                 classOpStuff = op_stuff,
  89                 classTyCon = tycon }
  90 \end{code}
  91
  92 %************************************************************************
  93 %*                                                                      *
  94 \subsection[Class-selectors]{@Class@: simple selectors}
  95 %*                                                                      *
  96 %************************************************************************
  97
  98 The rest of these functions are just simple selectors.
  99
 100 \begin{code}
 101 classArity :: Class -> Arity
 102 classArity clas = length (classTyVars clas)
 103         -- Could memoise this
 104
 105 classSelIds (Class {classSCSels = sc_sels, classOpStuff = op_stuff})
 106   = sc_sels ++ [op_sel | (op_sel, _) <- op_stuff]
 107
 108 classTvsFds c
 109   = (classTyVars c, classFunDeps c)
 110
 111 classBigSig (Class {classTyVars = tyvars, classSCTheta = sc_theta,
 112                     classSCSels = sc_sels, classOpStuff = op_stuff})
 113   = (tyvars, sc_theta, sc_sels, op_stuff)
 114 classExtraBigSig (Class {classTyVars = tyvars, classFunDeps = fundeps,
 115                          classSCTheta = sc_theta, classSCSels = sc_sels,
 116                          classOpStuff = op_stuff})
 117   = (tyvars, fundeps, sc_theta, sc_sels, op_stuff)
 118
 119 classHasFDs :: Class -> Bool
 120 classHasFDs (Class {classFunDeps = fundeps}) = notNull fundeps
 121 \end{code}
 122
 123
 124 %************************************************************************
 125 %*                                                                      *
 126 \subsection[Class-instances]{Instance declarations for @Class@}
 127 %*                                                                      *
 128 %************************************************************************
 129
 130 We compare @Classes@ by their keys (which include @Uniques@).
 131
 132 \begin{code}
 133 instance Eq Class where
 134     c1 == c2 = classKey c1 == classKey c2
 135     c1 /= c2 = classKey c1 /= classKey c2
 136
 137 instance Ord Class where
 138     c1 <= c2 = classKey c1 <= classKey c2
 139     c1 <  c2 = classKey c1 <  classKey c2
 140     c1 >= c2 = classKey c1 >= classKey c2
 141     c1 >  c2 = classKey c1 >  classKey c2
 142     compare c1 c2 = classKey c1 `compare` classKey c2
 143 \end{code}
 144
 145 \begin{code}
 146 instance Uniquable Class where
 147     getUnique c = classKey c
 148
 149 instance NamedThing Class where
 150     getName clas = className clas
 151
 152 instance Outputable Class where
 153     ppr c = ppr (getName c)
 154
 155 instance Show Class where
 156     showsPrec p c = showsPrecSDoc p (ppr c)
 157
 158 instance Outputable DefMeth where
 159     ppr DefMeth     =  text "{- has default method -}"
 160     ppr GenDefMeth  =  text "{- has generic method -}"
 161     ppr NoDefMeth   =  empty   -- No default method
 162 \end{code}
 163
 164