2 /* --------------------------------------------------------------------------
3 * Hugs parser (included as part of input.c)
5 * Expect 6 shift/reduce conflicts when passing this grammar through yacc,
6 * but don't worry; they should all be resolved in an appropriate manner.
8 * Hugs 98 is Copyright (c) Mark P Jones, Alastair Reid and the Yale
9 * Haskell Group 1994-99, and is distributed as Open Source software
10 * under the Artistic License; see the file "Artistic" that is included
11 * in the distribution for details.
13 * $RCSfile: parser.y,v $
15 * $Date: 1999/03/09 14:51:09 $
16 * ------------------------------------------------------------------------*/
22 #define defTycon(n,l,lhs,rhs,w) tyconDefn(intOf(l),lhs,rhs,w); sp-=n
23 #define sigdecl(l,vs,t) ap(SIGDECL,triple(l,vs,t))
24 #define fixdecl(l,ops,a,p) ap(FIXDECL,\
25 triple(l,ops,mkInt(mkSyntax(a,intOf(p)))))
26 #define grded(gs) ap(GUARDED,gs)
27 #define bang(t) ap(BANG,t)
28 #define only(t) ap(ONLY,t)
29 #define letrec(bs,e) (nonNull(bs) ? ap(LETREC,pair(bs,e)) : e)
30 #define qualify(ps,t) (nonNull(ps) ? ap(QUAL,pair(ps,t)) : t)
32 #define exportSelf() NIL
34 #define exportSelf() singleton(ap(MODULEENT,mkCon(module(currentModule).text)))
36 #define yyerror(s) /* errors handled elsewhere */
39 static Cell local gcShadow Args((Int,Cell));
40 static Void local syntaxError Args((String));
41 static String local unexpected Args((Void));
42 static Cell local checkPrec Args((Cell));
43 static Cell local buildTuple Args((List));
44 static List local checkContext Args((List));
45 static Cell local checkPred Args((Cell));
46 static Pair local checkDo Args((List));
47 static Cell local checkTyLhs Args((Cell));
49 static Void local noTREX Args((String));
52 /* For the purposes of reasonably portable garbage collection, it is
53 * necessary to simulate the YACC stack on the Hugs stack to keep
54 * track of all intermediate constructs. The lexical analyser
55 * pushes a token onto the stack for each token that is found, with
56 * these elements being removed as reduce actions are performed,
57 * taking account of look-ahead tokens as described by gcShadow()
60 * Of the non-terminals used below, only start, topDecl & begin
61 * do not leave any values on the Hugs stack. The same is true for the
62 * terminals EXPR and SCRIPT. At the end of a successful parse, there
63 * should only be one element left on the stack, containing the result
67 #define gc0(e) gcShadow(0,e)
68 #define gc1(e) gcShadow(1,e)
69 #define gc2(e) gcShadow(2,e)
70 #define gc3(e) gcShadow(3,e)
71 #define gc4(e) gcShadow(4,e)
72 #define gc5(e) gcShadow(5,e)
73 #define gc6(e) gcShadow(6,e)
74 #define gc7(e) gcShadow(7,e)
79 %token CASEXP OF DATA TYPE IF
80 %token THEN ELSE WHERE LET IN
81 %token INFIXN INFIXL INFIXR FOREIGN TNEWTYPE
82 %token DEFAULT DERIVING DO TCLASS TINSTANCE
83 %token REPEAT ALL NUMLIT CHARLIT STRINGLIT
84 %token VAROP VARID CONOP CONID
85 %token QVAROP QVARID QCONOP QCONID
89 %token COCO '=' UPTO '@' '\\'
90 %token '|' '-' FROM ARROW '~'
91 %token '!' IMPLIES '(' ',' ')'
92 %token '[' ';' ']' '`' '.'
93 %token TMODULE IMPORT HIDING QUALIFIED ASMOD
97 /*- Top level script/module structure -------------------------------------*/
99 start : EXPR exp wherePart {inputExpr = letrec($3,$2); sp-=2;}
100 | SCRIPT topModule {valDefns = $2; sp-=1;}
101 | error {syntaxError("input");}
104 /*- Haskell module header/import parsing: -----------------------------------
105 * Syntax for Haskell modules (module headers and imports) is parsed but
106 * most of it is ignored. However, module names in import declarations
107 * are used, of course, if import chasing is turned on.
108 *-------------------------------------------------------------------------*/
110 /* In Haskell 1.2, the default module header was "module Main where"
111 * In 1.3, this changed to "module Main(main) where".
112 * We use the 1.2 header because it breaks much less pre-module code.
114 topModule : startMain begin modBody end {
115 setExportList(singleton(ap(MODULEENT,mkCon(module(currentModule).text))));
118 | TMODULE modname expspec WHERE '{' modBody end
119 {setExportList($3); $$ = gc7($6);}
120 | TMODULE error {syntaxError("module definition");}
122 /* To implement the Haskell module system, we have to keep track of the
123 * current module. We rely on the use of LALR parsing to ensure that this
124 * side effect happens before any declarations within the module.
126 startMain : /* empty */ {startModule(conMain);
129 modname : CONID {startModule($1); $$ = gc1(NIL);}
131 modid : CONID {$$ = $1;}
132 | STRINGLIT { extern String scriptFile;
133 String modName = findPathname(scriptFile,textToStr(textOf($1)));
134 if (modName) { /* fillin pathname if known */
135 $$ = mkStr(findText(modName));
141 modBody : topDecls {$$ = $1;}
142 | impDecls chase {$$ = gc2(NIL);}
143 | impDecls ';' chase topDecls {$$ = gc4($4);}
146 /*- Exports: --------------------------------------------------------------*/
148 expspec : /* empty */ {$$ = gc0(exportSelf());}
149 | '(' ')' {$$ = gc2(NIL);}
150 | '(' exports ')' {$$ = gc3($2);}
151 | '(' exports ',' ')' {$$ = gc4($2);}
153 exports : exports ',' export {$$ = gc3(cons($3,$1));}
154 | export {$$ = gc1(singleton($1));}
156 /* The qcon should be qconid.
157 * Relaxing the rule lets us explicitly export (:) from the Prelude.
159 export : qvar {$$ = $1;}
161 | qconid '(' UPTO ')' {$$ = gc4(pair($1,DOTDOT));}
162 | qconid '(' qnames ')' {$$ = gc4(pair($1,$3));}
163 | TMODULE modid {$$ = gc2(ap(MODULEENT,$2));}
165 qnames : /* empty */ {$$ = gc0(NIL);}
166 | ',' {$$ = gc1(NIL);}
168 | qnames1 ',' {$$ = gc2($1);}
170 qnames1 : qnames1 ',' qname {$$ = gc3(cons($3,$1));}
171 | qname {$$ = gc1(singleton($1));}
173 qname : qvar {$$ = $1;}
177 /*- Import declarations: --------------------------------------------------*/
179 impDecls : impDecls ';' impDecl {imps = cons($3,imps); $$=gc3(NIL);}
180 | impDecl {imps = singleton($1); $$=gc1(NIL);}
182 chase : /* empty */ {if (chase(imps)) {
192 /* Note that qualified import ignores the import list. */
193 impDecl : IMPORT modid impspec {addQualImport($2,$2);
194 addUnqualImport($2,$3);
196 | IMPORT modid ASMOD modid impspec
197 {addQualImport($2,$4);
198 addUnqualImport($2,$5);
200 | IMPORT QUALIFIED modid ASMOD modid impspec
201 {addQualImport($3,$5);
203 | IMPORT QUALIFIED modid impspec
204 {addQualImport($3,$3);
206 | IMPORT error {syntaxError("import declaration");}
208 impspec : /* empty */ {$$ = gc0(DOTDOT);}
209 | HIDING '(' imports ')' {$$ = gc4(ap(HIDDEN,$3));}
210 | '(' imports ')' {$$ = gc3($2);}
212 imports : /* empty */ {$$ = gc0(NIL);}
213 | ',' {$$ = gc1(NIL);}
214 | imports1 {$$ = $1;}
215 | imports1 ',' {$$ = gc2($1);}
217 imports1 : imports1 ',' import {$$ = gc3(cons($3,$1));}
218 | import {$$ = gc1(singleton($1));}
220 import : var {$$ = $1;}
222 | CONID '(' UPTO ')' {$$ = gc4(pair($1,DOTDOT));}
223 | CONID '(' names ')' {$$ = gc4(pair($1,$3));}
225 names : /* empty */ {$$ = gc0(NIL);}
226 | ',' {$$ = gc1(NIL);}
228 | names1 ',' {$$ = gc2($1);}
230 names1 : names1 ',' name {$$ = gc3(cons($3,$1));}
231 | name {$$ = gc1(singleton($1));}
233 name : var {$$ = $1;}
237 /*- Top-level declarations: -----------------------------------------------*/
239 topDecls : /* empty */ {$$ = gc0(NIL);}
240 | ';' {$$ = gc1(NIL);}
241 | topDecls1 {$$ = $1;}
242 | topDecls1 ';' {$$ = gc2($1);}
244 topDecls1 : topDecls1 ';' topDecl {$$ = gc2($1);}
245 | topDecls1 ';' decl {$$ = gc3(cons($3,$1));}
246 | topDecl {$$ = gc0(NIL);}
247 | decl {$$ = gc1(cons($1,NIL));}
250 /*- Type declarations: ----------------------------------------------------*/
252 topDecl : TYPE tyLhs '=' type {defTycon(4,$3,$2,$4,SYNONYM);}
253 | TYPE tyLhs '=' type IN invars
255 ap($4,$6),RESTRICTSYN);}
256 | TYPE error {syntaxError("type definition");}
257 | DATA btype2 '=' constrs deriving
258 {defTycon(5,$3,checkTyLhs($2),
259 ap(rev($4),$5),DATATYPE);}
260 | DATA context IMPLIES tyLhs '=' constrs deriving
262 ap(qualify($2,rev($6)),
264 | DATA btype2 {defTycon(2,$1,checkTyLhs($2),
265 ap(NIL,NIL),DATATYPE);}
266 | DATA context IMPLIES tyLhs {defTycon(4,$1,$4,
269 | DATA error {syntaxError("data definition");}
270 | TNEWTYPE btype2 '=' nconstr deriving
271 {defTycon(5,$3,checkTyLhs($2),
273 | TNEWTYPE context IMPLIES tyLhs '=' nconstr deriving
277 | TNEWTYPE error {syntaxError("newtype definition");}
279 tyLhs : tyLhs varid {$$ = gc2(ap($1,$2));}
281 | error {syntaxError("type defn lhs");}
283 invars : invars ',' invar {$$ = gc3(cons($3,$1));}
284 | invar {$$ = gc1(cons($1,NIL));}
286 invar : var COCO topType {$$ = gc3(sigdecl($2,singleton($1),
290 constrs : constrs '|' pconstr {$$ = gc3(cons($3,$1));}
291 | pconstr {$$ = gc1(cons($1,NIL));}
293 pconstr : ALL varids '.' qconstr {$$ = gc4(ap(POLYTYPE,
297 qconstr : context IMPLIES constr {$$ = gc3(qualify($1,$3));}
300 constr : '!' btype conop bbtype {$$ = gc4(ap(ap($3,bang($2)),$4));}
301 | btype1 conop bbtype {$$ = gc3(ap(ap($2,$1),$3));}
302 | btype2 conop bbtype {$$ = gc3(ap(ap($2,$1),$3));}
303 | bpolyType conop bbtype {$$ = gc3(ap(ap($2,$1),$3));}
307 | con '{' fieldspecs '}' {$$ = gc4(ap(LABC,pair($1,rev($3))));}
308 | con '{' '}' {$$ = gc3(ap(LABC,pair($1,NIL)));}
309 | error {syntaxError("data type definition");}
311 btype3 : btype2 '!' atype {$$ = gc3(ap($1,bang($3)));}
312 | btype3 '!' atype {$$ = gc3(ap($1,bang($3)));}
313 | btype3 atype {$$ = gc2(ap($1,$2));}
315 btype4 : btype2 bpolyType {$$ = gc2(ap($1,$2));}
316 | btype3 bpolyType {$$ = gc2(ap($1,$2));}
317 | btype4 bpolyType {$$ = gc2(ap($1,$2));}
318 | btype4 atype {$$ = gc2(ap($1,$2));}
319 | btype4 '!' atype {$$ = gc3(ap($1,bang($3)));}
321 bbtype : '!' btype {$$ = gc2(bang($2));}
323 | bpolyType {$$ = $1;}
325 nconstr : pconstr {$$ = gc1(singleton($1));}
327 fieldspecs: fieldspecs ',' fieldspec {$$ = gc3(cons($3,$1));}
328 | fieldspec {$$ = gc1(cons($1,NIL));}
330 fieldspec : vars COCO polyType {$$ = gc3(pair(rev($1),$3));}
331 | vars COCO type {$$ = gc3(pair(rev($1),$3));}
332 | vars COCO '!' type {$$ = gc4(pair(rev($1),bang($4)));}
334 deriving : /* empty */ {$$ = gc0(NIL);}
335 | DERIVING qconid {$$ = gc2(singleton($2));}
336 | DERIVING '(' derivs0 ')' {$$ = gc4($3);}
338 derivs0 : /* empty */ {$$ = gc0(NIL);}
339 | derivs {$$ = gc1(rev($1));}
341 derivs : derivs ',' qconid {$$ = gc3(cons($3,$1));}
342 | qconid {$$ = gc1(singleton($1));}
345 /*- Processing definitions of primitives ----------------------------------*/
347 topDecl : FOREIGN IMPORT callconv ext_loc ext_name unsafe_flag var COCO type
348 {foreignImport($1,pair($4,$5),$7,$9); sp-=9;}
349 | FOREIGN EXPORT callconv ext_name qvarid COCO type
350 {foreignExport($1,$4,$5,$7); sp-=7;}
353 callconv : var {$$ = gc1(NIL); /* ignored */ }
355 ext_loc : STRINGLIT {$$ = $1;}
357 ext_name : STRINGLIT {$$ = $1;}
359 unsafe_flag: /* empty */ {$$ = gc0(NIL);}
360 | UNSAFE {$$ = gc1(NIL); /* ignored */ }
364 /*- Class declarations: ---------------------------------------------------*/
366 topDecl : TCLASS crule wherePart {classDefn(intOf($1),$2,$3); sp-=3;}
367 | TINSTANCE irule wherePart {instDefn(intOf($1),$2,$3); sp-=3;}
368 | DEFAULT '(' dtypes ')' {defaultDefn(intOf($1),$3); sp-=4;}
369 | TCLASS error {syntaxError("class declaration");}
370 | TINSTANCE error {syntaxError("instance declaration");}
371 | DEFAULT error {syntaxError("default declaration");}
373 crule : context IMPLIES btype2 {$$ = gc3(pair($1,checkPred($3)));}
374 | btype2 {$$ = gc1(pair(NIL,checkPred($1)));}
376 irule : context IMPLIES btype2 {$$ = gc3(pair($1,checkPred($3)));}
377 | btype2 {$$ = gc1(pair(NIL,checkPred($1)));}
379 dtypes : /* empty */ {$$ = gc0(NIL);}
380 | dtypes1 {$$ = gc1(rev($1));}
382 dtypes1 : dtypes1 ',' type {$$ = gc3(cons($3,$1));}
383 | type {$$ = gc1(cons($1,NIL));}
386 /*- Type expressions: -----------------------------------------------------*/
388 topType : context IMPLIES topType1 {$$ = gc3(qualify($1,$3));}
389 | topType1 {$$ = $1;}
391 topType1 : bpolyType ARROW topType1 {$$ = gc3(fn($1,$3));}
392 | btype1 ARROW topType1 {$$ = gc3(fn($1,$3));}
393 | btype2 ARROW topType1 {$$ = gc3(fn($1,$3));}
396 polyType : ALL varids '.' sigType {$$ = gc4(ap(POLYTYPE,
398 | bpolyType {$$ = $1;}
400 bpolyType : '(' polyType ')' {$$ = gc3($2);}
402 varids : varids ',' varid {$$ = gc3(cons($3,$1));}
403 | varid {$$ = gc1(singleton($1));}
405 sigType : context IMPLIES type {$$ = gc3(qualify($1,$3));}
408 context : '(' ')' {$$ = gc2(NIL);}
409 | btype2 {$$ = gc1(singleton(checkPred($1)));}
410 | '(' btype2 ')' {$$ = gc3(singleton(checkPred($2)));}
411 | '(' btypes2 ')' {$$ = gc3(checkContext(rev($2)));}
413 | lacks {$$ = gc1(singleton($1));}
414 | '(' lacks1 ')' {$$ = gc3(checkContext(rev($2)));}
416 lacks : varid '\\' varid {
418 $$ = gc3(ap(mkExt(textOf($3)),$1));
420 noTREX("a type context");
424 lacks1 : btypes2 ',' lacks {$$ = gc3(cons($3,$1));}
425 | lacks1 ',' btype2 {$$ = gc3(cons($3,$1));}
426 | lacks1 ',' lacks {$$ = gc3(cons($3,$1));}
427 | btype2 ',' lacks {$$ = gc3(cons($3,cons($1,NIL)));}
428 | lacks {$$ = gc1(singleton($1));}
432 type : type1 {$$ = $1;}
435 type1 : btype1 {$$ = $1;}
436 | btype1 ARROW type {$$ = gc3(fn($1,$3));}
437 | btype2 ARROW type {$$ = gc3(fn($1,$3));}
438 | error {syntaxError("type expression");}
440 btype : btype1 {$$ = $1;}
443 btype1 : btype1 atype {$$ = gc2(ap($1,$2));}
446 btype2 : btype2 atype {$$ = gc2(ap($1,$2));}
449 atype : atype1 {$$ = $1;}
452 atype1 : varid {$$ = $1;}
453 | '(' ')' {$$ = gc2(typeUnit);}
454 | '(' ARROW ')' {$$ = gc3(typeArrow);}
455 | '(' type1 ')' {$$ = gc3($2);}
456 | '(' btype2 ')' {$$ = gc3($2);}
457 | '(' tupCommas ')' {$$ = gc3($2);}
458 | '(' btypes2 ')' {$$ = gc3(buildTuple($2));}
459 | '(' typeTuple ')' {$$ = gc3(buildTuple($2));}
463 $$ = gc3(revOnto($2,typeNoRow));
468 | '(' tfields '|' type ')' {$$ = gc5(revOnto($2,$4));}
470 | '[' type ']' {$$ = gc3(ap(typeList,$2));}
471 | '[' ']' {$$ = gc2(typeList);}
472 | '_' {$$ = gc1(inventVar());}
474 btypes2 : btypes2 ',' btype2 {$$ = gc3(cons($3,$1));}
475 | btype2 ',' btype2 {$$ = gc3(cons($3,cons($1,NIL)));}
477 typeTuple : type1 ',' type {$$ = gc3(cons($3,cons($1,NIL)));}
478 | btype2 ',' type1 {$$ = gc3(cons($3,cons($1,NIL)));}
479 | btypes2 ',' type1 {$$ = gc3(cons($3,$1));}
480 | typeTuple ',' type {$$ = gc3(cons($3,$1));}
483 tfields : tfields ',' tfield {$$ = gc3(cons($3,$1));}
484 | tfield {$$ = gc1(singleton($1));}
486 tfield : varid COCO type {$$ = gc3(ap(mkExt(textOf($1)),$3));}
490 /*- Value declarations: ---------------------------------------------------*/
492 gendecl : INFIXN optDigit ops {$$ = gc3(fixdecl($1,$3,NON_ASS,$2));}
493 | INFIXN error {syntaxError("fixity decl");}
494 | INFIXL optDigit ops {$$ = gc3(fixdecl($1,$3,LEFT_ASS,$2));}
495 | INFIXL error {syntaxError("fixity decl");}
496 | INFIXR optDigit ops {$$ = gc3(fixdecl($1,$3,RIGHT_ASS,$2));}
497 | INFIXR error {syntaxError("fixity decl");}
498 | vars COCO topType {$$ = gc3(sigdecl($2,$1,$3));}
499 | vars COCO error {syntaxError("type signature");}
501 optDigit : NUMLIT {$$ = gc1(checkPrec($1));}
502 | /* empty */ {$$ = gc0(mkInt(DEF_PREC));}
504 ops : ops ',' op {$$ = gc3(cons($3,$1));}
505 | op {$$ = gc1(singleton($1));}
507 vars : vars ',' var {$$ = gc3(cons($3,$1));}
508 | var {$$ = gc1(singleton($1));}
510 decls : '{' decls0 end {$$ = gc3($2);}
511 | '{' decls1 end {$$ = gc3($2);}
513 decls0 : /* empty */ {$$ = gc0(NIL);}
514 | decls0 ';' {$$ = gc2($1);}
515 | decls1 ';' {$$ = gc2($1);}
517 decls1 : decls0 decl {$$ = gc2(cons($2,$1));}
519 decl : gendecl {$$ = $1;}
520 | funlhs rhs {$$ = gc2(ap(FUNBIND,pair($1,$2)));}
521 | funlhs COCO type rhs {$$ = gc4(ap(FUNBIND,
524 | pat0 rhs {$$ = gc2(ap(PATBIND,pair($1,$2)));}
526 funlhs : funlhs0 {$$ = $1;}
530 funlhs0 : pat10_vI varop pat0 {$$ = gc3(ap2($2,$1,$3));}
531 | infixPat varop pat0 {$$ = gc3(ap2($2,$1,$3));}
532 | NUMLIT varop pat0 {$$ = gc3(ap2($2,$1,$3));}
533 | var varop_pl pat0 {$$ = gc3(ap2($2,$1,$3));}
534 | var '+' pat0_INT {$$ = gc3(ap2(varPlus,$1,$3));}
536 funlhs1 : '(' funlhs0 ')' apat {$$ = gc4(ap($2,$4));}
537 | '(' funlhs1 ')' apat {$$ = gc4(ap($2,$4));}
538 | '(' npk ')' apat {$$ = gc4(ap($2,$4));}
539 | var apat {$$ = gc2(ap($1,$2));}
540 | funlhs1 apat {$$ = gc2(ap($1,$2));}
542 rhs : rhs1 wherePart {$$ = gc2(letrec($2,$1));}
543 | error {syntaxError("declaration");}
545 rhs1 : '=' exp {$$ = gc2(pair($1,$2));}
546 | gdrhs {$$ = gc1(grded(rev($1)));}
548 gdrhs : gdrhs gddef {$$ = gc2(cons($2,$1));}
549 | gddef {$$ = gc1(singleton($1));}
551 gddef : '|' exp0 '=' exp {$$ = gc4(pair($3,pair($2,$4)));}
553 wherePart : /* empty */ {$$ = gc0(NIL);}
554 | WHERE decls {$$ = gc2($2);}
557 /*- Patterns: -------------------------------------------------------------*/
562 pat_npk : pat0 COCO type {$$ = gc3(ap(ESIGN,pair($1,$3)));}
565 npk : var '+' NUMLIT {$$ = gc3(ap2(varPlus,$1,$3));}
567 pat0 : var {$$ = $1;}
571 pat0_INT : var {$$ = $1;}
574 pat0_vI : pat10_vI {$$ = $1;}
575 | infixPat {$$ = gc1(ap(INFIX,$1));}
577 infixPat : '-' pat10 {$$ = gc2(ap(NEG,only($2)));}
578 | var qconop pat10 {$$ = gc3(ap(ap($2,only($1)),$3));}
579 | var qconop '-' pat10 {$$ = gc4(ap(NEG,ap2($2,only($1),$4)));}
580 | NUMLIT qconop pat10 {$$ = gc3(ap(ap($2,only($1)),$3));}
581 | NUMLIT qconop '-' pat10 {$$ = gc4(ap(NEG,ap2($2,only($1),$4)));}
582 | pat10_vI qconop pat10 {$$ = gc3(ap(ap($2,only($1)),$3));}
583 | pat10_vI qconop '-' pat10 {$$ = gc4(ap(NEG,ap2($2,only($1),$4)));}
584 | infixPat qconop pat10 {$$ = gc3(ap(ap($2,$1),$3));}
585 | infixPat qconop '-' pat10 {$$ = gc4(ap(NEG,ap(ap($2,$1),$4)));}
587 pat10 : fpat {$$ = $1;}
590 pat10_vI : fpat {$$ = $1;}
593 fpat : fpat apat {$$ = gc2(ap($1,$2));}
594 | gcon apat {$$ = gc2(ap($1,$2));}
596 apat : NUMLIT {$$ = $1;}
600 apat_vI : var '@' apat {$$ = gc3(ap(ASPAT,pair($1,$3)));}
602 | qcon '{' patbinds '}' {$$ = gc4(ap(CONFLDS,pair($1,$3)));}
604 | STRINGLIT {$$ = $1;}
605 | '_' {$$ = gc1(WILDCARD);}
606 | '(' pat_npk ')' {$$ = gc3($2);}
607 | '(' npk ')' {$$ = gc3($2);}
608 | '(' pats2 ')' {$$ = gc3(buildTuple($2));}
609 | '[' pats1 ']' {$$ = gc3(ap(FINLIST,rev($2)));}
610 | '~' apat {$$ = gc2(ap(LAZYPAT,$2));}
612 | '(' patfields ')' {
614 $$ = gc3(revOnto($2,nameNoRec));
619 | '(' patfields '|' pat ')' {$$ = gc5(revOnto($2,$4));}
622 pats2 : pats2 ',' pat {$$ = gc3(cons($3,$1));}
623 | pat ',' pat {$$ = gc3(cons($3,singleton($1)));}
625 pats1 : pats1 ',' pat {$$ = gc3(cons($3,$1));}
626 | pat {$$ = gc1(singleton($1));}
628 patbinds : /* empty */ {$$ = gc0(NIL);}
629 | patbinds1 {$$ = gc1(rev($1));}
631 patbinds1 : patbinds1 ',' patbind {$$ = gc3(cons($3,$1));}
632 | patbind {$$ = gc1(singleton($1));}
634 patbind : qvar '=' pat {$$ = gc3(pair($1,$3));}
638 patfields : patfields ',' patfield {$$ = gc3(cons($3,$1));}
639 | patfield {$$ = gc1(singleton($1));}
641 patfield : varid '=' pat {
643 $$ = gc3(ap(mkExt(textOf($1)),$3));
651 /*- Expressions: ----------------------------------------------------------*/
653 exp : exp_err {$$ = $1;}
654 | error {syntaxError("expression");}
656 exp_err : exp0a COCO sigType {$$ = gc3(ap(ESIGN,pair($1,$3)));}
659 exp0 : exp0a {$$ = $1;}
662 exp0a : infixExpa {$$ = gc1(ap(INFIX,$1));}
665 exp0b : infixExpb {$$ = gc1(ap(INFIX,$1));}
668 infixExpa : infixExpa qop '-' exp10a {$$ = gc4(ap(NEG,ap(ap($2,$1),$4)));}
669 | infixExpa qop exp10a {$$ = gc3(ap(ap($2,$1),$3));}
670 | '-' exp10a {$$ = gc2(ap(NEG,only($2)));}
671 | exp10a qop '-' exp10a {$$ = gc4(ap(NEG,
672 ap(ap($2,only($1)),$4)));}
673 | exp10a qop exp10a {$$ = gc3(ap(ap($2,only($1)),$3));}
675 infixExpb : infixExpa qop '-' exp10b {$$ = gc4(ap(NEG,ap(ap($2,$1),$4)));}
676 | infixExpa qop exp10b {$$ = gc3(ap(ap($2,$1),$3));}
677 | '-' exp10b {$$ = gc2(ap(NEG,only($2)));}
678 | exp10a qop '-' exp10b {$$ = gc4(ap(NEG,
679 ap(ap($2,only($1)),$4)));}
680 | exp10a qop exp10b {$$ = gc3(ap(ap($2,only($1)),$3));}
682 exp10a : CASEXP exp OF '{' alts end {$$ = gc6(ap(CASE,pair($2,rev($5))));}
683 | DO '{' stmts end {$$ = gc4(ap(DOCOMP,checkDo($3)));}
686 exp10b : '\\' pats ARROW exp {$$ = gc4(ap(LAMBDA,
689 | LET decls IN exp {$$ = gc4(letrec($2,$4));}
690 | IF exp THEN exp ELSE exp {$$ = gc6(ap(COND,triple($2,$4,$6)));}
692 pats : pats apat {$$ = gc2(cons($2,$1));}
693 | apat {$$ = gc1(cons($1,NIL));}
695 appExp : appExp aexp {$$ = gc2(ap($1,$2));}
698 aexp : qvar {$$ = $1;}
699 | qvar '@' aexp {$$ = gc3(ap(ASPAT,pair($1,$3)));}
700 | '~' aexp {$$ = gc2(ap(LAZYPAT,$2));}
701 | '_' {$$ = gc1(WILDCARD);}
703 | qcon '{' fbinds '}' {$$ = gc4(ap(CONFLDS,pair($1,$3)));}
704 | aexp '{' fbinds '}' {$$ = gc4(ap(UPDFLDS,
705 triple($1,NIL,$3)));}
708 | STRINGLIT {$$ = $1;}
710 | '(' exp ')' {$$ = gc3($2);}
711 | '(' exps2 ')' {$$ = gc3(buildTuple($2));}
715 $$ = gc3(revOnto($2,nameNoRec));
720 | '(' vfields '|' exp ')' {$$ = gc5(revOnto($2,$4));}
721 | RECSELID {$$ = $1;}
723 | '[' list ']' {$$ = gc3($2);}
724 | '(' exp10a qop ')' {$$ = gc4(ap($3,$2));}
725 | '(' qvarop_mi exp0 ')' {$$ = gc4(ap(ap(nameFlip,$2),$3));}
726 | '(' qconop exp0 ')' {$$ = gc4(ap(ap(nameFlip,$2),$3));}
728 exps2 : exps2 ',' exp {$$ = gc3(cons($3,$1));}
729 | exp ',' exp {$$ = gc3(cons($3,cons($1,NIL)));}
732 vfields : vfields ',' vfield {$$ = gc3(cons($3,$1));}
733 | vfield {$$ = gc1(singleton($1));}
735 vfield : varid '=' exp {
737 $$ = gc3(ap(mkExt(textOf($1)),$3));
739 noTREX("an expression");
744 alts : alts1 {$$ = $1;}
745 | alts1 ';' {$$ = gc2($1);}
747 alts1 : alts1 ';' alt {$$ = gc3(cons($3,$1));}
748 | alt {$$ = gc1(cons($1,NIL));}
750 alt : pat altRhs wherePart {$$ = gc3(pair($1,letrec($3,$2)));}
752 altRhs : guardAlts {$$ = gc1(grded(rev($1)));}
753 | ARROW exp {$$ = gc2(pair($1,$2));}
754 | error {syntaxError("case expression");}
756 guardAlts : guardAlts guardAlt {$$ = gc2(cons($2,$1));}
757 | guardAlt {$$ = gc1(cons($1,NIL));}
759 guardAlt : '|' exp0 ARROW exp {$$ = gc4(pair($3,pair($2,$4)));}
761 stmts : stmts1 ';' {$$ = gc2($1);}
764 stmts1 : stmts1 ';' stmt {$$ = gc3(cons($3,$1));}
765 | stmt {$$ = gc1(cons($1,NIL));}
767 stmt : exp_err FROM exp {$$ = gc3(ap(FROMQUAL,pair($1,$3)));}
768 | LET decls {$$ = gc2(ap(QWHERE,$2));}
769 /* | IF exp {$$ = gc2(ap(BOOLQUAL,$2));}*/
770 | exp_err {$$ = gc1(ap(DOQUAL,$1));}
772 fbinds : /* empty */ {$$ = gc0(NIL);}
773 | fbinds1 {$$ = gc1(rev($1));}
775 fbinds1 : fbinds1 ',' fbind {$$ = gc3(cons($3,$1));}
776 | fbind {$$ = gc1(singleton($1));}
778 fbind : var {$$ = $1;}
779 | qvar '=' exp {$$ = gc3(pair($1,$3));}
782 /*- List Expressions: -------------------------------------------------------*/
784 list : exp {$$ = gc1(ap(FINLIST,cons($1,NIL)));}
785 | exps2 {$$ = gc1(ap(FINLIST,rev($1)));}
786 | exp '|' quals {$$ = gc3(ap(COMP,pair($1,rev($3))));}
787 | exp UPTO exp {$$ = gc3(ap(ap(nameFromTo,$1),$3));}
788 | exp ',' exp UPTO {$$ = gc4(ap(ap(nameFromThen,$1),$3));}
789 | exp UPTO {$$ = gc2(ap(nameFrom,$1));}
790 | exp ',' exp UPTO exp {$$ = gc5(ap(ap(ap(nameFromThenTo,
793 quals : quals ',' qual {$$ = gc3(cons($3,$1));}
794 | qual {$$ = gc1(cons($1,NIL));}
796 qual : exp FROM exp {$$ = gc3(ap(FROMQUAL,pair($1,$3)));}
797 | exp {$$ = gc1(ap(BOOLQUAL,$1));}
798 | LET decls {$$ = gc2(ap(QWHERE,$2));}
801 /*- Identifiers and symbols: ----------------------------------------------*/
803 gcon : qcon {$$ = $1;}
804 | '(' ')' {$$ = gc2(nameUnit);}
805 | '[' ']' {$$ = gc2(nameNil);}
806 | '(' tupCommas ')' {$$ = gc3($2);}
808 tupCommas : tupCommas ',' {$$ = gc2(mkTuple(tupleOf($1)+1));}
809 | ',' {$$ = gc1(mkTuple(2));}
811 varid : VARID {$$ = $1;}
812 | HIDING {$$ = gc1(varHiding);}
813 | QUALIFIED {$$ = gc1(varQualified);}
814 | ASMOD {$$ = gc1(varAsMod);}
816 qconid : QCONID {$$ = $1;}
819 var : varid {$$ = $1;}
820 | '(' VAROP ')' {$$ = gc3($2);}
821 | '(' '+' ')' {$$ = gc3(varPlus);}
822 | '(' '-' ')' {$$ = gc3(varMinus);}
823 | '(' '!' ')' {$$ = gc3(varBang);}
824 | '(' '.' ')' {$$ = gc3(varDot);}
826 qvar : QVARID {$$ = $1;}
827 | '(' QVAROP ')' {$$ = gc3($2);}
830 con : CONID {$$ = $1;}
831 | '(' CONOP ')' {$$ = gc3($2);}
833 qcon : QCONID {$$ = $1;}
834 | '(' QCONOP ')' {$$ = gc3($2);}
837 varop : '+' {$$ = gc1(varPlus);}
838 | '-' {$$ = gc1(varMinus);}
839 | varop_mipl {$$ = $1;}
841 varop_mi : '+' {$$ = gc1(varPlus);}
842 | varop_mipl {$$ = $1;}
844 varop_pl : '-' {$$ = gc1(varMinus);}
845 | varop_mipl {$$ = $1;}
847 varop_mipl: VAROP {$$ = $1;}
848 | '`' varid '`' {$$ = gc3($2);}
849 | '!' {$$ = gc1(varBang);}
850 | '.' {$$ = gc1(varDot);}
852 qvarop : '-' {$$ = gc1(varMinus);}
853 | qvarop_mi {$$ = $1;}
855 qvarop_mi : QVAROP {$$ = $1;}
856 | '`' QVARID '`' {$$ = gc3($2);}
857 | varop_mi {$$ = $1;}
860 conop : CONOP {$$ = $1;}
861 | '`' CONID '`' {$$ = gc3($2);}
863 qconop : QCONOP {$$ = $1;}
864 | '`' QCONID '`' {$$ = gc3($2);}
867 op : varop {$$ = $1;}
870 qop : qvarop {$$ = $1;}
874 /*- Stuff from STG hugs ---------------------------------------------------*/
876 qvarid : varid1 {$$ = gc1($1);}
877 | QVARID {$$ = gc1($1);}
879 varid1 : VARID {$$ = gc1($1);}
880 | HIDING {$$ = gc1(varHiding);}
881 | QUALIFIED {$$ = gc1(varQualified);}
882 | ASMOD {$$ = gc1(varAsMod);}
885 /*- Tricks to force insertion of leading and closing braces ---------------*/
887 begin : error {yyerrok; goOffside(startColumn);}
889 /* deal with trailing semicolon */
892 if (canUnOffside()) {
894 /* insert extra token on stack*/
896 pushed(0) = pushed(1);
897 pushed(1) = mkInt(column);
900 syntaxError("definition");
904 /*-------------------------------------------------------------------------*/
908 static Cell local gcShadow(n,e) /* keep parsed fragments on stack */
911 /* If a look ahead token is held then the required stack transformation
914 * x1 | ... | xn | la ===> e | la
917 * Othwerwise, the transformation is:
919 * x1 | ... | xn ===> e
932 static Void local syntaxError(s) /* report on syntax error */
934 ERRMSG(row) "Syntax error in %s (unexpected %s)", s, unexpected()
938 static String local unexpected() { /* find name for unexpected token */
939 static char buffer[100];
940 static char *fmt = "%s \"%s\"";
941 static char *kwd = "keyword";
944 case 0 : return "end of input";
946 #define keyword(kw) sprintf(buffer,fmt,kwd,kw); return buffer;
947 case INFIXL : keyword("infixl");
948 case INFIXR : keyword("infixr");
949 case INFIXN : keyword("infix");
950 case FOREIGN : keyword("foreign");
951 case UNSAFE : keyword("unsafe");
952 case TINSTANCE : keyword("instance");
953 case TCLASS : keyword("class");
954 case CASEXP : keyword("case");
955 case OF : keyword("of");
956 case IF : keyword("if");
957 case THEN : keyword("then");
958 case ELSE : keyword("else");
959 case WHERE : keyword("where");
960 case TYPE : keyword("type");
961 case DATA : keyword("data");
962 case TNEWTYPE : keyword("newtype");
963 case LET : keyword("let");
964 case IN : keyword("in");
965 case DERIVING : keyword("deriving");
966 case DEFAULT : keyword("default");
967 case IMPORT : keyword("import");
968 case TMODULE : keyword("module");
969 case ALL : keyword("forall");
972 case ARROW : return "`->'";
973 case '=' : return "`='";
974 case COCO : return "`::'";
975 case '-' : return "`-'";
976 case '!' : return "`!'";
977 case ',' : return "comma";
978 case '@' : return "`@'";
979 case '(' : return "`('";
980 case ')' : return "`)'";
981 case '{' : return "`{'";
982 case '}' : return "`}'";
983 case '_' : return "`_'";
984 case '|' : return "`|'";
985 case '.' : return "`.'";
986 case ';' : return "`;'";
987 case UPTO : return "`..'";
988 case '[' : return "`['";
989 case ']' : return "`]'";
990 case FROM : return "`<-'";
991 case '\\' : return "backslash (lambda)";
992 case '~' : return "tilde";
993 case '`' : return "backquote";
995 case RECSELID : sprintf(buffer,"selector \"#%s\"",
996 textToStr(extText(snd(yylval))));
1002 case CONID : sprintf(buffer,"symbol \"%s\"",
1003 textToStr(textOf(yylval)));
1008 case QCONID : sprintf(buffer,"symbol \"%s\"",
1009 identToStr(yylval));
1011 case HIDING : return "symbol \"hiding\"";
1012 case QUALIFIED : return "symbol \"qualified\"";
1013 case ASMOD : return "symbol \"as\"";
1014 case NUMLIT : return "numeric literal";
1015 case CHARLIT : return "character literal";
1016 case STRINGLIT : return "string literal";
1017 case IMPLIES : return "`=>'";
1018 default : return "token";
1022 static Cell local checkPrec(p) /* Check for valid precedence value*/
1024 if (!isInt(p) || intOf(p)<MIN_PREC || intOf(p)>MAX_PREC) {
1025 ERRMSG(row) "Precedence value must be an integer in the range [%d..%d]",
1032 static Cell local buildTuple(tup) /* build tuple (x1,...,xn) from */
1033 List tup; { /* list [xn,...,x1] */
1039 x = fst(t); /* / \ / \ */
1040 fst(t) = snd(t); /* xn . . xn */
1041 snd(t) = x; /* . ===> . */
1043 t = fun(x); /* . . */
1045 } while (nonNull(t)); /* x1 NIL (n) x1 */
1046 fst(x) = mkTuple(n);
1050 static List local checkContext(con) /* validate context */
1052 mapOver(checkPred, con);
1056 static Cell local checkPred(c) /* check that type expr is a valid */
1057 Cell c; { /* constraint */
1058 Cell cn = getHead(c);
1060 if (isExt(cn) && argCount==1)
1063 if (!isQCon(cn) || argCount==0)
1064 syntaxError("class expression");
1068 static Pair local checkDo(dqs) /* convert reversed list of dquals */
1069 List dqs; { /* to an (expr,quals) pair */
1070 if (isNull(dqs) || whatIs(hd(dqs))!=DOQUAL) {
1071 ERRMSG(row) "Last generator in do {...} must be an expression"
1074 fst(dqs) = snd(fst(dqs)); /* put expression in fst of pair */
1075 snd(dqs) = rev(snd(dqs)); /* & reversed list of quals in snd */
1079 static Cell local checkTyLhs(c) /* check that lhs is of the form */
1080 Cell c; { /* T a1 ... a */
1082 while (isAp(tlhs) && whatIs(arg(tlhs))==VARIDCELL)
1084 switch (whatIs(tlhs)) {
1085 case CONIDCELL : return c;
1088 ERRMSG(row) "Illegal left hand side in datatype definition"
1091 return 0; /* NOTREACHED */
1095 static Void local noTREX(where)
1097 ERRMSG(row) "Attempt to use TREX records while parsing %s.\n", where ETHEN
1098 ERRTEXT "(TREX is disabled in this build of Hugs)"
1103 /*-------------------------------------------------------------------------*/