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