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