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/04/27 10:06:58 $
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)
31 #define exportSelf() singleton(ap(MODULEENT,mkCon(module(currentModule).text)))
32 #define yyerror(s) /* errors handled elsewhere */
35 static Cell local gcShadow Args((Int,Cell));
36 static Void local syntaxError Args((String));
37 static String local unexpected Args((Void));
38 static Cell local checkPrec Args((Cell));
39 static Cell local buildTuple Args((List));
40 static List local checkContext Args((List));
41 static Cell local checkPred Args((Cell));
42 static Pair local checkDo Args((List));
43 static Cell local checkTyLhs Args((Cell));
45 static Void local noTREX Args((String));
48 /* For the purposes of reasonably portable garbage collection, it is
49 * necessary to simulate the YACC stack on the Hugs stack to keep
50 * track of all intermediate constructs. The lexical analyser
51 * pushes a token onto the stack for each token that is found, with
52 * these elements being removed as reduce actions are performed,
53 * taking account of look-ahead tokens as described by gcShadow()
56 * Of the non-terminals used below, only start, topDecl & begin
57 * do not leave any values on the Hugs stack. The same is true for the
58 * terminals EXPR and SCRIPT. At the end of a successful parse, there
59 * should only be one element left on the stack, containing the result
63 #define gc0(e) gcShadow(0,e)
64 #define gc1(e) gcShadow(1,e)
65 #define gc2(e) gcShadow(2,e)
66 #define gc3(e) gcShadow(3,e)
67 #define gc4(e) gcShadow(4,e)
68 #define gc5(e) gcShadow(5,e)
69 #define gc6(e) gcShadow(6,e)
70 #define gc7(e) gcShadow(7,e)
75 %token CASEXP OF DATA TYPE IF
76 %token THEN ELSE WHERE LET IN
77 %token INFIXN INFIXL INFIXR FOREIGN TNEWTYPE
78 %token DEFAULT DERIVING DO TCLASS TINSTANCE
79 %token REPEAT ALL NUMLIT CHARLIT STRINGLIT
80 %token VAROP VARID CONOP CONID
81 %token QVAROP QVARID QCONOP QCONID
85 %token COCO '=' UPTO '@' '\\'
86 %token '|' '-' FROM ARROW '~'
87 %token '!' IMPLIES '(' ',' ')'
88 %token '[' ';' ']' '`' '.'
89 %token TMODULE IMPORT HIDING QUALIFIED ASMOD
93 /*- Top level script/module structure -------------------------------------*/
95 start : EXPR exp wherePart {inputExpr = letrec($3,$2); sp-=2;}
96 | SCRIPT topModule {valDefns = $2; sp-=1;}
97 | error {syntaxError("input");}
100 /*- Haskell module header/import parsing: -----------------------------------
101 * Syntax for Haskell modules (module headers and imports) is parsed but
102 * most of it is ignored. However, module names in import declarations
103 * are used, of course, if import chasing is turned on.
104 *-------------------------------------------------------------------------*/
106 /* In Haskell 1.2, the default module header was "module Main where"
107 * In 1.3, this changed to "module Main(main) where".
108 * We use the 1.2 header because it breaks much less pre-module code.
110 topModule : startMain begin modBody end {
111 setExportList(singleton(ap(MODULEENT,mkCon(module(currentModule).text))));
114 | TMODULE modname expspec WHERE '{' modBody end
115 {setExportList($3); $$ = gc7($6);}
116 | TMODULE error {syntaxError("module definition");}
118 /* To implement the Haskell module system, we have to keep track of the
119 * current module. We rely on the use of LALR parsing to ensure that this
120 * side effect happens before any declarations within the module.
122 startMain : /* empty */ {startModule(conMain);
125 modname : CONID {startModule($1); $$ = gc1(NIL);}
127 modid : CONID {$$ = $1;}
128 | STRINGLIT { extern String scriptFile;
129 String modName = findPathname(scriptFile,textToStr(textOf($1)));
130 if (modName) { /* fillin pathname if known */
131 $$ = mkStr(findText(modName));
137 modBody : topDecls {$$ = $1;}
138 | impDecls chase {$$ = gc2(NIL);}
139 | impDecls ';' chase topDecls {$$ = gc4($4);}
142 /*- Exports: --------------------------------------------------------------*/
144 expspec : /* empty */ {$$ = gc0(exportSelf());}
145 | '(' ')' {$$ = gc2(NIL);}
146 | '(' exports ')' {$$ = gc3($2);}
147 | '(' exports ',' ')' {$$ = gc4($2);}
149 exports : exports ',' export {$$ = gc3(cons($3,$1));}
150 | export {$$ = gc1(singleton($1));}
152 /* The qcon should be qconid.
153 * Relaxing the rule lets us explicitly export (:) from the Prelude.
155 export : qvar {$$ = $1;}
157 | qconid '(' UPTO ')' {$$ = gc4(pair($1,DOTDOT));}
158 | qconid '(' qnames ')' {$$ = gc4(pair($1,$3));}
159 | TMODULE modid {$$ = gc2(ap(MODULEENT,$2));}
161 qnames : /* empty */ {$$ = gc0(NIL);}
162 | ',' {$$ = gc1(NIL);}
164 | qnames1 ',' {$$ = gc2($1);}
166 qnames1 : qnames1 ',' qname {$$ = gc3(cons($3,$1));}
167 | qname {$$ = gc1(singleton($1));}
169 qname : qvar {$$ = $1;}
173 /*- Import declarations: --------------------------------------------------*/
175 impDecls : impDecls ';' impDecl {imps = cons($3,imps); $$=gc3(NIL);}
176 | impDecl {imps = singleton($1); $$=gc1(NIL);}
178 chase : /* empty */ {if (chase(imps)) {
188 /* Note that qualified import ignores the import list. */
189 impDecl : IMPORT modid impspec {addQualImport($2,$2);
190 addUnqualImport($2,$3);
192 | IMPORT modid ASMOD modid impspec
193 {addQualImport($2,$4);
194 addUnqualImport($2,$5);
196 | IMPORT QUALIFIED modid ASMOD modid impspec
197 {addQualImport($3,$5);
199 | IMPORT QUALIFIED modid impspec
200 {addQualImport($3,$3);
202 | IMPORT error {syntaxError("import declaration");}
204 impspec : /* empty */ {$$ = gc0(DOTDOT);}
205 | HIDING '(' imports ')' {$$ = gc4(ap(HIDDEN,$3));}
206 | '(' imports ')' {$$ = gc3($2);}
208 imports : /* empty */ {$$ = gc0(NIL);}
209 | ',' {$$ = gc1(NIL);}
210 | imports1 {$$ = $1;}
211 | imports1 ',' {$$ = gc2($1);}
213 imports1 : imports1 ',' import {$$ = gc3(cons($3,$1));}
214 | import {$$ = gc1(singleton($1));}
216 import : var {$$ = $1;}
218 | CONID '(' UPTO ')' {$$ = gc4(pair($1,DOTDOT));}
219 | CONID '(' names ')' {$$ = gc4(pair($1,$3));}
221 names : /* empty */ {$$ = gc0(NIL);}
222 | ',' {$$ = gc1(NIL);}
224 | names1 ',' {$$ = gc2($1);}
226 names1 : names1 ',' name {$$ = gc3(cons($3,$1));}
227 | name {$$ = gc1(singleton($1));}
229 name : var {$$ = $1;}
233 /*- Top-level declarations: -----------------------------------------------*/
235 topDecls : /* empty */ {$$ = gc0(NIL);}
236 | ';' {$$ = gc1(NIL);}
237 | topDecls1 {$$ = $1;}
238 | topDecls1 ';' {$$ = gc2($1);}
240 topDecls1 : topDecls1 ';' topDecl {$$ = gc2($1);}
241 | topDecls1 ';' decl {$$ = gc3(cons($3,$1));}
242 | topDecl {$$ = gc0(NIL);}
243 | decl {$$ = gc1(cons($1,NIL));}
246 /*- Type declarations: ----------------------------------------------------*/
248 topDecl : TYPE tyLhs '=' type {defTycon(4,$3,$2,$4,SYNONYM);}
249 | TYPE tyLhs '=' type IN invars
251 ap($4,$6),RESTRICTSYN);}
252 | TYPE error {syntaxError("type definition");}
253 | DATA btype2 '=' constrs deriving
254 {defTycon(5,$3,checkTyLhs($2),
255 ap(rev($4),$5),DATATYPE);}
256 | DATA context IMPLIES tyLhs '=' constrs deriving
258 ap(qualify($2,rev($6)),
260 | DATA btype2 {defTycon(2,$1,checkTyLhs($2),
261 ap(NIL,NIL),DATATYPE);}
262 | DATA context IMPLIES tyLhs {defTycon(4,$1,$4,
265 | DATA error {syntaxError("data definition");}
266 | TNEWTYPE btype2 '=' nconstr deriving
267 {defTycon(5,$3,checkTyLhs($2),
269 | TNEWTYPE context IMPLIES tyLhs '=' nconstr deriving
273 | TNEWTYPE error {syntaxError("newtype definition");}
275 tyLhs : tyLhs varid {$$ = gc2(ap($1,$2));}
277 | error {syntaxError("type defn lhs");}
279 invars : invars ',' invar {$$ = gc3(cons($3,$1));}
280 | invar {$$ = gc1(cons($1,NIL));}
282 invar : var COCO topType {$$ = gc3(sigdecl($2,singleton($1),
286 constrs : constrs '|' pconstr {$$ = gc3(cons($3,$1));}
287 | pconstr {$$ = gc1(cons($1,NIL));}
289 pconstr : ALL varids '.' qconstr {$$ = gc4(ap(POLYTYPE,
293 qconstr : context IMPLIES constr {$$ = gc3(qualify($1,$3));}
296 constr : '!' btype conop bbtype {$$ = gc4(ap(ap($3,bang($2)),$4));}
297 | btype1 conop bbtype {$$ = gc3(ap(ap($2,$1),$3));}
298 | btype2 conop bbtype {$$ = gc3(ap(ap($2,$1),$3));}
299 | bpolyType conop bbtype {$$ = gc3(ap(ap($2,$1),$3));}
303 | con '{' fieldspecs '}' {$$ = gc4(ap(LABC,pair($1,rev($3))));}
304 | con '{' '}' {$$ = gc3(ap(LABC,pair($1,NIL)));}
305 | error {syntaxError("data type definition");}
307 btype3 : btype2 '!' atype {$$ = gc3(ap($1,bang($3)));}
308 | btype3 '!' atype {$$ = gc3(ap($1,bang($3)));}
309 | btype3 atype {$$ = gc2(ap($1,$2));}
311 btype4 : btype2 bpolyType {$$ = gc2(ap($1,$2));}
312 | btype3 bpolyType {$$ = gc2(ap($1,$2));}
313 | btype4 bpolyType {$$ = gc2(ap($1,$2));}
314 | btype4 atype {$$ = gc2(ap($1,$2));}
315 | btype4 '!' atype {$$ = gc3(ap($1,bang($3)));}
317 bbtype : '!' btype {$$ = gc2(bang($2));}
319 | bpolyType {$$ = $1;}
321 nconstr : pconstr {$$ = gc1(singleton($1));}
323 fieldspecs: fieldspecs ',' fieldspec {$$ = gc3(cons($3,$1));}
324 | fieldspec {$$ = gc1(cons($1,NIL));}
326 fieldspec : vars COCO polyType {$$ = gc3(pair(rev($1),$3));}
327 | vars COCO type {$$ = gc3(pair(rev($1),$3));}
328 | vars COCO '!' type {$$ = gc4(pair(rev($1),bang($4)));}
330 deriving : /* empty */ {$$ = gc0(NIL);}
331 | DERIVING qconid {$$ = gc2(singleton($2));}
332 | DERIVING '(' derivs0 ')' {$$ = gc4($3);}
334 derivs0 : /* empty */ {$$ = gc0(NIL);}
335 | derivs {$$ = gc1(rev($1));}
337 derivs : derivs ',' qconid {$$ = gc3(cons($3,$1));}
338 | qconid {$$ = gc1(singleton($1));}
341 /*- Processing definitions of primitives ----------------------------------*/
343 topDecl : FOREIGN IMPORT callconv ext_loc ext_name unsafe_flag var COCO type
344 {foreignImport($1,pair($4,$5),$7,$9); sp-=9;}
345 | FOREIGN EXPORT callconv ext_name qvarid COCO type
346 {foreignExport($1,$4,$5,$7); sp-=7;}
349 callconv : var {$$ = gc1(NIL); /* ignored */ }
351 ext_loc : STRINGLIT {$$ = $1;}
353 ext_name : STRINGLIT {$$ = $1;}
355 unsafe_flag: /* empty */ {$$ = gc0(NIL);}
356 | UNSAFE {$$ = gc1(NIL); /* ignored */ }
360 /*- Class declarations: ---------------------------------------------------*/
362 topDecl : TCLASS crule wherePart {classDefn(intOf($1),$2,$3); sp-=3;}
363 | TINSTANCE irule wherePart {instDefn(intOf($1),$2,$3); sp-=3;}
364 | DEFAULT '(' dtypes ')' {defaultDefn(intOf($1),$3); sp-=4;}
365 | TCLASS error {syntaxError("class declaration");}
366 | TINSTANCE error {syntaxError("instance declaration");}
367 | DEFAULT error {syntaxError("default declaration");}
369 crule : context IMPLIES btype2 {$$ = gc3(pair($1,checkPred($3)));}
370 | btype2 {$$ = gc1(pair(NIL,checkPred($1)));}
372 irule : context IMPLIES btype2 {$$ = gc3(pair($1,checkPred($3)));}
373 | btype2 {$$ = gc1(pair(NIL,checkPred($1)));}
375 dtypes : /* empty */ {$$ = gc0(NIL);}
376 | dtypes1 {$$ = gc1(rev($1));}
378 dtypes1 : dtypes1 ',' type {$$ = gc3(cons($3,$1));}
379 | type {$$ = gc1(cons($1,NIL));}
382 /*- Type expressions: -----------------------------------------------------*/
384 topType : context IMPLIES topType1 {$$ = gc3(qualify($1,$3));}
385 | topType1 {$$ = $1;}
387 topType1 : bpolyType ARROW topType1 {$$ = gc3(fn($1,$3));}
388 | btype1 ARROW topType1 {$$ = gc3(fn($1,$3));}
389 | btype2 ARROW topType1 {$$ = gc3(fn($1,$3));}
392 polyType : ALL varids '.' sigType {$$ = gc4(ap(POLYTYPE,
394 | bpolyType {$$ = $1;}
396 bpolyType : '(' polyType ')' {$$ = gc3($2);}
398 varids : varids ',' varid {$$ = gc3(cons($3,$1));}
399 | varid {$$ = gc1(singleton($1));}
401 sigType : context IMPLIES type {$$ = gc3(qualify($1,$3));}
404 context : '(' ')' {$$ = gc2(NIL);}
405 | btype2 {$$ = gc1(singleton(checkPred($1)));}
406 | '(' btype2 ')' {$$ = gc3(singleton(checkPred($2)));}
407 | '(' btypes2 ')' {$$ = gc3(checkContext(rev($2)));}
409 | lacks {$$ = gc1(singleton($1));}
410 | '(' lacks1 ')' {$$ = gc3(checkContext(rev($2)));}
412 lacks : varid '\\' varid {
414 $$ = gc3(ap(mkExt(textOf($3)),$1));
416 noTREX("a type context");
420 lacks1 : btypes2 ',' lacks {$$ = gc3(cons($3,$1));}
421 | lacks1 ',' btype2 {$$ = gc3(cons($3,$1));}
422 | lacks1 ',' lacks {$$ = gc3(cons($3,$1));}
423 | btype2 ',' lacks {$$ = gc3(cons($3,cons($1,NIL)));}
424 | lacks {$$ = gc1(singleton($1));}
428 type : type1 {$$ = $1;}
431 type1 : btype1 {$$ = $1;}
432 | btype1 ARROW type {$$ = gc3(fn($1,$3));}
433 | btype2 ARROW type {$$ = gc3(fn($1,$3));}
434 | error {syntaxError("type expression");}
436 btype : btype1 {$$ = $1;}
439 btype1 : btype1 atype {$$ = gc2(ap($1,$2));}
442 btype2 : btype2 atype {$$ = gc2(ap($1,$2));}
445 atype : atype1 {$$ = $1;}
448 atype1 : varid {$$ = $1;}
449 | '(' ')' {$$ = gc2(typeUnit);}
450 | '(' ARROW ')' {$$ = gc3(typeArrow);}
451 | '(' type1 ')' {$$ = gc3($2);}
452 | '(' btype2 ')' {$$ = gc3($2);}
453 | '(' tupCommas ')' {$$ = gc3($2);}
454 | '(' btypes2 ')' {$$ = gc3(buildTuple($2));}
455 | '(' typeTuple ')' {$$ = gc3(buildTuple($2));}
459 $$ = gc3(revOnto($2,typeNoRow));
464 | '(' tfields '|' type ')' {$$ = gc5(revOnto($2,$4));}
466 | '[' type ']' {$$ = gc3(ap(typeList,$2));}
467 | '[' ']' {$$ = gc2(typeList);}
468 | '_' {$$ = gc1(inventVar());}
470 btypes2 : btypes2 ',' btype2 {$$ = gc3(cons($3,$1));}
471 | btype2 ',' btype2 {$$ = gc3(cons($3,cons($1,NIL)));}
473 typeTuple : type1 ',' type {$$ = gc3(cons($3,cons($1,NIL)));}
474 | btype2 ',' type1 {$$ = gc3(cons($3,cons($1,NIL)));}
475 | btypes2 ',' type1 {$$ = gc3(cons($3,$1));}
476 | typeTuple ',' type {$$ = gc3(cons($3,$1));}
479 tfields : tfields ',' tfield {$$ = gc3(cons($3,$1));}
480 | tfield {$$ = gc1(singleton($1));}
482 tfield : varid COCO type {$$ = gc3(ap(mkExt(textOf($1)),$3));}
486 /*- Value declarations: ---------------------------------------------------*/
488 gendecl : INFIXN optDigit ops {$$ = gc3(fixdecl($1,$3,NON_ASS,$2));}
489 | INFIXN error {syntaxError("fixity decl");}
490 | INFIXL optDigit ops {$$ = gc3(fixdecl($1,$3,LEFT_ASS,$2));}
491 | INFIXL error {syntaxError("fixity decl");}
492 | INFIXR optDigit ops {$$ = gc3(fixdecl($1,$3,RIGHT_ASS,$2));}
493 | INFIXR error {syntaxError("fixity decl");}
494 | vars COCO topType {$$ = gc3(sigdecl($2,$1,$3));}
495 | vars COCO error {syntaxError("type signature");}
497 optDigit : NUMLIT {$$ = gc1(checkPrec($1));}
498 | /* empty */ {$$ = gc0(mkInt(DEF_PREC));}
500 ops : ops ',' op {$$ = gc3(cons($3,$1));}
501 | op {$$ = gc1(singleton($1));}
503 vars : vars ',' var {$$ = gc3(cons($3,$1));}
504 | var {$$ = gc1(singleton($1));}
506 decls : '{' decls0 end {$$ = gc3($2);}
507 | '{' decls1 end {$$ = gc3($2);}
509 decls0 : /* empty */ {$$ = gc0(NIL);}
510 | decls0 ';' {$$ = gc2($1);}
511 | decls1 ';' {$$ = gc2($1);}
513 decls1 : decls0 decl {$$ = gc2(cons($2,$1));}
515 decl : gendecl {$$ = $1;}
516 | funlhs rhs {$$ = gc2(ap(FUNBIND,pair($1,$2)));}
517 | funlhs COCO type rhs {$$ = gc4(ap(FUNBIND,
520 | pat0 rhs {$$ = gc2(ap(PATBIND,pair($1,$2)));}
522 funlhs : funlhs0 {$$ = $1;}
526 funlhs0 : pat10_vI varop pat0 {$$ = gc3(ap2($2,$1,$3));}
527 | infixPat varop pat0 {$$ = gc3(ap2($2,$1,$3));}
528 | NUMLIT varop pat0 {$$ = gc3(ap2($2,$1,$3));}
529 | var varop_pl pat0 {$$ = gc3(ap2($2,$1,$3));}
530 | var '+' pat0_INT {$$ = gc3(ap2(varPlus,$1,$3));}
532 funlhs1 : '(' funlhs0 ')' apat {$$ = gc4(ap($2,$4));}
533 | '(' funlhs1 ')' apat {$$ = gc4(ap($2,$4));}
534 | '(' npk ')' apat {$$ = gc4(ap($2,$4));}
535 | var apat {$$ = gc2(ap($1,$2));}
536 | funlhs1 apat {$$ = gc2(ap($1,$2));}
538 rhs : rhs1 wherePart {$$ = gc2(letrec($2,$1));}
539 | error {syntaxError("declaration");}
541 rhs1 : '=' exp {$$ = gc2(pair($1,$2));}
542 | gdrhs {$$ = gc1(grded(rev($1)));}
544 gdrhs : gdrhs gddef {$$ = gc2(cons($2,$1));}
545 | gddef {$$ = gc1(singleton($1));}
547 gddef : '|' exp0 '=' exp {$$ = gc4(pair($3,pair($2,$4)));}
549 wherePart : /* empty */ {$$ = gc0(NIL);}
550 | WHERE decls {$$ = gc2($2);}
553 /*- Patterns: -------------------------------------------------------------*/
558 pat_npk : pat0 COCO type {$$ = gc3(ap(ESIGN,pair($1,$3)));}
561 npk : var '+' NUMLIT {$$ = gc3(ap2(varPlus,$1,$3));}
563 pat0 : var {$$ = $1;}
567 pat0_INT : var {$$ = $1;}
570 pat0_vI : pat10_vI {$$ = $1;}
571 | infixPat {$$ = gc1(ap(INFIX,$1));}
573 infixPat : '-' pat10 {$$ = gc2(ap(NEG,only($2)));}
574 | var qconop pat10 {$$ = gc3(ap(ap($2,only($1)),$3));}
575 | var qconop '-' pat10 {$$ = gc4(ap(NEG,ap2($2,only($1),$4)));}
576 | NUMLIT qconop pat10 {$$ = gc3(ap(ap($2,only($1)),$3));}
577 | NUMLIT qconop '-' pat10 {$$ = gc4(ap(NEG,ap2($2,only($1),$4)));}
578 | pat10_vI qconop pat10 {$$ = gc3(ap(ap($2,only($1)),$3));}
579 | pat10_vI qconop '-' pat10 {$$ = gc4(ap(NEG,ap2($2,only($1),$4)));}
580 | infixPat qconop pat10 {$$ = gc3(ap(ap($2,$1),$3));}
581 | infixPat qconop '-' pat10 {$$ = gc4(ap(NEG,ap(ap($2,$1),$4)));}
583 pat10 : fpat {$$ = $1;}
586 pat10_vI : fpat {$$ = $1;}
589 fpat : fpat apat {$$ = gc2(ap($1,$2));}
590 | gcon apat {$$ = gc2(ap($1,$2));}
592 apat : NUMLIT {$$ = $1;}
596 apat_vI : var '@' apat {$$ = gc3(ap(ASPAT,pair($1,$3)));}
598 | qcon '{' patbinds '}' {$$ = gc4(ap(CONFLDS,pair($1,$3)));}
600 | STRINGLIT {$$ = $1;}
601 | '_' {$$ = gc1(WILDCARD);}
602 | '(' pat_npk ')' {$$ = gc3($2);}
603 | '(' npk ')' {$$ = gc3($2);}
604 | '(' pats2 ')' {$$ = gc3(buildTuple($2));}
605 | '[' pats1 ']' {$$ = gc3(ap(FINLIST,rev($2)));}
606 | '~' apat {$$ = gc2(ap(LAZYPAT,$2));}
608 | '(' patfields ')' {
610 $$ = gc3(revOnto($2,nameNoRec));
615 | '(' patfields '|' pat ')' {$$ = gc5(revOnto($2,$4));}
618 pats2 : pats2 ',' pat {$$ = gc3(cons($3,$1));}
619 | pat ',' pat {$$ = gc3(cons($3,singleton($1)));}
621 pats1 : pats1 ',' pat {$$ = gc3(cons($3,$1));}
622 | pat {$$ = gc1(singleton($1));}
624 patbinds : /* empty */ {$$ = gc0(NIL);}
625 | patbinds1 {$$ = gc1(rev($1));}
627 patbinds1 : patbinds1 ',' patbind {$$ = gc3(cons($3,$1));}
628 | patbind {$$ = gc1(singleton($1));}
630 patbind : qvar '=' pat {$$ = gc3(pair($1,$3));}
634 patfields : patfields ',' patfield {$$ = gc3(cons($3,$1));}
635 | patfield {$$ = gc1(singleton($1));}
637 patfield : varid '=' pat {
639 $$ = gc3(ap(mkExt(textOf($1)),$3));
647 /*- Expressions: ----------------------------------------------------------*/
649 exp : exp_err {$$ = $1;}
650 | error {syntaxError("expression");}
652 exp_err : exp0a COCO sigType {$$ = gc3(ap(ESIGN,pair($1,$3)));}
655 exp0 : exp0a {$$ = $1;}
658 exp0a : infixExpa {$$ = gc1(ap(INFIX,$1));}
661 exp0b : infixExpb {$$ = gc1(ap(INFIX,$1));}
664 infixExpa : infixExpa qop '-' exp10a {$$ = gc4(ap(NEG,ap(ap($2,$1),$4)));}
665 | infixExpa qop exp10a {$$ = gc3(ap(ap($2,$1),$3));}
666 | '-' exp10a {$$ = gc2(ap(NEG,only($2)));}
667 | exp10a qop '-' exp10a {$$ = gc4(ap(NEG,
668 ap(ap($2,only($1)),$4)));}
669 | exp10a qop exp10a {$$ = gc3(ap(ap($2,only($1)),$3));}
671 infixExpb : infixExpa qop '-' exp10b {$$ = gc4(ap(NEG,ap(ap($2,$1),$4)));}
672 | infixExpa qop exp10b {$$ = gc3(ap(ap($2,$1),$3));}
673 | '-' exp10b {$$ = gc2(ap(NEG,only($2)));}
674 | exp10a qop '-' exp10b {$$ = gc4(ap(NEG,
675 ap(ap($2,only($1)),$4)));}
676 | exp10a qop exp10b {$$ = gc3(ap(ap($2,only($1)),$3));}
678 exp10a : CASEXP exp OF '{' alts end {$$ = gc6(ap(CASE,pair($2,rev($5))));}
679 | DO '{' stmts end {$$ = gc4(ap(DOCOMP,checkDo($3)));}
682 exp10b : '\\' pats ARROW exp {$$ = gc4(ap(LAMBDA,
685 | LET decls IN exp {$$ = gc4(letrec($2,$4));}
686 | IF exp THEN exp ELSE exp {$$ = gc6(ap(COND,triple($2,$4,$6)));}
688 pats : pats apat {$$ = gc2(cons($2,$1));}
689 | apat {$$ = gc1(cons($1,NIL));}
691 appExp : appExp aexp {$$ = gc2(ap($1,$2));}
694 aexp : qvar {$$ = $1;}
695 | qvar '@' aexp {$$ = gc3(ap(ASPAT,pair($1,$3)));}
696 | '~' aexp {$$ = gc2(ap(LAZYPAT,$2));}
697 | '_' {$$ = gc1(WILDCARD);}
699 | qcon '{' fbinds '}' {$$ = gc4(ap(CONFLDS,pair($1,$3)));}
700 | aexp '{' fbinds '}' {$$ = gc4(ap(UPDFLDS,
701 triple($1,NIL,$3)));}
704 | STRINGLIT {$$ = $1;}
706 | '(' exp ')' {$$ = gc3($2);}
707 | '(' exps2 ')' {$$ = gc3(buildTuple($2));}
711 $$ = gc3(revOnto($2,nameNoRec));
716 | '(' vfields '|' exp ')' {$$ = gc5(revOnto($2,$4));}
717 | RECSELID {$$ = $1;}
719 | '[' list ']' {$$ = gc3($2);}
720 | '(' exp10a qop ')' {$$ = gc4(ap($3,$2));}
721 | '(' qvarop_mi exp0 ')' {$$ = gc4(ap(ap(nameFlip,$2),$3));}
722 | '(' qconop exp0 ')' {$$ = gc4(ap(ap(nameFlip,$2),$3));}
724 exps2 : exps2 ',' exp {$$ = gc3(cons($3,$1));}
725 | exp ',' exp {$$ = gc3(cons($3,cons($1,NIL)));}
728 vfields : vfields ',' vfield {$$ = gc3(cons($3,$1));}
729 | vfield {$$ = gc1(singleton($1));}
731 vfield : varid '=' exp {
733 $$ = gc3(ap(mkExt(textOf($1)),$3));
735 noTREX("an expression");
740 alts : alts1 {$$ = $1;}
741 | alts1 ';' {$$ = gc2($1);}
743 alts1 : alts1 ';' alt {$$ = gc3(cons($3,$1));}
744 | alt {$$ = gc1(cons($1,NIL));}
746 alt : pat altRhs wherePart {$$ = gc3(pair($1,letrec($3,$2)));}
748 altRhs : guardAlts {$$ = gc1(grded(rev($1)));}
749 | ARROW exp {$$ = gc2(pair($1,$2));}
750 | error {syntaxError("case expression");}
752 guardAlts : guardAlts guardAlt {$$ = gc2(cons($2,$1));}
753 | guardAlt {$$ = gc1(cons($1,NIL));}
755 guardAlt : '|' exp0 ARROW exp {$$ = gc4(pair($3,pair($2,$4)));}
757 stmts : stmts1 ';' {$$ = gc2($1);}
760 stmts1 : stmts1 ';' stmt {$$ = gc3(cons($3,$1));}
761 | stmt {$$ = gc1(cons($1,NIL));}
763 stmt : exp_err FROM exp {$$ = gc3(ap(FROMQUAL,pair($1,$3)));}
764 | LET decls {$$ = gc2(ap(QWHERE,$2));}
765 /* | IF exp {$$ = gc2(ap(BOOLQUAL,$2));}*/
766 | exp_err {$$ = gc1(ap(DOQUAL,$1));}
768 fbinds : /* empty */ {$$ = gc0(NIL);}
769 | fbinds1 {$$ = gc1(rev($1));}
771 fbinds1 : fbinds1 ',' fbind {$$ = gc3(cons($3,$1));}
772 | fbind {$$ = gc1(singleton($1));}
774 fbind : var {$$ = $1;}
775 | qvar '=' exp {$$ = gc3(pair($1,$3));}
778 /*- List Expressions: -------------------------------------------------------*/
780 list : exp {$$ = gc1(ap(FINLIST,cons($1,NIL)));}
781 | exps2 {$$ = gc1(ap(FINLIST,rev($1)));}
782 | exp '|' quals {$$ = gc3(ap(COMP,pair($1,rev($3))));}
783 | exp UPTO exp {$$ = gc3(ap(ap(nameFromTo,$1),$3));}
784 | exp ',' exp UPTO {$$ = gc4(ap(ap(nameFromThen,$1),$3));}
785 | exp UPTO {$$ = gc2(ap(nameFrom,$1));}
786 | exp ',' exp UPTO exp {$$ = gc5(ap(ap(ap(nameFromThenTo,
789 quals : quals ',' qual {$$ = gc3(cons($3,$1));}
790 | qual {$$ = gc1(cons($1,NIL));}
792 qual : exp FROM exp {$$ = gc3(ap(FROMQUAL,pair($1,$3)));}
793 | exp {$$ = gc1(ap(BOOLQUAL,$1));}
794 | LET decls {$$ = gc2(ap(QWHERE,$2));}
797 /*- Identifiers and symbols: ----------------------------------------------*/
799 gcon : qcon {$$ = $1;}
800 | '(' ')' {$$ = gc2(nameUnit);}
801 | '[' ']' {$$ = gc2(nameNil);}
802 | '(' tupCommas ')' {$$ = gc3($2);}
804 tupCommas : tupCommas ',' {$$ = gc2(mkTuple(tupleOf($1)+1));}
805 | ',' {$$ = gc1(mkTuple(2));}
807 varid : VARID {$$ = $1;}
808 | HIDING {$$ = gc1(varHiding);}
809 | QUALIFIED {$$ = gc1(varQualified);}
810 | ASMOD {$$ = gc1(varAsMod);}
812 qconid : QCONID {$$ = $1;}
815 var : varid {$$ = $1;}
816 | '(' VAROP ')' {$$ = gc3($2);}
817 | '(' '+' ')' {$$ = gc3(varPlus);}
818 | '(' '-' ')' {$$ = gc3(varMinus);}
819 | '(' '!' ')' {$$ = gc3(varBang);}
820 | '(' '.' ')' {$$ = gc3(varDot);}
822 qvar : QVARID {$$ = $1;}
823 | '(' QVAROP ')' {$$ = gc3($2);}
826 con : CONID {$$ = $1;}
827 | '(' CONOP ')' {$$ = gc3($2);}
829 qcon : QCONID {$$ = $1;}
830 | '(' QCONOP ')' {$$ = gc3($2);}
833 varop : '+' {$$ = gc1(varPlus);}
834 | '-' {$$ = gc1(varMinus);}
835 | varop_mipl {$$ = $1;}
837 varop_mi : '+' {$$ = gc1(varPlus);}
838 | varop_mipl {$$ = $1;}
840 varop_pl : '-' {$$ = gc1(varMinus);}
841 | varop_mipl {$$ = $1;}
843 varop_mipl: VAROP {$$ = $1;}
844 | '`' varid '`' {$$ = gc3($2);}
845 | '!' {$$ = gc1(varBang);}
846 | '.' {$$ = gc1(varDot);}
848 qvarop : '-' {$$ = gc1(varMinus);}
849 | qvarop_mi {$$ = $1;}
851 qvarop_mi : QVAROP {$$ = $1;}
852 | '`' QVARID '`' {$$ = gc3($2);}
853 | varop_mi {$$ = $1;}
856 conop : CONOP {$$ = $1;}
857 | '`' CONID '`' {$$ = gc3($2);}
859 qconop : QCONOP {$$ = $1;}
860 | '`' QCONID '`' {$$ = gc3($2);}
863 op : varop {$$ = $1;}
866 qop : qvarop {$$ = $1;}
870 /*- Stuff from STG hugs ---------------------------------------------------*/
872 qvarid : varid1 {$$ = gc1($1);}
873 | QVARID {$$ = gc1($1);}
875 varid1 : VARID {$$ = gc1($1);}
876 | HIDING {$$ = gc1(varHiding);}
877 | QUALIFIED {$$ = gc1(varQualified);}
878 | ASMOD {$$ = gc1(varAsMod);}
881 /*- Tricks to force insertion of leading and closing braces ---------------*/
883 begin : error {yyerrok; goOffside(startColumn);}
885 /* deal with trailing semicolon */
888 if (canUnOffside()) {
890 /* insert extra token on stack*/
892 pushed(0) = pushed(1);
893 pushed(1) = mkInt(column);
896 syntaxError("definition");
900 /*-------------------------------------------------------------------------*/
904 static Cell local gcShadow(n,e) /* keep parsed fragments on stack */
907 /* If a look ahead token is held then the required stack transformation
910 * x1 | ... | xn | la ===> e | la
913 * Othwerwise, the transformation is:
915 * x1 | ... | xn ===> e
928 static Void local syntaxError(s) /* report on syntax error */
930 ERRMSG(row) "Syntax error in %s (unexpected %s)", s, unexpected()
934 static String local unexpected() { /* find name for unexpected token */
935 static char buffer[100];
936 static char *fmt = "%s \"%s\"";
937 static char *kwd = "keyword";
940 case 0 : return "end of input";
942 #define keyword(kw) sprintf(buffer,fmt,kwd,kw); return buffer;
943 case INFIXL : keyword("infixl");
944 case INFIXR : keyword("infixr");
945 case INFIXN : keyword("infix");
946 case FOREIGN : keyword("foreign");
947 case UNSAFE : keyword("unsafe");
948 case TINSTANCE : keyword("instance");
949 case TCLASS : keyword("class");
950 case CASEXP : keyword("case");
951 case OF : keyword("of");
952 case IF : keyword("if");
953 case THEN : keyword("then");
954 case ELSE : keyword("else");
955 case WHERE : keyword("where");
956 case TYPE : keyword("type");
957 case DATA : keyword("data");
958 case TNEWTYPE : keyword("newtype");
959 case LET : keyword("let");
960 case IN : keyword("in");
961 case DERIVING : keyword("deriving");
962 case DEFAULT : keyword("default");
963 case IMPORT : keyword("import");
964 case TMODULE : keyword("module");
965 case ALL : keyword("forall");
968 case ARROW : return "`->'";
969 case '=' : return "`='";
970 case COCO : return "`::'";
971 case '-' : return "`-'";
972 case '!' : return "`!'";
973 case ',' : return "comma";
974 case '@' : return "`@'";
975 case '(' : return "`('";
976 case ')' : return "`)'";
977 case '{' : return "`{'";
978 case '}' : return "`}'";
979 case '_' : return "`_'";
980 case '|' : return "`|'";
981 case '.' : return "`.'";
982 case ';' : return "`;'";
983 case UPTO : return "`..'";
984 case '[' : return "`['";
985 case ']' : return "`]'";
986 case FROM : return "`<-'";
987 case '\\' : return "backslash (lambda)";
988 case '~' : return "tilde";
989 case '`' : return "backquote";
991 case RECSELID : sprintf(buffer,"selector \"#%s\"",
992 textToStr(extText(snd(yylval))));
998 case CONID : sprintf(buffer,"symbol \"%s\"",
999 textToStr(textOf(yylval)));
1004 case QCONID : sprintf(buffer,"symbol \"%s\"",
1005 identToStr(yylval));
1007 case HIDING : return "symbol \"hiding\"";
1008 case QUALIFIED : return "symbol \"qualified\"";
1009 case ASMOD : return "symbol \"as\"";
1010 case NUMLIT : return "numeric literal";
1011 case CHARLIT : return "character literal";
1012 case STRINGLIT : return "string literal";
1013 case IMPLIES : return "`=>'";
1014 default : return "token";
1018 static Cell local checkPrec(p) /* Check for valid precedence value*/
1020 if (!isInt(p) || intOf(p)<MIN_PREC || intOf(p)>MAX_PREC) {
1021 ERRMSG(row) "Precedence value must be an integer in the range [%d..%d]",
1028 static Cell local buildTuple(tup) /* build tuple (x1,...,xn) from */
1029 List tup; { /* list [xn,...,x1] */
1035 x = fst(t); /* / \ / \ */
1036 fst(t) = snd(t); /* xn . . xn */
1037 snd(t) = x; /* . ===> . */
1039 t = fun(x); /* . . */
1041 } while (nonNull(t)); /* x1 NIL (n) x1 */
1042 fst(x) = mkTuple(n);
1046 static List local checkContext(con) /* validate context */
1048 mapOver(checkPred, con);
1052 static Cell local checkPred(c) /* check that type expr is a valid */
1053 Cell c; { /* constraint */
1054 Cell cn = getHead(c);
1056 if (isExt(cn) && argCount==1)
1059 if (!isQCon(cn) || argCount==0)
1060 syntaxError("class expression");
1064 static Pair local checkDo(dqs) /* convert reversed list of dquals */
1065 List dqs; { /* to an (expr,quals) pair */
1066 if (isNull(dqs) || whatIs(hd(dqs))!=DOQUAL) {
1067 ERRMSG(row) "Last generator in do {...} must be an expression"
1070 fst(dqs) = snd(fst(dqs)); /* put expression in fst of pair */
1071 snd(dqs) = rev(snd(dqs)); /* & reversed list of quals in snd */
1075 static Cell local checkTyLhs(c) /* check that lhs is of the form */
1076 Cell c; { /* T a1 ... a */
1078 while (isAp(tlhs) && whatIs(arg(tlhs))==VARIDCELL)
1080 switch (whatIs(tlhs)) {
1081 case CONIDCELL : return c;
1084 ERRMSG(row) "Illegal left hand side in datatype definition"
1087 return 0; /* NOTREACHED */
1091 static Void local noTREX(where)
1093 ERRMSG(row) "Attempt to use TREX records while parsing %s.\n", where ETHEN
1094 ERRTEXT "(TREX is disabled in this build of Hugs)"
1099 /*-------------------------------------------------------------------------*/