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
|
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[Class]{The @Class@ datatype}
\begin{code}
module Class (
Class, ClassOpItem, FunDep,
DefMeth (..),
mkClass, classTyVars, classArity,
classKey, className, classSelIds, classTyCon, classMethods,
classBigSig, classExtraBigSig, classTvsFds, classSCTheta
) where
#include "HsVersions.h"
import {-# SOURCE #-} TyCon ( TyCon )
import {-# SOURCE #-} TypeRep ( PredType )
import Var ( Id, TyVar )
import Name ( NamedThing(..), Name )
import BasicTypes ( Arity )
import Unique ( Unique, Uniquable(..) )
import Outputable
\end{code}
%************************************************************************
%* *
\subsection[Class-basic]{@Class@: basic definition}
%* *
%************************************************************************
A @Class@ corresponds to a Greek kappa in the static semantics:
\begin{code}
data Class
= Class {
classKey :: Unique, -- Key for fast comparison
className :: Name,
classTyVars :: [TyVar], -- The class type variables
classFunDeps :: [FunDep TyVar], -- The functional dependencies
classSCTheta :: [PredType], -- Immediate superclasses, and the
classSCSels :: [Id], -- corresponding selector functions to
-- extract them from a dictionary of this
-- class
classOpStuff :: [ClassOpItem], -- Ordered by tag
classTyCon :: TyCon -- The data type constructor for dictionaries
} -- of this class
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 -- A polymorphic default method
| GenDefMeth -- A generic default method
deriving Eq
\end{code}
The @mkClass@ function fills in the indirect superclasses.
\begin{code}
mkClass :: Name -> [TyVar]
-> [([TyVar], [TyVar])]
-> [PredType] -> [Id]
-> [ClassOpItem]
-> TyCon
-> Class
mkClass name tyvars fds super_classes superdict_sels
op_stuff tycon
= Class { classKey = getUnique name,
className = name,
classTyVars = tyvars,
classFunDeps = fds,
classSCTheta = super_classes,
classSCSels = superdict_sels,
classOpStuff = op_stuff,
classTyCon = tycon }
\end{code}
%************************************************************************
%* *
\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
classSelIds :: Class -> [Id]
classSelIds c@(Class {classSCSels = sc_sels})
= sc_sels ++ classMethods c
classMethods :: Class -> [Id]
classMethods (Class {classOpStuff = op_stuff})
= [op_sel | (op_sel, _) <- op_stuff]
classTvsFds c
= (classTyVars c, classFunDeps c)
classBigSig (Class {classTyVars = tyvars, classSCTheta = sc_theta,
classSCSels = sc_sels, classOpStuff = op_stuff})
= (tyvars, sc_theta, sc_sels, op_stuff)
classExtraBigSig (Class {classTyVars = tyvars, classFunDeps = fundeps,
classSCTheta = sc_theta, classSCSels = sc_sels,
classOpStuff = op_stuff})
= (tyvars, fundeps, sc_theta, sc_sels, 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 Show Class where
showsPrec p c = showsPrecSDoc p (ppr c)
instance Outputable DefMeth where
ppr DefMeth = text "{- has default method -}"
ppr GenDefMeth = text "{- has generic method -}"
ppr NoDefMeth = empty -- No default method
\end{code}
|
