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