Merge branch 'master' of darcs.haskell.org:/home/darcs/ghc
[ghc.git] / 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 -fno-warn-tabs #-}
10 -- The above warning supression flag is a temporary kludge.
11 -- While working on this module you are encouraged to remove it and
12 -- detab the module (please do the detabbing in a separate patch). See
13 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
14 -- for details
15
16 module Class (
17         Class,
18         ClassOpItem, DefMeth (..),
19         ClassATItem, ATDefault (..),
20         defMethSpecOfDefMeth,
21
22         FunDep, pprFundeps, pprFunDep,
23
24         mkClass, classTyVars, classArity, 
25         classKey, className, classATs, classATItems, classTyCon, classMethods,
26         classOpItems, classBigSig, classExtraBigSig, classTvsFds, classSCTheta,
27         classAllSelIds, classSCSelId
28     ) where
29
30 #include "Typeable.h"
31 #include "HsVersions.h"
32
33 import {-# SOURCE #-} TyCon     ( TyCon, tyConName, tyConUnique )
34 import {-# SOURCE #-} TypeRep   ( Type, PredType )
35
36 import Var
37 import Name
38 import BasicTypes
39 import Unique
40 import Util
41 import Outputable
42 import SrcLoc
43 import FastString
44
45 import Data.Typeable (Typeable)
46 import qualified Data.Data as Data
47 \end{code}
48
49 %************************************************************************
50 %*                                                                      *
51 \subsection[Class-basic]{@Class@: basic definition}
52 %*                                                                      *
53 %************************************************************************
54
55 A @Class@ corresponds to a Greek kappa in the static semantics:
56
57 \begin{code}
58 data Class
59   = Class {
60         classTyCon :: TyCon,    -- The data type constructor for
61                                 -- dictionaries of this class
62                                 -- See Note [ATyCon for classes] in TypeRep
63
64         className :: Name,              -- Just the cached name of the TyCon
65         classKey  :: Unique,            -- Cached unique of TyCon
66         
67         classTyVars  :: [TyVar],        -- The class kind and type variables;
68                                         -- identical to those of the TyCon
69
70         classFunDeps :: [FunDep TyVar], -- The functional dependencies
71
72         -- Superclasses: eg: (F a ~ b, F b ~ G a, Eq a, Show b)
73         -- We need value-level selectors for both the dictionary 
74         -- superclasses and the equality superclasses
75         classSCTheta :: [PredType],     -- Immediate superclasses, 
76         classSCSels  :: [Id],           -- Selector functions to extract the
77                                         --   superclasses from a 
78                                         --   dictionary of this class
79         -- Associated types
80         classATStuff :: [ClassATItem],  -- Associated type families
81
82         -- Class operations (methods, not superclasses)
83         classOpStuff :: [ClassOpItem]   -- Ordered by tag
84      }
85   deriving Typeable
86
87 type FunDep a = ([a],[a])  --  e.g. class C a b c | a b -> c, a c -> b where...
88                            --  Here fun-deps are [([a,b],[c]), ([a,c],[b])]
89
90 type ClassOpItem = (Id, DefMeth)
91         -- Selector function; contains unfolding
92         -- Default-method info
93
94 data DefMeth = NoDefMeth                -- No default method
95              | DefMeth Name             -- A polymorphic default method
96              | GenDefMeth Name          -- A generic default method
97              deriving Eq
98
99 type ClassATItem = (TyCon,           -- See Note [Associated type tyvar names]
100                     [ATDefault])     -- Default associated types from these templates 
101   -- We can have more than one default per type; see
102   -- Note [Associated type defaults] in TcTyClsDecls
103
104 -- Each associated type default template is a quad of:
105 data ATDefault = ATD { -- TyVars of the RHS and family arguments 
106                        -- (including, but perhaps more than, the class TVs)
107                        atDefaultTys     :: [TyVar],
108                        -- The instantiated family arguments
109                        atDefaultPats    :: [Type],
110                        -- The RHS of the synonym
111                        atDefaultRhs     :: Type,
112                        -- The source location of the synonym
113                        atDefaultSrcSpan :: SrcSpan }
114
115 -- | Convert a `DefMethSpec` to a `DefMeth`, which discards the name field in
116 --   the `DefMeth` constructor of the `DefMeth`.
117 defMethSpecOfDefMeth :: DefMeth -> DefMethSpec
118 defMethSpecOfDefMeth meth
119  = case meth of
120         NoDefMeth       -> NoDM
121         DefMeth _       -> VanillaDM
122         GenDefMeth _    -> GenericDM
123
124 \end{code}
125
126 The @mkClass@ function fills in the indirect superclasses.
127
128 \begin{code}
129 mkClass :: [TyVar]
130         -> [([TyVar], [TyVar])]
131         -> [PredType] -> [Id]
132         -> [ClassATItem]
133         -> [ClassOpItem]
134         -> TyCon
135         -> Class
136
137 mkClass tyvars fds super_classes superdict_sels at_stuff
138         op_stuff tycon
139   = Class {     classKey     = tyConUnique tycon, 
140                 className    = tyConName tycon,
141                 classTyVars  = tyvars,
142                 classFunDeps = fds,
143                 classSCTheta = super_classes,
144                 classSCSels  = superdict_sels,
145                 classATStuff = at_stuff,
146                 classOpStuff = op_stuff,
147                 classTyCon   = tycon }
148 \end{code}
149
150 Note [Associated type tyvar names]
151 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
152 The TyCon of an associated type should use the same variable names as its
153 parent class. Thus
154     class C a b where
155       type F b x a :: *
156 We make F use the same Name for 'a' as C does, and similary 'b'.
157
158 The only reason for this is when checking instances it's easier to match 
159 them up, to ensure they match.  Eg
160     instance C Int [d] where
161       type F [d] x Int = ....
162 we should make sure that the first and third args match the instance
163 header.
164
165 This is the reason we use the Name and TyVar from the parent declaration,
166 in both class and instance decls: just to make this check easier.
167
168
169 %************************************************************************
170 %*                                                                      *
171 \subsection[Class-selectors]{@Class@: simple selectors}
172 %*                                                                      *
173 %************************************************************************
174
175 The rest of these functions are just simple selectors.
176
177 \begin{code}
178 classArity :: Class -> Arity
179 classArity clas = length (classTyVars clas)
180         -- Could memoise this
181
182 classAllSelIds :: Class -> [Id]
183 -- Both superclass-dictionary and method selectors
184 classAllSelIds c@(Class {classSCSels = sc_sels})
185   = sc_sels ++ classMethods c
186
187 classSCSelId :: Class -> Int -> Id
188 -- Get the n'th superclass selector Id
189 -- where n is 0-indexed, and counts 
190 --    *all* superclasses including equalities
191 classSCSelId (Class { classSCSels = sc_sels }) n
192   = ASSERT( n >= 0 && n < length sc_sels )
193     sc_sels !! n
194
195 classMethods :: Class -> [Id]
196 classMethods (Class {classOpStuff = op_stuff})
197   = [op_sel | (op_sel, _) <- op_stuff]
198
199 classOpItems :: Class -> [ClassOpItem]
200 classOpItems = classOpStuff
201
202 classATs :: Class -> [TyCon]
203 classATs (Class { classATStuff = at_stuff })
204   = [tc | (tc, _) <- at_stuff]
205
206 classATItems :: Class -> [ClassATItem]
207 classATItems = classATStuff
208
209 classTvsFds :: Class -> ([TyVar], [FunDep TyVar])
210 classTvsFds c
211   = (classTyVars c, classFunDeps c)
212
213 classBigSig :: Class -> ([TyVar], [PredType], [Id], [ClassOpItem])
214 classBigSig (Class {classTyVars = tyvars, classSCTheta = sc_theta, 
215                     classSCSels = sc_sels, classOpStuff = op_stuff})
216   = (tyvars, sc_theta, sc_sels, op_stuff)
217
218 classExtraBigSig :: Class -> ([TyVar], [FunDep TyVar], [PredType], [Id], [ClassATItem], [ClassOpItem])
219 classExtraBigSig (Class {classTyVars = tyvars, classFunDeps = fundeps,
220                          classSCTheta = sc_theta, classSCSels = sc_sels,
221                          classATStuff = ats, classOpStuff = op_stuff})
222   = (tyvars, fundeps, sc_theta, sc_sels, ats, op_stuff)
223 \end{code}
224
225
226 %************************************************************************
227 %*                                                                      *
228 \subsection[Class-instances]{Instance declarations for @Class@}
229 %*                                                                      *
230 %************************************************************************
231
232 We compare @Classes@ by their keys (which include @Uniques@).
233
234 \begin{code}
235 instance Eq Class where
236     c1 == c2 = classKey c1 == classKey c2
237     c1 /= c2 = classKey c1 /= classKey c2
238
239 instance Ord Class where
240     c1 <= c2 = classKey c1 <= classKey c2
241     c1 <  c2 = classKey c1 <  classKey c2
242     c1 >= c2 = classKey c1 >= classKey c2
243     c1 >  c2 = classKey c1 >  classKey c2
244     compare c1 c2 = classKey c1 `compare` classKey c2
245 \end{code}
246
247 \begin{code}
248 instance Uniquable Class where
249     getUnique c = classKey c
250
251 instance NamedThing Class where
252     getName clas = className clas
253
254 instance Outputable Class where
255     ppr c = ppr (getName c)
256
257 instance Outputable DefMeth where
258     ppr (DefMeth n)    =  ptext (sLit "Default method") <+> ppr n
259     ppr (GenDefMeth n) =  ptext (sLit "Generic default method") <+> ppr n
260     ppr NoDefMeth      =  empty   -- No default method
261
262 pprFundeps :: Outputable a => [FunDep a] -> SDoc
263 pprFundeps []  = empty
264 pprFundeps fds = hsep (ptext (sLit "|") : punctuate comma (map pprFunDep fds))
265
266 pprFunDep :: Outputable a => FunDep a -> SDoc
267 pprFunDep (us, vs) = hsep [interppSP us, ptext (sLit "->"), interppSP vs]
268
269 instance Data.Data Class where
270     -- don't traverse?
271     toConstr _   = abstractConstr "Class"
272     gunfold _ _  = error "gunfold"
273     dataTypeOf _ = mkNoRepType "Class"
274 \end{code}