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
|
%
% (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(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(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, lexVarQual, lexTcQual,
dummyRdrVarName, dummyRdrTcName,
isUnqual, isQual,
showRdr, rdrNameOcc, ieOcc,
cmpRdr, prefixRdrName,
mkOpApp
) where
IMP_Ubiq()
import HsSyn
import Lex
import PrelMods ( pRELUDE )
import BasicTypes ( Module(..), NewOrData, IfaceFlavour(..) )
import Name ( ExportFlag(..), pprModule,
OccName(..), pprOccName,
prefixOccName, SYN_IE(NamedThing) )
import Pretty
import Outputable ( PprStyle(..) )
import Util --( cmpPString, panic, thenCmp )
import Outputable
#if __GLASGOW_HASKELL__ >= 202
import CoreSyn ( GenCoreExpr )
import HsPragmas ( GenPragmas, ClassPragmas, DataPragmas, ClassOpPragmas, InstancePragmas )
#endif
\end{code}
\begin{code}
type RdrNameArithSeqInfo = ArithSeqInfo Fake Fake RdrName RdrNamePat
type RdrNameBangType = BangType RdrName
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 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
-- In (All a => a -> a) -> Int, there are no free tyvars
-- We just assume that we quantify over all type variables mentioned in the context.
get (HsPreForAllTy ctxt ty) acc = filter (`notElem` locals) (get ty [])
++ acc
where
locals = foldr (get . snd) [] ctxt
get (HsForAllTy tvs ctxt ty) acc = (filter (`notElem` locals) $
foldr (get . snd) (get ty []) ctxt)
++ acc
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 IfaceFlavour -- HiBootFile for M!.t (interface files only),
-- HiFile for the common M.t
qual (m,n) = Qual m n HiFile
tcQual (m,n) = Qual m (TCOcc n) HiFile
varQual (m,n) = Qual m (VarOcc n) HiFile
lexTcQual (m,n,hif) = Qual m (TCOcc n) hif
lexVarQual (m,n,hif) = Qual m (VarOcc n) hif
-- 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
-- Used for adding a prefix to a RdrName
prefixRdrName :: FAST_STRING -> RdrName -> RdrName
prefixRdrName prefix (Qual m n hif) = Qual m (prefixOccName prefix n) hif
prefixRdrName prefix (Unqual n) = Unqual (prefixOccName prefix n)
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
ieOcc :: RdrNameIE -> OccName
ieOcc ie = rdrNameOcc (ieName ie)
instance Text RdrName where -- debugging
showsPrec _ rn = showString (show (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) = pprQuote sty $ \ sty -> pprOccName sty n
ppr sty (Qual m n _) = pprQuote sty $ \ sty -> hcat [pprModule sty m, char '.', 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 = render (ppr sty rdr)
\end{code}
|