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