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
|
%
% (c) The AQUA Project, Glasgow University, 1996
%
\section[RdrHsSyn]{Specialisations of the @HsSyn@ syntax for the reader}
(Well, really, for specialisations involving @RdrName@s, even if
they are used somewhat later on in the compiler...)
\begin{code}
#include "HsVersions.h"
module RdrHsSyn (
SYN_IE(RdrNameArithSeqInfo),
SYN_IE(RdrNameBangType),
SYN_IE(RdrNameBind),
SYN_IE(RdrNameClassDecl),
SYN_IE(RdrNameClassOpSig),
SYN_IE(RdrNameConDecl),
SYN_IE(RdrNameContext),
SYN_IE(RdrNameSpecDataSig),
SYN_IE(RdrNameDefaultDecl),
SYN_IE(RdrNameFixityDecl),
SYN_IE(RdrNameGRHS),
SYN_IE(RdrNameGRHSsAndBinds),
SYN_IE(RdrNameHsBinds),
SYN_IE(RdrNameHsDecl),
SYN_IE(RdrNameHsExpr),
SYN_IE(RdrNameHsModule),
SYN_IE(RdrNameIE),
SYN_IE(RdrNameImportDecl),
SYN_IE(RdrNameInstDecl),
SYN_IE(RdrNameMatch),
SYN_IE(RdrNameMonoBinds),
SYN_IE(RdrNamePat),
SYN_IE(RdrNameHsType),
SYN_IE(RdrNameQual),
SYN_IE(RdrNameSig),
SYN_IE(RdrNameSpecInstSig),
SYN_IE(RdrNameStmt),
SYN_IE(RdrNameTyDecl),
SYN_IE(RdrNameClassOpPragmas),
SYN_IE(RdrNameClassPragmas),
SYN_IE(RdrNameDataPragmas),
SYN_IE(RdrNameGenPragmas),
SYN_IE(RdrNameInstancePragmas),
SYN_IE(RdrNameCoreExpr),
extractHsTyVars,
RdrName(..),
qual, varQual, tcQual, varUnqual,
dummyRdrVarName, dummyRdrTcName,
isUnqual, isQual,
showRdr, rdrNameOcc,
cmpRdr,
mkOpApp
) where
IMP_Ubiq()
import HsSyn
import Lex
import PrelMods ( pRELUDE )
import Name ( ExportFlag(..), Module(..), pprModule,
OccName(..), pprOccName )
import Pretty
import PprStyle ( PprStyle(..) )
import Util ( cmpPString, panic, thenCmp )
\end{code}
\begin{code}
type RdrNameArithSeqInfo = ArithSeqInfo Fake Fake RdrName RdrNamePat
type RdrNameBangType = BangType RdrName
type RdrNameBind = Bind Fake Fake RdrName RdrNamePat
type RdrNameClassDecl = ClassDecl Fake Fake RdrName RdrNamePat
type RdrNameClassOpSig = Sig RdrName
type RdrNameConDecl = ConDecl RdrName
type RdrNameContext = Context RdrName
type RdrNameHsDecl = HsDecl Fake Fake RdrName RdrNamePat
type RdrNameSpecDataSig = SpecDataSig RdrName
type RdrNameDefaultDecl = DefaultDecl RdrName
type RdrNameFixityDecl = FixityDecl RdrName
type RdrNameGRHS = GRHS Fake Fake RdrName RdrNamePat
type RdrNameGRHSsAndBinds = GRHSsAndBinds Fake Fake RdrName RdrNamePat
type RdrNameHsBinds = HsBinds Fake Fake RdrName RdrNamePat
type RdrNameHsExpr = HsExpr Fake Fake RdrName RdrNamePat
type RdrNameHsModule = HsModule Fake Fake RdrName RdrNamePat
type RdrNameIE = IE RdrName
type RdrNameImportDecl = ImportDecl RdrName
type RdrNameInstDecl = InstDecl Fake Fake RdrName RdrNamePat
type RdrNameMatch = Match Fake Fake RdrName RdrNamePat
type RdrNameMonoBinds = MonoBinds Fake Fake RdrName RdrNamePat
type RdrNamePat = InPat RdrName
type RdrNameHsType = HsType RdrName
type RdrNameQual = Qualifier Fake Fake RdrName RdrNamePat
type RdrNameSig = Sig RdrName
type RdrNameSpecInstSig = SpecInstSig RdrName
type RdrNameStmt = Stmt Fake Fake RdrName RdrNamePat
type RdrNameTyDecl = TyDecl RdrName
type RdrNameClassOpPragmas = ClassOpPragmas RdrName
type RdrNameClassPragmas = ClassPragmas RdrName
type RdrNameDataPragmas = DataPragmas RdrName
type RdrNameGenPragmas = GenPragmas RdrName
type RdrNameInstancePragmas = InstancePragmas RdrName
type RdrNameCoreExpr = GenCoreExpr RdrName RdrName RdrName RdrName
\end{code}
@extractHsTyVars@ looks just for things that could be type variables.
It's used when making the for-alls explicit.
\begin{code}
extractHsTyVars :: HsType RdrName -> [RdrName]
extractHsTyVars ty
= get ty []
where
get (MonoTyApp ty1 ty2) acc = get ty1 (get ty2 acc)
get (MonoListTy tc ty) acc = get ty acc
get (MonoTupleTy tc tys) acc = foldr get acc tys
get (MonoFunTy ty1 ty2) acc = get ty1 (get ty2 acc)
get (MonoDictTy cls ty) acc = get ty acc
get (MonoTyVar tv) acc = insert tv acc
get (HsPreForAllTy ctxt ty) acc = foldr (get . snd) (get ty acc) ctxt
get (HsForAllTy tvs ctxt ty) acc = filter (`notElem` locals) $
foldr (get . snd) (get ty acc) ctxt
where
locals = map getTyVarName tvs
insert (Qual _ _) acc = acc
insert (Unqual (TCOcc _)) acc = acc
insert other acc | other `elem` acc = acc
| otherwise = other : acc
\end{code}
A useful function for building @OpApps@. The operator is always a variable,
and we don't know the fixity yet.
\begin{code}
mkOpApp e1 op e2 = OpApp e1 (HsVar op) (error "mkOpApp:fixity") e2
\end{code}
%************************************************************************
%* *
\subsection[RdrName]{The @RdrName@ datatype; names read from files}
%* *
%************************************************************************
\begin{code}
data RdrName
= Unqual OccName
| Qual Module OccName
qual (m,n) = Qual m n
tcQual (m,n) = Qual m (TCOcc n)
varQual (m,n) = Qual m (VarOcc n)
-- This guy is used by the reader when HsSyn has a slot for
-- an implicit name that's going to be filled in by
-- the renamer. We can't just put "error..." because
-- we sometimes want to print out stuff after reading but
-- before renaming
dummyRdrVarName = Unqual (VarOcc SLIT("V-DUMMY"))
dummyRdrTcName = Unqual (VarOcc SLIT("TC-DUMMY"))
varUnqual n = Unqual (VarOcc n)
isUnqual (Unqual _) = True
isUnqual (Qual _ _) = False
isQual (Unqual _) = False
isQual (Qual _ _) = True
cmpRdr (Unqual n1) (Unqual n2) = n1 `cmp` n2
cmpRdr (Unqual n1) (Qual m2 n2) = LT_
cmpRdr (Qual m1 n1) (Unqual n2) = GT_
cmpRdr (Qual m1 n1) (Qual m2 n2) = (n1 `cmp` n2) `thenCmp` (_CMP_STRING_ m1 m2)
-- always compare module-names *second*
rdrNameOcc :: RdrName -> OccName
rdrNameOcc (Unqual occ) = occ
rdrNameOcc (Qual _ occ) = occ
instance Text RdrName where -- debugging
showsPrec _ rn = showString (ppShow 80 (ppr PprDebug rn))
instance Eq RdrName where
a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True }
instance Ord RdrName where
a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False }
a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False }
a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True }
a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True }
instance Ord3 RdrName where
cmp = cmpRdr
instance Outputable RdrName where
ppr sty (Unqual n) = pprOccName sty n
ppr sty (Qual m n) = ppBesides [pprModule sty m, ppStr ".", pprOccName sty n]
instance NamedThing RdrName where -- Just so that pretty-printing of expressions works
getOccName = rdrNameOcc
getName = panic "no getName for RdrNames"
showRdr sty rdr = ppShow 100 (ppr sty rdr)
\end{code}
|
