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