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 {-# OPTIONS_GHC -w #-}
  10 -- The above warning supression flag is a temporary kludge.
  11 -- While working on this module you are encouraged to remove it and fix
  12 -- any warnings in the module. See
  13 --     http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings
  14 -- for details
  15
  16 module Class (
  17         Class, ClassOpItem,
  18         DefMeth (..),
  19
  20         FunDep, pprFundeps,
  21
  22         mkClass, classTyVars, classArity,
  23         classKey, className, classATs, classSelIds, classTyCon, classMethods,
  24         classBigSig, classExtraBigSig, classTvsFds, classSCTheta
  25     ) where
  26
  27 #include "HsVersions.h"
  28
  29 import {-# SOURCE #-} TyCon     ( TyCon )
  30 import {-# SOURCE #-} TypeRep   ( PredType )
  31
  32 import Var
  33 import Name
  34 import BasicTypes
  35 import Unique
  36 import Outputable
  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         classSCTheta :: [PredType],     -- Immediate superclasses, and the
  57         classSCSels  :: [Id],           -- corresponding selector functions
  58                                         -- to extract them from a dictionary
  59                                         -- of this class
  60
  61         classATs     :: [TyCon],        -- Associated type families
  62
  63         classOpStuff :: [ClassOpItem],  -- Ordered by tag
  64
  65         classTyCon :: TyCon             -- The data type constructor for
  66                                         -- dictionaries of this class
  67      }
  68
  69 type FunDep a = ([a],[a])  --  e.g. class C a b c | a b -> c, a c -> b where...
  70                            --  Here fun-deps are [([a,b],[c]), ([a,c],[b])]
  71
  72 type ClassOpItem = (Id, DefMeth)
  73         -- Selector function; contains unfolding
  74         -- Default-method info
  75
  76 data DefMeth = NoDefMeth                -- No default method
  77              | DefMeth                  -- A polymorphic default method
  78              | GenDefMeth               -- A generic default method
  79              deriving Eq
  80 \end{code}
  81
  82 The @mkClass@ function fills in the indirect superclasses.
  83
  84 \begin{code}
  85 mkClass :: Name -> [TyVar]
  86         -> [([TyVar], [TyVar])]
  87         -> [PredType] -> [Id]
  88         -> [TyCon]
  89         -> [ClassOpItem]
  90         -> TyCon
  91         -> Class
  92
  93 mkClass name tyvars fds super_classes superdict_sels ats
  94         op_stuff tycon
  95   = Class {     classKey = getUnique name,
  96                 className = name,
  97                 classTyVars = tyvars,
  98                 classFunDeps = fds,
  99                 classSCTheta = super_classes,
 100                 classSCSels = superdict_sels,
 101                 classATs = ats,
 102                 classOpStuff = op_stuff,
 103                 classTyCon = tycon }
 104 \end{code}
 105
 106 %************************************************************************
 107 %*                                                                      *
 108 \subsection[Class-selectors]{@Class@: simple selectors}
 109 %*                                                                      *
 110 %************************************************************************
 111
 112 The rest of these functions are just simple selectors.
 113
 114 \begin{code}
 115 classArity :: Class -> Arity
 116 classArity clas = length (classTyVars clas)
 117         -- Could memoise this
 118
 119 classSelIds :: Class -> [Id]
 120 classSelIds c@(Class {classSCSels = sc_sels})
 121   = sc_sels ++ classMethods c
 122
 123 classMethods :: Class -> [Id]
 124 classMethods (Class {classOpStuff = op_stuff})
 125   = [op_sel | (op_sel, _) <- op_stuff]
 126
 127 classTvsFds c
 128   = (classTyVars c, classFunDeps c)
 129
 130 classBigSig (Class {classTyVars = tyvars, classSCTheta = sc_theta,
 131                     classSCSels = sc_sels, classOpStuff = op_stuff})
 132   = (tyvars, sc_theta, sc_sels, op_stuff)
 133 classExtraBigSig (Class {classTyVars = tyvars, classFunDeps = fundeps,
 134                          classSCTheta = sc_theta, classSCSels = sc_sels,
 135                          classATs = ats, classOpStuff = op_stuff})
 136   = (tyvars, fundeps, sc_theta, sc_sels, ats, op_stuff)
 137 \end{code}
 138
 139
 140 %************************************************************************
 141 %*                                                                      *
 142 \subsection[Class-instances]{Instance declarations for @Class@}
 143 %*                                                                      *
 144 %************************************************************************
 145
 146 We compare @Classes@ by their keys (which include @Uniques@).
 147
 148 \begin{code}
 149 instance Eq Class where
 150     c1 == c2 = classKey c1 == classKey c2
 151     c1 /= c2 = classKey c1 /= classKey c2
 152
 153 instance Ord Class where
 154     c1 <= c2 = classKey c1 <= classKey c2
 155     c1 <  c2 = classKey c1 <  classKey c2
 156     c1 >= c2 = classKey c1 >= classKey c2
 157     c1 >  c2 = classKey c1 >  classKey c2
 158     compare c1 c2 = classKey c1 `compare` classKey c2
 159 \end{code}
 160
 161 \begin{code}
 162 instance Uniquable Class where
 163     getUnique c = classKey c
 164
 165 instance NamedThing Class where
 166     getName clas = className clas
 167
 168 instance Outputable Class where
 169     ppr c = ppr (getName c)
 170
 171 instance Show Class where
 172     showsPrec p c = showsPrecSDoc p (ppr c)
 173
 174 instance Outputable DefMeth where
 175     ppr DefMeth     =  text "{- has default method -}"
 176     ppr GenDefMeth  =  text "{- has generic method -}"
 177     ppr NoDefMeth   =  empty   -- No default method
 178
 179 pprFundeps :: Outputable a => [FunDep a] -> SDoc
 180 pprFundeps []  = empty
 181 pprFundeps fds = hsep (ptext SLIT("|") : punctuate comma (map ppr_fd fds))
 182                where
 183                  ppr_fd (us, vs) = hsep [interppSP us, ptext SLIT("->"),
 184                                          interppSP vs]
 185 \end{code}
 186