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