2 #include "HsVersions.h"
4 module ParseIface ( parseIface ) where
10 import HsSyn -- quite a bit of stuff
11 import RdrHsSyn -- oodles of synonyms
12 import HsPragmas ( noGenPragmas )
14 import Bag ( emptyBag, unitBag, snocBag )
15 import FiniteMap ( emptyFM, unitFM, addToFM, plusFM, bagToFM )
16 import Name ( ExportFlag(..), mkTupNameStr,
17 RdrName(..){-instance Outputable:ToDo:rm-}
19 import Outputable -- ToDo:rm
20 import PprStyle ( PprStyle(..) ) -- ToDo: rm debugging
21 import SrcLoc ( mkIfaceSrcLoc )
22 import Util ( panic, pprPanic{-ToDo:rm-} )
24 -----------------------------------------------------------------
26 parseIface = parseIToks . lexIface
28 -----------------------------------------------------------------
32 %tokentype { IfaceToken }
33 %monad { IfM }{ thenIf }{ returnIf }
36 INTERFACE { ITinterface }
37 USAGES_PART { ITusages }
38 VERSIONS_PART { ITversions }
39 EXPORTS_PART { ITexports }
40 INSTANCE_MODULES_PART { ITinstance_modules }
41 INSTANCES_PART { ITinstances }
42 FIXITIES_PART { ITfixities }
43 DECLARATIONS_PART { ITdeclarations }
44 PRAGMAS_PART { ITpragmas }
60 INSTANCE { ITinstance }
70 INTEGER { ITinteger $$ }
73 VARSYM { ITvarsym $$ }
74 CONSYM { ITconsym $$ }
75 QVARID { ITqvarid $$ }
76 QCONID { ITqconid $$ }
77 QVARSYM { ITqvarsym $$ }
78 QCONSYM { ITqconsym $$ }
81 iface :: { ParsedIface }
82 iface : INTERFACE CONID INTEGER
83 usages_part versions_part
84 exports_part inst_modules_part
85 fixities_part decls_part instances_part pragmas_part
86 { case $9 of { (tm, vm) ->
87 ParsedIface $2 (panic "merge modules") (fromInteger $3) Nothing{-src version-}
91 $7 -- instance modules
95 $10 -- local instances
98 --------------------------------------------------------------------------
101 usages_part :: { UsagesMap }
102 usages_part : USAGES_PART module_stuff_pairs { bagToFM $2 }
105 versions_part :: { VersionsMap }
106 versions_part : VERSIONS_PART name_version_pairs { bagToFM $2 }
109 module_stuff_pairs :: { Bag (Module, (Version, FiniteMap FAST_STRING Version)) }
110 module_stuff_pairs : module_stuff_pair
112 | module_stuff_pairs module_stuff_pair
115 module_stuff_pair :: { (Module, (Version, FiniteMap FAST_STRING Version)) }
116 module_stuff_pair : CONID INTEGER DCOLON name_version_pairs SEMI
117 { ($1, (fromInteger $2, bagToFM $4)) }
119 name_version_pairs :: { Bag (FAST_STRING, Int) }
120 name_version_pairs : name_version_pair
122 | name_version_pairs COMMA name_version_pair
125 name_version_pair :: { (FAST_STRING, Int) }
126 name_version_pair : iname INTEGER
127 { ($1, fromInteger $2)
128 --------------------------------------------------------------------------
131 exports_part :: { ExportsMap }
132 exports_part : EXPORTS_PART export_items { bagToFM $2 }
134 export_items :: { Bag (FAST_STRING, (RdrName, ExportFlag)) }
135 export_items : export_item { unitBag $1 }
136 | export_items export_item { $1 `snocBag` $2 }
138 export_item :: { (FAST_STRING, (RdrName, ExportFlag)) }
139 export_item : qiname maybe_dotdot { (de_qual $1, ($1, $2)) }
141 maybe_dotdot :: { ExportFlag }
142 maybe_dotdot : DOTDOT { ExportAll }
144 --------------------------------------------------------------------------
147 inst_modules_part :: { Bag Module }
148 inst_modules_part : INSTANCE_MODULES_PART mod_list { $2 }
151 mod_list :: { Bag Module }
152 mod_list : CONID { unitBag $1 }
153 | mod_list CONID { $1 `snocBag` $2
154 --------------------------------------------------------------------------
157 fixities_part :: { FixitiesMap }
158 fixities_part : FIXITIES_PART fixes { $2 }
161 fixes :: { FixitiesMap }
162 fixes : fix { case $1 of (k,v) -> unitFM k v }
163 | fixes fix { case $2 of (k,v) -> addToFM $1 k v }
165 fix :: { (FAST_STRING, RdrNameFixityDecl) }
166 fix : INFIXL INTEGER qop SEMI { (de_qual $3, InfixL $3 (fromInteger $2)) }
167 | INFIXR INTEGER qop SEMI { (de_qual $3, InfixR $3 (fromInteger $2)) }
168 | INFIX INTEGER qop SEMI { (de_qual $3, InfixN $3 (fromInteger $2))
169 --------------------------------------------------------------------------
172 decls_part :: { (LocalTyDefsMap, LocalValDefsMap) }
173 decls_part : DECLARATIONS_PART topdecls { $2 }
175 topdecls :: { (LocalTyDefsMap, LocalValDefsMap) }
176 topdecls : topdecl { $1 }
177 | topdecls topdecl { case $1 of { (ts1, vs1) ->
178 case $2 of { (ts2, vs2) ->
179 (plusFM ts1 ts2, plusFM vs1 vs2)}}
182 topdecl :: { (LocalTyDefsMap, LocalValDefsMap) }
183 topdecl : typed SEMI { ($1, emptyFM) }
187 | decl { case $1 of { (n, Sig qn ty _ loc) ->
188 (emptyFM, unitFM n (ValSig qn loc ty)) }
191 typed :: { LocalTyDefsMap }
192 typed : TYPE simple EQUAL type { mk_type $2 $4 }
194 datad :: { (LocalTyDefsMap, LocalValDefsMap) }
195 datad : DATA simple EQUAL constrs { mk_data [] $2 $4 }
196 | DATA context DARROW simple EQUAL constrs { mk_data $2 $4 $6 }
198 newtd :: { (LocalTyDefsMap, LocalValDefsMap) }
199 newtd : NEWTYPE simple EQUAL constr1 { mk_new [] $2 $4 }
200 | NEWTYPE context DARROW simple EQUAL constr1 { mk_new $2 $4 $6 }
202 classd :: { (LocalTyDefsMap, LocalValDefsMap) }
203 classd : CLASS class cbody { mk_class [] $2 $3 }
204 | CLASS context DARROW class cbody { mk_class $2 $4 $5 }
206 cbody :: { [(FAST_STRING, RdrNameSig)] }
207 cbody : WHERE OCURLY decls CCURLY { $3 }
210 decls :: { [(FAST_STRING, RdrNameSig)] }
211 decls : decl { [$1] }
212 | decls decl { $1 ++ [$2] }
214 decl :: { (FAST_STRING, RdrNameSig) }
215 decl : var DCOLON ctype SEMI { (de_qual $1, Sig $1 $3 noGenPragmas mkIfaceSrcLoc) }
217 context :: { RdrNameContext }
218 context : OPAREN context_list CPAREN { reverse $2 }
221 context_list :: { RdrNameContext{-reversed-} }
222 context_list : class { [$1] }
223 | context_list COMMA class { $3 : $1 }
225 class :: { (RdrName, RdrName) }
226 class : gtycon VARID { ($1, Unqual $2) }
228 ctype :: { RdrNamePolyType }
229 ctype : type DARROW type { HsPreForAllTy (type2context $1) $3 }
230 | type { HsPreForAllTy [] $1 }
232 type :: { RdrNameMonoType }
234 | btype RARROW type { MonoFunTy $1 $3 }
236 types :: { [RdrNameMonoType] }
237 types : type { [$1] }
238 | types COMMA type { $1 ++ [$3] }
240 btype :: { RdrNameMonoType }
241 btype : gtyconapp { case $1 of (tc, tys) -> MonoTyApp tc tys }
242 | ntyconapp { case $1 of { (ty1, tys) ->
247 MonoTyVar tv -> MonoTyApp tv tys;
248 MonoTyApp tc ts -> MonoTyApp tc (ts++tys);
249 MonoFunTy t1 t2 -> MonoTyApp (Unqual SLIT("->")) (t1:t2:tys);
250 MonoListTy ty -> MonoTyApp (Unqual SLIT("[]")) (ty:tys);
251 MonoTupleTy ts -> MonoTyApp (Unqual (mkTupNameStr (length ts)))
253 _ -> pprPanic "test:" (ppr PprDebug $1)
257 ntyconapp :: { (RdrNameMonoType, [RdrNameMonoType]) }
258 ntyconapp : ntycon { ($1, []) }
259 | ntyconapp atype { case $1 of (t1,tys) -> (t1, tys ++ [$2]) }
261 gtyconapp :: { (RdrName, [RdrNameMonoType]) }
262 gtyconapp : gtycon { ($1, []) }
263 | gtyconapp atype { case $1 of (tc,tys) -> (tc, tys ++ [$2]) }
265 atype :: { RdrNameMonoType }
266 atype : gtycon { MonoTyApp $1 [] }
269 atypes :: { [RdrNameMonoType] }
270 atypes : atype { [$1] }
271 | atypes atype { $1 ++ [$2] }
273 ntycon :: { RdrNameMonoType }
274 ntycon : VARID { MonoTyVar (Unqual $1) }
275 | OPAREN type COMMA types CPAREN { MonoTupleTy ($2 : $4) }
276 | OBRACK type CBRACK { MonoListTy $2 }
277 | OPAREN type CPAREN { $2 }
279 gtycon :: { RdrName }
280 gtycon : QCONID { $1 }
281 | CONID { Unqual $1 }
282 | OPAREN RARROW CPAREN { Unqual SLIT("->") }
283 | OBRACK CBRACK { Unqual SLIT("[]") }
284 | OPAREN CPAREN { Unqual SLIT("()") }
285 | OPAREN commas CPAREN { Unqual (mkTupNameStr $2) }
288 commas : COMMA { 2{-1 comma => arity 2-} }
289 | commas COMMA { $1 + 1 }
291 simple :: { (RdrName, [FAST_STRING]) }
292 simple : gtycon { ($1, []) }
293 | gtyconvars { case $1 of (tc,tvs) -> (tc, reverse tvs) }
295 gtyconvars :: { (RdrName, [FAST_STRING] {-reversed-}) }
296 gtyconvars : gtycon VARID { ($1, [$2]) }
297 | gtyconvars VARID { case $1 of (tc,tvs) -> (tc, $2 : tvs) }
299 constrs :: { [(RdrName, RdrNameConDecl)] }
300 constrs : constr { [$1] }
301 | constrs VBAR constr { $1 ++ [$3] }
303 constr :: { (RdrName, RdrNameConDecl) }
305 { case $1 of (con, tys) -> (con, ConDecl con tys mkIfaceSrcLoc) }
306 | OPAREN QCONSYM CPAREN { ($2, ConDecl $2 [] mkIfaceSrcLoc) }
307 | OPAREN QCONSYM CPAREN batypes { ($2, ConDecl $2 $4 mkIfaceSrcLoc) }
308 | OPAREN CONSYM CPAREN { (Unqual $2, ConDecl (Unqual $2) [] mkIfaceSrcLoc) }
309 | OPAREN CONSYM CPAREN batypes { (Unqual $2, ConDecl (Unqual $2) $4 mkIfaceSrcLoc) }
310 | gtycon OCURLY fields CCURLY
311 { ($1, RecConDecl $1 $3 mkIfaceSrcLoc) }
313 btyconapp :: { (RdrName, [RdrNameBangType]) }
314 btyconapp : gtycon { ($1, []) }
315 | btyconapp batype { case $1 of (tc,tys) -> (tc, tys ++ [$2]) }
317 bbtype :: { RdrNameBangType }
318 bbtype : btype { Unbanged (HsPreForAllTy [] $1) }
319 | BANG atype { Banged (HsPreForAllTy [] $2) }
321 batype :: { RdrNameBangType }
322 batype : atype { Unbanged (HsPreForAllTy [] $1) }
323 | BANG atype { Banged (HsPreForAllTy [] $2) }
325 batypes :: { [RdrNameBangType] }
326 batypes : batype { [$1] }
327 | batypes batype { $1 ++ [$2] }
329 fields :: { [([RdrName], RdrNameBangType)] }
330 fields : field { [$1] }
331 | fields COMMA field { $1 ++ [$3] }
333 field :: { ([RdrName], RdrNameBangType) }
334 field : var DCOLON type { ([$1], Unbanged (HsPreForAllTy [] $3)) }
335 | var DCOLON BANG atype { ([$1], Banged (HsPreForAllTy [] $4)) }
337 constr1 :: { (RdrName, RdrNameMonoType) }
338 constr1 : gtycon atype { ($1, $2) }
342 | OPAREN QVARSYM CPAREN { $2 }
343 | VARID { Unqual $1 }
344 | OPAREN VARSYM CPAREN { Unqual $2 }
346 op :: { FAST_STRING }
347 op : BQUOTE VARID BQUOTE { $2 }
348 | BQUOTE CONID BQUOTE { $2 }
353 qop : BQUOTE QVARID BQUOTE { $2 }
354 | BQUOTE QCONID BQUOTE { $2 }
359 iname :: { FAST_STRING }
362 | OPAREN VARSYM CPAREN { $2 }
363 | OPAREN CONSYM CPAREN { $2 }
365 qiname :: { RdrName }
366 qiname : QVARID { $1 }
368 | OPAREN QVARSYM CPAREN { $2 }
369 | OPAREN QCONSYM CPAREN { $2 }
370 | iname { Unqual $1 }
372 instances_part :: { Bag RdrIfaceInst }
373 instances_part : INSTANCES_PART instdecls { $2 }
376 instdecls :: { Bag RdrIfaceInst }
377 instdecls : instd { unitBag $1 }
378 | instdecls instd { $1 `snocBag` $2 }
380 instd :: { RdrIfaceInst }
381 instd : INSTANCE context DARROW gtycon restrict_inst SEMI { mk_inst $2 $4 $5 }
382 | INSTANCE gtycon general_inst SEMI { mk_inst [] $2 $3 }
384 restrict_inst :: { RdrNameMonoType }
385 restrict_inst : gtycon { MonoTyApp $1 [] }
386 | OPAREN gtyconvars CPAREN { case $2 of (tc,tvs) -> MonoTyApp tc (map en_mono tvs) }
387 | OPAREN VARID COMMA tyvar_list CPAREN { MonoTupleTy (map en_mono ($2:$4)) }
388 | OBRACK VARID CBRACK { MonoListTy (en_mono $2) }
389 | OPAREN VARID RARROW VARID CPAREN { MonoFunTy (en_mono $2) (en_mono $4) }
391 general_inst :: { RdrNameMonoType }
392 general_inst : gtycon { MonoTyApp $1 [] }
393 | OPAREN gtyconapp CPAREN { case $2 of (tc,tys) -> MonoTyApp tc tys }
394 | OPAREN type COMMA types CPAREN { MonoTupleTy ($2:$4) }
395 | OBRACK type CBRACK { MonoListTy $2 }
396 | OPAREN btype RARROW type CPAREN { MonoFunTy $2 $4 }
398 tyvar_list :: { [FAST_STRING] }
399 tyvar_list : VARID { [$1] }
400 | tyvar_list COMMA VARID { $1 ++ [$3]
401 --------------------------------------------------------------------------
404 pragmas_part :: { LocalPragmasMap }
405 pragmas_part : PRAGMAS_PART