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,
   9         DefMeth (..),
  10
  11         FunDep, pprFundeps,
  12
  13         mkClass, classTyVars, classArity,
  14         classKey, className, classATs, classSelIds, classTyCon, classMethods,
  15         classBigSig, classExtraBigSig, classTvsFds, classSCTheta
  16     ) where
  17
  18 #include "HsVersions.h"
  19
  20 import {-# SOURCE #-} TyCon     ( TyCon )
  21 import {-# SOURCE #-} TypeRep   ( PredType )
  22
  23 import Var              ( Id, TyVar )
  24 import Name             ( NamedThing(..), Name )
  25 import BasicTypes       ( Arity )
  26 import Unique           ( Unique, Uniquable(..) )
  27 import Outputable
  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
  49                                         -- to extract them from a dictionary
  50                                         -- of this class
  51
  52         classATs     :: [TyCon],        -- Associated type families
  53
  54         classOpStuff :: [ClassOpItem],  -- Ordered by tag
  55
  56         classTyCon :: TyCon             -- The data type constructor for
  57                                         -- dictionaries of this class
  58      }
  59
  60 type FunDep a = ([a],[a])  --  e.g. class C a b c | a b -> c, a c -> b where...
  61                            --  Here fun-deps are [([a,b],[c]), ([a,c],[b])]
  62
  63 type ClassOpItem = (Id, DefMeth)
  64         -- Selector function; contains unfolding
  65         -- Default-method info
  66
  67 data DefMeth = NoDefMeth                -- No default method
  68              | DefMeth                  -- A polymorphic default method
  69              | GenDefMeth               -- A generic default method
  70              deriving Eq
  71 \end{code}
  72
  73 The @mkClass@ function fills in the indirect superclasses.
  74
  75 \begin{code}
  76 mkClass :: Name -> [TyVar]
  77         -> [([TyVar], [TyVar])]
  78         -> [PredType] -> [Id]
  79         -> [TyCon]
  80         -> [ClassOpItem]
  81         -> TyCon
  82         -> Class
  83
  84 mkClass name tyvars fds super_classes superdict_sels ats
  85         op_stuff tycon
  86   = Class {     classKey = getUnique name,
  87                 className = name,
  88                 classTyVars = tyvars,
  89                 classFunDeps = fds,
  90                 classSCTheta = super_classes,
  91                 classSCSels = superdict_sels,
  92                 classATs = ats,
  93                 classOpStuff = op_stuff,
  94                 classTyCon = tycon }
  95 \end{code}
  96
  97 %************************************************************************
  98 %*                                                                      *
  99 \subsection[Class-selectors]{@Class@: simple selectors}
 100 %*                                                                      *
 101 %************************************************************************
 102
 103 The rest of these functions are just simple selectors.
 104
 105 \begin{code}
 106 classArity :: Class -> Arity
 107 classArity clas = length (classTyVars clas)
 108         -- Could memoise this
 109
 110 classSelIds :: Class -> [Id]
 111 classSelIds c@(Class {classSCSels = sc_sels})
 112   = sc_sels ++ classMethods c
 113
 114 classMethods :: Class -> [Id]
 115 classMethods (Class {classOpStuff = op_stuff})
 116   = [op_sel | (op_sel, _) <- op_stuff]
 117
 118 classTvsFds c
 119   = (classTyVars c, classFunDeps c)
 120
 121 classBigSig (Class {classTyVars = tyvars, classSCTheta = sc_theta,
 122                     classSCSels = sc_sels, classOpStuff = op_stuff})
 123   = (tyvars, sc_theta, sc_sels, op_stuff)
 124 classExtraBigSig (Class {classTyVars = tyvars, classFunDeps = fundeps,
 125                          classSCTheta = sc_theta, classSCSels = sc_sels,
 126                          classATs = ats, classOpStuff = op_stuff})
 127   = (tyvars, fundeps, sc_theta, sc_sels, ats, op_stuff)
 128 \end{code}
 129
 130
 131 %************************************************************************
 132 %*                                                                      *
 133 \subsection[Class-instances]{Instance declarations for @Class@}
 134 %*                                                                      *
 135 %************************************************************************
 136
 137 We compare @Classes@ by their keys (which include @Uniques@).
 138
 139 \begin{code}
 140 instance Eq Class where
 141     c1 == c2 = classKey c1 == classKey c2
 142     c1 /= c2 = classKey c1 /= classKey c2
 143
 144 instance Ord Class where
 145     c1 <= c2 = classKey c1 <= classKey c2
 146     c1 <  c2 = classKey c1 <  classKey c2
 147     c1 >= c2 = classKey c1 >= classKey c2
 148     c1 >  c2 = classKey c1 >  classKey c2
 149     compare c1 c2 = classKey c1 `compare` classKey c2
 150 \end{code}
 151
 152 \begin{code}
 153 instance Uniquable Class where
 154     getUnique c = classKey c
 155
 156 instance NamedThing Class where
 157     getName clas = className clas
 158
 159 instance Outputable Class where
 160     ppr c = ppr (getName c)
 161
 162 instance Show Class where
 163     showsPrec p c = showsPrecSDoc p (ppr c)
 164
 165 instance Outputable DefMeth where
 166     ppr DefMeth     =  text "{- has default method -}"
 167     ppr GenDefMeth  =  text "{- has generic method -}"
 168     ppr NoDefMeth   =  empty   -- No default method
 169
 170 pprFundeps :: Outputable a => [FunDep a] -> SDoc
 171 pprFundeps []  = empty
 172 pprFundeps fds = hsep (ptext SLIT("|") : punctuate comma (map ppr_fd fds))
 173                where
 174                  ppr_fd (us, vs) = hsep [interppSP us, ptext SLIT("->"),
 175                                          interppSP vs]
 176 \end{code}
 177