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, FiniteMap )
16 import Name ( ExportFlag(..), mkTupNameStr, preludeQual,
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 }
61 INSTANCE { ITinstance }
72 INTEGER { ITinteger $$ }
75 VARSYM { ITvarsym $$ }
76 CONSYM { ITconsym $$ }
77 QVARID { ITqvarid $$ }
78 QCONID { ITqconid $$ }
79 QVARSYM { ITqvarsym $$ }
80 QCONSYM { ITqconsym $$ }
83 iface :: { ParsedIface }
84 iface : INTERFACE CONID INTEGER
85 usages_part versions_part
86 exports_part inst_modules_part
87 fixities_part decls_part instances_part pragmas_part
88 { case $9 of { (tm, vm) ->
89 ParsedIface $2 (panic "merge modules") (fromInteger $3) Nothing{-src version-}
93 $7 -- instance modules
97 $10 -- local instances
100 --------------------------------------------------------------------------
103 usages_part :: { UsagesMap }
104 usages_part : USAGES_PART module_stuff_pairs { bagToFM $2 }
107 versions_part :: { VersionsMap }
108 versions_part : VERSIONS_PART name_version_pairs { bagToFM $2 }
111 module_stuff_pairs :: { Bag (Module, (Version, FiniteMap FAST_STRING Version)) }
112 module_stuff_pairs : module_stuff_pair
114 | module_stuff_pairs module_stuff_pair
117 module_stuff_pair :: { (Module, (Version, FiniteMap FAST_STRING Version)) }
118 module_stuff_pair : CONID INTEGER DCOLON name_version_pairs SEMI
119 { ($1, (fromInteger $2, bagToFM $4)) }
121 name_version_pairs :: { Bag (FAST_STRING, Int) }
122 name_version_pairs : name_version_pair
124 | name_version_pairs name_version_pair
127 name_version_pair :: { (FAST_STRING, Int) }
128 name_version_pair : name INTEGER
129 { ($1, fromInteger $2)
130 --------------------------------------------------------------------------
133 exports_part :: { ExportsMap }
134 exports_part : EXPORTS_PART export_items { bagToFM $2 }
137 export_items :: { Bag (FAST_STRING, (OrigName, ExportFlag)) }
138 export_items : export_item { unitBag $1 }
139 | export_items export_item { $1 `snocBag` $2 }
141 export_item :: { (FAST_STRING, (OrigName, ExportFlag)) }
142 export_item : CONID name maybe_dotdot { ($2, (OrigName $1 $2, $3)) }
144 maybe_dotdot :: { ExportFlag }
145 maybe_dotdot : DOTDOT { ExportAll }
147 --------------------------------------------------------------------------
150 inst_modules_part :: { Bag Module }
151 inst_modules_part : INSTANCE_MODULES_PART mod_list { $2 }
154 mod_list :: { Bag Module }
155 mod_list : CONID { unitBag $1 }
156 | mod_list CONID { $1 `snocBag` $2
157 --------------------------------------------------------------------------
160 fixities_part :: { FixitiesMap }
161 fixities_part : FIXITIES_PART fixes { $2 }
164 fixes :: { FixitiesMap }
165 fixes : fix { case $1 of (k,v) -> unitFM k v }
166 | fixes fix { case $2 of (k,v) -> addToFM $1 k v }
168 fix :: { (FAST_STRING, RdrNameFixityDecl) }
169 fix : INFIXL INTEGER qname SEMI { (de_qual $3, InfixL $3 (fromInteger $2)) }
170 | INFIXR INTEGER qname SEMI { (de_qual $3, InfixR $3 (fromInteger $2)) }
171 | INFIX INTEGER qname SEMI { (de_qual $3, InfixN $3 (fromInteger $2))
172 --------------------------------------------------------------------------
175 decls_part :: { (LocalTyDefsMap, LocalValDefsMap) }
176 decls_part : DECLARATIONS_PART topdecls { $2 }
177 | { (emptyFM, emptyFM) }
179 topdecls :: { (LocalTyDefsMap, LocalValDefsMap) }
180 topdecls : topdecl { $1 }
181 | topdecls topdecl { case $1 of { (ts1, vs1) ->
182 case $2 of { (ts2, vs2) ->
183 (plusFM ts1 ts2, plusFM vs1 vs2)}}
186 topdecl :: { (LocalTyDefsMap, LocalValDefsMap) }
187 topdecl : typed SEMI { ($1, emptyFM) }
191 | decl { case $1 of { (n, Sig qn ty _ loc) ->
192 (emptyFM, unitFM n (ValSig qn loc ty)) }
195 typed :: { LocalTyDefsMap }
196 typed : TYPE simple EQUAL type { mk_type $2 $4 }
198 datad :: { (LocalTyDefsMap, LocalValDefsMap) }
199 datad : DATA simple EQUAL constrs { mk_data [] $2 $4 }
200 | DATA context DARROW simple EQUAL constrs { mk_data $2 $4 $6 }
202 newtd :: { (LocalTyDefsMap, LocalValDefsMap) }
203 newtd : NEWTYPE simple EQUAL constr1 { mk_new [] $2 $4 }
204 | NEWTYPE context DARROW simple EQUAL constr1 { mk_new $2 $4 $6 }
206 classd :: { (LocalTyDefsMap, LocalValDefsMap) }
207 classd : CLASS class cbody { mk_class [] $2 $3 }
208 | CLASS context DARROW class cbody { mk_class $2 $4 $5 }
210 cbody :: { [(FAST_STRING, RdrNameSig)] }
211 cbody : WHERE OCURLY decls CCURLY { $3 }
214 decls :: { [(FAST_STRING, RdrNameSig)] }
215 decls : decl { [$1] }
216 | decls decl { $1 ++ [$2] }
218 decl :: { (FAST_STRING, RdrNameSig) }
219 decl : var DCOLON ctype SEMI { (de_qual $1, Sig $1 $3 noGenPragmas mkIfaceSrcLoc) }
221 context :: { RdrNameContext }
222 context : DOCURLY context_list DCCURLY { reverse $2 }
224 context_list :: { RdrNameContext{-reversed-} }
225 context_list : class { [$1] }
226 | context_list COMMA class { $3 : $1 }
228 class :: { (RdrName, RdrName) }
229 class : gtycon VARID { ($1, Unqual $2) }
231 ctype :: { RdrNamePolyType }
232 ctype : FORALL OBRACK tyvars CBRACK context DARROW type { HsForAllTy (map Unqual $3) $5 $7 }
233 | FORALL OBRACK tyvars CBRACK type { HsForAllTy (map Unqual $3) [] $5 }
234 | context DARROW type {{-ToDo:rm-} HsPreForAllTy $1 $3 }
235 | type {{-ToDo:change-} HsPreForAllTy [] $1 }
237 type :: { RdrNameMonoType }
239 | btype RARROW type { MonoFunTy $1 $3 }
241 types :: { [RdrNameMonoType] }
242 types : type { [$1] }
243 | types COMMA type { $1 ++ [$3] }
245 btype :: { RdrNameMonoType }
246 btype : gtyconapp { case $1 of (tc, tys) -> MonoTyApp tc tys }
247 | ntyconapp { case $1 of { (ty1, tys) ->
252 MonoTyVar tv -> MonoTyApp tv tys;
253 MonoTyApp tc ts -> MonoTyApp tc (ts++tys);
254 MonoFunTy t1 t2 -> MonoTyApp (preludeQual SLIT("->")) (t1:t2:tys);
255 MonoListTy ty -> MonoTyApp (preludeQual SLIT("[]")) (ty:tys);
256 MonoTupleTy ts -> MonoTyApp (preludeQual (mkTupNameStr (length ts)))
258 _ -> pprPanic "test:" (ppr PprDebug $1)
262 ntyconapp :: { (RdrNameMonoType, [RdrNameMonoType]) }
263 ntyconapp : ntycon { ($1, []) }
264 | ntyconapp atype { case $1 of (t1,tys) -> (t1, tys ++ [$2]) }
266 gtyconapp :: { (RdrName, [RdrNameMonoType]) }
267 gtyconapp : gtycon { ($1, []) }
268 | gtyconapp atype { case $1 of (tc,tys) -> (tc, tys ++ [$2]) }
270 atype :: { RdrNameMonoType }
271 atype : gtycon { MonoTyApp $1 [] }
274 atypes :: { [RdrNameMonoType] }
275 atypes : atype { [$1] }
276 | atypes atype { $1 ++ [$2] }
278 ntycon :: { RdrNameMonoType }
279 ntycon : VARID { MonoTyVar (Unqual $1) }
280 | OPAREN type COMMA types CPAREN { MonoTupleTy ($2 : $4) }
281 | OBRACK type CBRACK { MonoListTy $2 }
282 | OPAREN type CPAREN { $2 }
284 gtycon :: { RdrName }
285 gtycon : QCONID { $1 }
286 | OPAREN RARROW CPAREN { preludeQual SLIT("->") }
287 | OBRACK CBRACK { preludeQual SLIT("[]") }
288 | OPAREN CPAREN { preludeQual SLIT("()") }
289 | OPAREN commas CPAREN { preludeQual (mkTupNameStr $2) }
292 commas : COMMA { 2{-1 comma => arity 2-} }
293 | commas COMMA { $1 + 1 }
295 simple :: { (RdrName, [FAST_STRING]) }
296 simple : gtycon { ($1, []) }
297 | gtyconvars { case $1 of (tc,tvs) -> (tc, reverse tvs) }
299 gtyconvars :: { (RdrName, [FAST_STRING] {-reversed-}) }
300 gtyconvars : gtycon VARID { ($1, [$2]) }
301 | gtyconvars VARID { case $1 of (tc,tvs) -> (tc, $2 : tvs) }
303 constrs :: { [(RdrName, RdrNameConDecl)] }
304 constrs : constr { [$1] }
305 | constrs VBAR constr { $1 ++ [$3] }
307 constr :: { (RdrName, RdrNameConDecl) }
309 { case $1 of (con, tys) -> (con, ConDecl con tys mkIfaceSrcLoc) }
310 | QCONSYM { ($1, ConDecl $1 [] mkIfaceSrcLoc) }
311 | QCONSYM batypes { ($1, ConDecl $1 $2 mkIfaceSrcLoc) }
312 | gtycon OCURLY fields CCURLY
313 { ($1, RecConDecl $1 $3 mkIfaceSrcLoc) }
315 btyconapp :: { (RdrName, [RdrNameBangType]) }
316 btyconapp : gtycon { ($1, []) }
317 | btyconapp batype { case $1 of (tc,tys) -> (tc, tys ++ [$2]) }
319 batype :: { RdrNameBangType }
320 batype : atype { Unbanged (HsForAllTy [{-ToDo:tvs-}] [] $1) }
321 | BANG atype { Banged (HsForAllTy [{-ToDo:tvs-}] [] $2) }
323 batypes :: { [RdrNameBangType] }
324 batypes : batype { [$1] }
325 | batypes batype { $1 ++ [$2] }
327 fields :: { [([RdrName], RdrNameBangType)] }
328 fields : field { [$1] }
329 | fields COMMA field { $1 ++ [$3] }
331 field :: { ([RdrName], RdrNameBangType) }
332 field : var DCOLON type { ([$1], Unbanged (HsForAllTy [{-ToDo:tvs-}] [] $3)) }
333 | var DCOLON BANG atype { ([$1], Banged (HsForAllTy [{-ToDo:tvs-}] [] $4)) }
335 constr1 :: { (RdrName, RdrNameMonoType) }
336 constr1 : gtycon atype { ($1, $2) }
343 qname : QVARID { $1 }
348 name :: { FAST_STRING }
352 | BANG { SLIT("!"){-sigh, double-sigh-} }
354 | OBRACK CBRACK { SLIT("[]") }
355 | OPAREN CPAREN { SLIT("()") }
356 | OPAREN commas CPAREN { mkTupNameStr $2 }
358 instances_part :: { Bag RdrIfaceInst }
359 instances_part : INSTANCES_PART instdecls { $2 }
362 instdecls :: { Bag RdrIfaceInst }
363 instdecls : instd { unitBag $1 }
364 | instdecls instd { $1 `snocBag` $2 }
366 instd :: { RdrIfaceInst }
367 instd : INSTANCE FORALL OBRACK tyvars CBRACK context DARROW gtycon restrict_inst SEMI { mk_inst (Just (map Unqual $4)) $6 $8 $9 }
368 | INSTANCE FORALL OBRACK tyvars CBRACK gtycon general_inst SEMI { mk_inst (Just (map Unqual $4)) [] $6 $7 }
369 | INSTANCE context DARROW gtycon restrict_inst SEMI {{-ToDo:rm-} mk_inst Nothing $2 $4 $5 }
370 | INSTANCE gtycon general_inst SEMI {{-ToDo:rm-} mk_inst Nothing [] $2 $3 }
372 restrict_inst :: { RdrNameMonoType }
373 restrict_inst : gtycon { MonoTyApp $1 [] }
374 | OPAREN gtyconvars CPAREN { case $2 of (tc,tvs) -> MonoTyApp tc (map en_mono (reverse tvs)) }
375 | OPAREN VARID COMMA tyvars CPAREN { MonoTupleTy (map en_mono ($2:$4)) }
376 | OBRACK VARID CBRACK { MonoListTy (en_mono $2) }
377 | OPAREN VARID RARROW VARID CPAREN { MonoFunTy (en_mono $2) (en_mono $4) }
379 general_inst :: { RdrNameMonoType }
380 general_inst : gtycon { MonoTyApp $1 [] }
381 | OPAREN gtyconapp CPAREN { case $2 of (tc,tys) -> MonoTyApp tc tys }
382 | OPAREN type COMMA types CPAREN { MonoTupleTy ($2:$4) }
383 | OBRACK type CBRACK { MonoListTy $2 }
384 | OPAREN btype RARROW type CPAREN { MonoFunTy $2 $4 }
386 tyvars :: { [FAST_STRING] }
387 tyvars : VARID { [$1] }
388 | tyvars COMMA VARID { $1 ++ [$3]
389 --------------------------------------------------------------------------
392 pragmas_part :: { LocalPragmasMap }
393 pragmas_part : PRAGMAS_PART