compiler/types/Class.lhs

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