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 * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
9 * Yale Haskell Group, and the Oregon Graduate Institute of Science and
10 * Technology, 1994-1999, All rights reserved. It is distributed as
11 * free software under the license in the file "License", which is
12 * included in the distribution.
14 * $RCSfile: parser.y,v $
16 * $Date: 2000/04/04 17:35:04 $
17 * ------------------------------------------------------------------------*/
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 only(t) ap(ONLY,t)
28 #define letrec(bs,e) (nonNull(bs) ? ap(LETREC,pair(bs,e)) : e)
29 #define qualify(ps,t) (nonNull(ps) ? ap(QUAL,pair(ps,t)) : t)
30 #define yyerror(s) /* errors handled elsewhere */
33 static Cell local gcShadow ( Int,Cell );
34 static Void local syntaxError ( String );
35 static String local unexpected ( Void );
36 static Cell local checkPrec ( Cell );
37 static Void local fixDefn ( Syntax,Cell,Cell,List );
38 static Cell local buildTuple ( List );
39 static List local checkCtxt ( List );
40 static Cell local checkPred ( Cell );
41 static Pair local checkDo ( List );
42 static Cell local checkTyLhs ( Cell );
44 static Void local noTREX ( String );
47 static Void local noIP ( String );
50 /* For the purposes of reasonably portable garbage collection, it is
51 * necessary to simulate the YACC stack on the Hugs stack to keep
52 * track of all intermediate constructs. The lexical analyser
53 * pushes a token onto the stack for each token that is found, with
54 * these elements being removed as reduce actions are performed,
55 * taking account of look-ahead tokens as described by gcShadow()
58 * Of the non-terminals used below, only start, topDecl & begin
59 * do not leave any values on the Hugs stack. The same is true for the
60 * terminals EXPR and SCRIPT. At the end of a successful parse, there
61 * should only be one element left on the stack, containing the result
65 #define gc0(e) gcShadow(0,e)
66 #define gc1(e) gcShadow(1,e)
67 #define gc2(e) gcShadow(2,e)
68 #define gc3(e) gcShadow(3,e)
69 #define gc4(e) gcShadow(4,e)
70 #define gc5(e) gcShadow(5,e)
71 #define gc6(e) gcShadow(6,e)
72 #define gc7(e) gcShadow(7,e)
73 #define gc8(e) gcShadow(8,e)
74 #define gc9(e) gcShadow(9,e)
78 %token EXPR CONTEXT SCRIPT
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
86 %token REPEAT ALL NUMLIT CHARLIT STRINGLIT
87 %token VAROP VARID CONOP CONID
88 %token QVAROP QVARID QCONOP QCONID
90 %token RECSELID IPVARID
92 %token COCO '=' UPTO '@' '\\'
93 %token '|' '-' FROM ARROW '~'
94 %token '!' IMPLIES '(' ',' ')'
95 %token '[' ';' ']' '`' '.'
96 %token TMODULE IMPORT HIDING QUALIFIED ASMOD
97 %token EXPORT UUEXPORT INTERFACE REQUIRES UNSAFE
98 %token INSTIMPORT DYNAMIC CCALL STDKALL
99 %token UTL UTR UUUSAGE
103 /*- Top level script/module structure -------------------------------------*/
105 start : EXPR exp wherePart {inputExpr = letrec($3,$2); sp-=2;}
106 | CONTEXT context {inputContext = $2; sp-=1;}
107 | SCRIPT topModule {drop(); push($2);}
108 | INTERFACE iface {sp-=1;}
109 | error {syntaxError("input");}
113 /*- GHC interface file parsing: -------------------------------------------*/
115 /* Reading in an interface file is surprisingly like reading
116 * a normal Haskell module: we read in a bunch of declarations,
117 * construct symbol table entries, etc. The "only" differences
118 * are that there's no syntactic sugar to deal with and we don't
119 * have to read in expressions.
122 /*- Top-level interface files -----------------------------*/
123 iface : INTERFACE ifCon NUMLIT ifOrphans ifCheckVersion WHERE ifTopDecls
124 {$$ = gc7(ap(I_INTERFACE,
126 | INTERFACE error {syntaxError("interface file");}
129 ifTopDecls: {$$=gc0(NIL);}
130 | ifTopDecl ';' ifTopDecls {$$=gc3(cons($1,$3));}
134 : IMPORT CONID NUMLIT ifOrphans ifIsBoot ifOptCOCO ifVersionList
135 {$$=gc7(ap(I_IMPORT,zpair($2,$7))); }
137 | INSTIMPORT CONID {$$=gc2(ap(I_INSTIMPORT,NIL));}
139 | UUEXPORT CONID ifEntities {$$=gc3(ap(I_EXPORT,zpair($2,$3)));}
141 | NUMLIT INFIXL optDigit ifVarCon
142 {$$=gc4(ap(I_FIXDECL,
143 ztriple($3,mkInt(LEFT_ASS),$4)));}
144 | NUMLIT INFIXR optDigit ifVarCon
145 {$$=gc4(ap(I_FIXDECL,
146 ztriple($3,mkInt(RIGHT_ASS),$4)));}
147 | NUMLIT INFIXN optDigit ifVarCon
148 {$$=gc4(ap(I_FIXDECL,
149 ztriple($3,mkInt(NON_ASS),$4)));}
151 | TINSTANCE ifCtxInst ifInstHdL '=' ifVar
152 {$$=gc5(ap(I_INSTANCE,
153 z5ble($1,$2,$3,$5,NIL)));}
155 | NUMLIT TYPE ifCon ifKindedTyvarL '=' ifType
157 z4ble($2,$3,$4,$6)));}
159 | NUMLIT DATA ifCtxDecl ifConData ifKindedTyvarL ifConstrs
161 z5ble($2,$3,$4,$5,$6)));}
163 | NUMLIT TNEWTYPE ifCtxDecl ifConData ifKindedTyvarL ifNewTypeConstr
164 {$$=gc6(ap(I_NEWTYPE,
165 z5ble($2,$3,$4,$5,$6)));}
167 | NUMLIT TCLASS ifCtxDecl ifCon ifKindedTyvar ifCmeths
170 singleton($5),$6)));}
172 | NUMLIT ifVar COCO ifType
174 ztriple($3,$2,$4)));}
176 | error { syntaxError(
177 "interface declaration"); }
181 /*- Top-level misc interface stuff ------------------------*/
182 ifOrphans : '!' {$$=gc1(NIL);}
184 ifIsBoot : '@' {$$=gc1(NIL);}
187 ifOptCOCO : COCO {$$=gc1(NIL);}
191 : NUMLIT {$$ = gc1(NIL); }
196 /*- Interface variable and constructor ids ----------------*/
197 ifTyvar : VARID {$$ = $1;}
199 ifVar : VARID {$$ = gc1($1);}
201 ifCon : CONID {$$ = gc1($1);}
204 ifVarCon : VARID {$$ = gc1($1);}
205 | CONID {$$ = gc1($1);}
208 ifQCon : CONID {$$ = gc1($1);}
209 | QCONID {$$ = gc1($1);}
211 ifConData : ifCon {$$ = gc1($1);}
212 | '(' ')' {$$ = gc2(typeUnit);}
213 | '[' ']' {$$ = gc2(typeList);}
214 | '(' ARROW ')' {$$ = gc3(typeArrow);}
216 ifTCName : CONID { $$ = gc1($1); }
217 | CONOP { $$ = gc1($1); }
218 | '(' ARROW ')' { $$ = gc3(typeArrow); }
219 | '[' ']' { $$ = gc1(typeList); }
221 ifQTCName : ifTCName { $$ = gc1($1); }
222 | QCONID { $$ = gc1($1); }
223 | QCONOP { $$ = gc1($1); }
227 /*- Interface contexts ------------------------------------*/
228 ifCtxInst /* __forall [a b] => :: [((VarId,Kind))] */
229 : ALL ifForall IMPLIES {$$=gc3($2);}
232 ifInstHd /* { Class aType } :: ((ConId, Type)) */
233 : '{' ifQCon ifAType '}' {$$=gc4(ap(DICTAP,
237 ifInstHdL /* { C a1 } -> { C2 a2 } -> ... -> { Cn an } :: Type */
238 : ifInstHd ARROW ifInstHdL {$$=gc3(ap($1,$3));}
239 | ifInstHd {$$=gc1($1);}
242 ifCtxDecl /* {M.C1 a, C2 b} => :: [(QConId, VarId)] */
243 : ifCtxDeclT IMPLIES { $$ = gc2($1); }
246 ifCtxDeclT /* {M.C1 a, C2 b} :: [(QConId, VarId)] */
248 | '{' ifCtxDeclL '}' { $$ = gc3($2); }
251 ifCtxDeclL /* M.C1 a, C2 b :: [(QConId, VarId)] */
252 : ifCtxDeclLE ',' ifCtxDeclL {$$=gc3(cons($1,$3));}
253 | ifCtxDeclLE {$$=gc1(cons($1,NIL));}
256 ifCtxDeclLE /* M.C1 a :: (QConId,VarId) */
257 : ifQCon ifTyvar {$$=gc2(zpair($1,$2));}
261 /*- Interface data declarations - constructor lists -------*/
262 /* The (Type,VarId,Int) are (field type, name (or NIL), strictness).
263 Strictness is a number: mkInt(0) indicates lazy, mkInt(1)
264 indicates a strict field (!type) as in standard H98, and
265 mkInt(2) indicates unpacked -- a GHC extension.
268 ifConstrs /* = Con1 | ... | ConN :: [((ConId,[((Type,VarId,Int))]))] */
270 | '=' ifConstrL {$$ = gc2($2);}
272 ifConstrL /* [((ConId,[((Type,VarId,Int))]))] */
273 : ifConstr {$$ = gc1(singleton($1));}
274 | ifConstr '|' ifConstrL {$$ = gc3(cons($1,$3));}
276 ifConstr /* ((ConId,[((Type,VarId,Int))])) */
277 : ifConData ifDataAnonFieldL {$$ = gc2(zpair($1,$2));}
278 | ifConData '{' ifDataNamedFieldL '}'
279 {$$ = gc4(zpair($1,$3));}
281 ifDataAnonFieldL /* [((Type,VarId,Int))] */
283 | ifDataAnonField ifDataAnonFieldL
284 {$$=gc2(cons($1,$2));}
286 ifDataNamedFieldL /* [((Type,VarId,Int))] */
288 | ifDataNamedField {$$=gc1(cons($1,NIL));}
289 | ifDataNamedField ',' ifDataNamedFieldL
290 {$$=gc3(cons($1,$3));}
292 ifDataAnonField /* ((Type,VarId,Int)) */
293 : ifAType {$$=gc1(ztriple($1,NIL,mkInt(0)));}
294 | '!' ifAType {$$=gc2(ztriple($2,NIL,mkInt(1)));}
295 | '!' '!' ifAType {$$=gc3(ztriple($3,NIL,mkInt(2)));}
297 ifDataNamedField /* ((Type,VarId,Int)) */
298 : ifVar COCO ifAType {$$=gc3(ztriple($3,$1,mkInt(0)));}
299 | ifVar COCO '!' ifAType {$$=gc4(ztriple($4,$1,mkInt(1)));}
300 | ifVar COCO '!' '!' ifAType {$$=gc5(ztriple($5,$1,mkInt(2)));}
304 /*- Interface class declarations - methods ----------------*/
305 ifCmeths /* [((VarId,Type))] */
307 | WHERE '{' ifCmethL '}' { $$ = gc4($3); }
309 ifCmethL /* [((VarId,Type))] */
310 : ifCmeth { $$ = gc1(singleton($1)); }
311 | ifCmeth ';' ifCmethL { $$ = gc3(cons($1,$3)); }
313 ifCmeth /* ((VarId,Type)) */
314 : ifVar COCO ifType { $$ = gc3(zpair($1,$3)); }
315 | ifVar '=' COCO ifType { $$ = gc4(zpair($1,$4)); }
316 /* has default method */
320 /*- Interface newtype declararions ------------------------*/
321 ifNewTypeConstr /* ((ConId,Type)) */
322 : '=' ifCon ifAType { $$ = gc3(zpair($2,$3)); }
326 /*- Interface type expressions ----------------------------*/
327 ifType : ALL ifForall ifCtxDeclT IMPLIES ifType
330 $$=gc5(pair(QUAL,pair($3,$5)));
332 | ifBType ARROW ifType { $$ = gc3(fn($1,$3)); }
333 | ifBType { $$ = gc1($1); }
335 ifForall /* [((VarId,Kind))] */
336 : '[' ifKindedTyvarL ']' { $$ = gc3($2); }
339 ifTypeL2 /* [Type], 2 or more */
340 : ifType ',' ifType { $$ = gc3(doubleton($1,$3)); }
341 | ifType ',' ifTypeL2 { $$ = gc3(cons($1,$3)); }
344 ifTypeL /* [Type], 0 or more */
345 : ifType ',' ifTypeL { $$ = gc3(cons($1,$3)); }
346 | ifType { $$ = gc1(singleton($1)); }
350 ifBType : ifAType { $$ = gc1($1); }
351 | ifBType ifAType { $$ = gc2(ap($1,$2)); }
352 | UUUSAGE ifUsage ifAType { $$ = gc3($3); }
355 ifAType : ifQTCName { $$ = gc1($1); }
356 | ifTyvar { $$ = gc1($1); }
357 | '(' ')' { $$ = gc2(typeUnit); }
358 | '(' ifTypeL2 ')' { $$ = gc3(buildTuple(reverse($2))); }
359 | '[' ifType ']' { $$ = gc3(ap(mkCon(tycon(typeList).text),
361 | '{' ifQTCName ifAType '}' { $$ = gc4(ap(DICTAP,
363 | '(' ifType ')' { $$ = gc3($2); }
364 | UTL ifTypeL UTR { $$ = gc3(ap(UNBOXEDTUP,$2)); }
368 /*- KW's usage stuff --------------------------------------*/
369 ifUsage : '-' { $$ = gc1(NIL); }
370 | '!' { $$ = gc1(NIL); }
371 | ifVar { $$ = gc1(NIL); }
375 /*- Interface kinds ---------------------------------------*/
376 ifKindedTyvarL /* [((VarId,Kind))] */
378 | ifKindedTyvar ifKindedTyvarL { $$ = gc2(cons($1,$2)); }
380 ifKindedTyvar /* ((VarId,Kind)) */
381 : ifTyvar { $$ = gc1(zpair($1,STAR)); }
382 | ifTyvar COCO ifAKind { $$ = gc3(zpair($1,$3)); }
384 ifKind : ifAKind { $$ = gc1($1); }
385 | ifAKind ARROW ifKind { $$ = gc3(ap($1,$3)); }
387 ifAKind : VAROP { $$ = gc1(STAR); }
389 | '(' ifKind ')' { $$ = gc3($2); }
393 /*- Interface version/export/import stuff -----------------*/
396 | ifEntity ifEntities { $$ = gc2(cons($1,$2)); }
399 : ifEntityOcc {$$=gc1($1);}
400 | ifEntityOcc ifStuffInside {$$=gc2(zpair($1,$2));}
403 : ifVar { $$ = gc1($1); }
404 | ifCon { $$ = gc1($1); }
405 | ARROW { $$ = gc1(typeArrow); }
406 | '(' ARROW ')' { $$ = gc3(typeArrow); }
407 /* why allow both? */
410 : '{' ifValOccs '}' { $$ = gc3($2); }
414 | ifVar ifValOccs { $$ = gc2(cons($1,$2)); }
415 | ifCon ifValOccs { $$ = gc2(cons($1,$2)); }
420 | VARID NUMLIT ifVersionList {$$=gc3(cons($1,$3));}
421 | CONID NUMLIT ifVersionList {$$=gc3(cons($1,$3));}
425 /*- Haskell module header/import parsing: -----------------------------------
426 * Module chasing is now totally different from Classic Hugs98. We parse
427 * the entire syntax tree. Subsequent passes over the tree collect and
428 * chase imports; we no longer attempt to do so whilst parsing.
429 *-------------------------------------------------------------------------*/
431 /* In Haskell 1.2, the default module header was "module Main where"
432 * In 1.3, this changed to "module Main(main) where".
433 * We use the 1.2 header because it breaks much less pre-module code.
434 * STG Hugs, 15 March 00: disallow default headers (pro tem).
436 topModule : TMODULE modname expspec WHERE '{' modBody end
438 ztriple($2,$3,$6)));}
439 | TMODULE modname WHERE '{' modBody end
443 singleton(ap(MODULEENT,$2)),
446 | begin modBody end {ConId fakeNm = mkCon(module(
447 moduleBeingParsed).text);
448 $$ = gc2(ap(M_MODULE,
450 singleton(ap(MODULEENT,fakeNm)),
453 | TMODULE error {syntaxError("module definition");}
456 modname : CONID {$$ = gc1($1);}
458 modid : CONID {$$ = gc1($1);}
460 modBody : topDecls {$$ = gc1($1);}
461 | impDecls {$$ = gc1($1);}
462 | impDecls ';' topDecls {$$ = gc3(appendOnto($1,$3));}
465 /*- Exports: --------------------------------------------------------------*/
467 expspec : '(' ')' {$$ = gc2(NIL);}
468 | '(' exports ')' {$$ = gc3($2);}
469 | '(' exports ',' ')' {$$ = gc4($2);}
471 exports : exports ',' export {$$ = gc3(cons($3,$1));}
472 | export {$$ = gc1(singleton($1));}
474 /* The qcon should be qconid.
475 * Relaxing the rule lets us explicitly export (:) from the Prelude.
477 export : qvar {$$ = $1;}
479 | qconid '(' UPTO ')' {$$ = gc4(pair($1,DOTDOT));}
480 | qconid '(' qnames ')' {$$ = gc4(pair($1,$3));}
481 | TMODULE modid {$$ = gc2(ap(MODULEENT,$2));}
483 qnames : /* empty */ {$$ = gc0(NIL);}
484 | ',' {$$ = gc1(NIL);}
486 | qnames1 ',' {$$ = gc2($1);}
488 qnames1 : qnames1 ',' qname {$$ = gc3(cons($3,$1));}
489 | qname {$$ = gc1(singleton($1));}
491 qname : qvar {$$ = $1;}
495 /*- Import declarations: --------------------------------------------------*/
497 impDecls : impDecls ';' impDecl {$$ = gc3(appendOnto($3,$1));}
498 | impDecl {$$ = gc1($1);}
501 /* Note that qualified import ignores the import list. */
502 impDecl : IMPORT modid impspec {$$=gc3(doubleton(
503 ap(M_IMPORT_Q,zpair($2,$2)),
504 ap(M_IMPORT_UNQ,zpair($2,$3))
506 | IMPORT modid ASMOD modid impspec
508 ap(M_IMPORT_Q,zpair($2,$4)),
509 ap(M_IMPORT_UNQ,zpair($2,$5))
511 | IMPORT QUALIFIED modid ASMOD modid impspec
513 ap(M_IMPORT_Q,zpair($3,$5))
515 | IMPORT QUALIFIED modid impspec
517 ap(M_IMPORT_Q,zpair($3,$3))
519 | IMPORT PRIVILEGED modid '(' imports ')'
522 zpair($3,ap(STAR,$5)))));}
523 | IMPORT error {syntaxError("import declaration");}
525 impspec : /* empty */ {$$ = gc0(DOTDOT);}
526 | HIDING '(' imports ')' {$$ = gc4(ap(HIDDEN,$3));}
527 | '(' imports ')' {$$ = gc3($2);}
529 imports : /* empty */ {$$ = gc0(NIL);}
530 | ',' {$$ = gc1(NIL);}
531 | imports1 {$$ = $1;}
532 | imports1 ',' {$$ = gc2($1);}
534 imports1 : imports1 ',' import {$$ = gc3(cons($3,$1));}
535 | import {$$ = gc1(singleton($1));}
537 import : var {$$ = $1;}
539 | CONID '(' UPTO ')' {$$ = gc4(pair($1,DOTDOT));}
540 | CONID '(' names ')' {$$ = gc4(pair($1,$3));}
542 names : /* empty */ {$$ = gc0(NIL);}
543 | ',' {$$ = gc1(NIL);}
545 | names1 ',' {$$ = gc2($1);}
547 names1 : names1 ',' name {$$ = gc3(cons($3,$1));}
548 | name {$$ = gc1(singleton($1));}
550 name : var {$$ = $1;}
554 /*- Top-level declarations: -----------------------------------------------*/
556 topDecls : /* empty */ {$$=gc0(NIL);}
557 | topDecl ';' topDecls {$$=gc3(cons($1,$3));}
558 | decl ';' topDecls {$$=gc3(cons(ap(M_VALUE,$1),$3));}
559 | topDecl {$$=gc1(cons($1,NIL));}
560 | decl {$$=gc1(cons(ap(M_VALUE,$1),NIL));}
563 /*- Type declarations: ----------------------------------------------------*/
565 topDecl : TYPE tyLhs '=' type {$$=gc4(ap(M_TYCON,
568 | TYPE tyLhs '=' type IN invars
570 z4ble($3,$2,ap($4,$6),
572 | TYPE error {syntaxError("type definition");}
573 | DATA btype2 '=' constrs deriving
575 z4ble($3,checkTyLhs($2),
578 | DATA context IMPLIES tyLhs '=' constrs deriving
581 ap(qualify($2,rev($6)),$7),
583 | DATA btype2 {$$=gc2(ap(M_TYCON,
584 z4ble($1,checkTyLhs($2),
585 ap(NIL,NIL),DATATYPE)));}
586 | DATA context IMPLIES tyLhs {$$=gc4(ap(M_TYCON,
588 ap(qualify($2,NIL),NIL),
590 | DATA error {syntaxError("data definition");}
591 | TNEWTYPE btype2 '=' nconstr deriving
593 z4ble($3,checkTyLhs($2),
594 ap($4,$5),NEWTYPE)));}
595 | TNEWTYPE context IMPLIES tyLhs '=' nconstr deriving
598 ap(qualify($2,$6),$7),
600 | TNEWTYPE error {syntaxError("newtype definition");}
602 tyLhs : tyLhs varid {$$ = gc2(ap($1,$2));}
604 | error {syntaxError("type defn lhs");}
606 invars : invars ',' invar {$$ = gc3(cons($3,$1));}
607 | invar {$$ = gc1(cons($1,NIL));}
609 invar : var COCO topType {$$ = gc3(sigdecl($2,singleton($1),
613 constrs : constrs '|' pconstr {$$ = gc3(cons($3,$1));}
614 | pconstr {$$ = gc1(cons($1,NIL));}
616 pconstr : ALL varids '.' qconstr {$$ = gc4(ap(POLYTYPE,
620 qconstr : context IMPLIES constr {$$ = gc3(qualify($1,$3));}
623 constr : '!' btype conop bbtype {$$ = gc4(ap(ap($3,bang($2)),$4));}
624 | btype1 conop bbtype {$$ = gc3(ap(ap($2,$1),$3));}
625 | btype2 conop bbtype {$$ = gc3(ap(ap($2,$1),$3));}
626 | bpolyType conop bbtype {$$ = gc3(ap(ap($2,$1),$3));}
630 | con '{' fieldspecs '}' {$$ = gc4(ap(LABC,pair($1,rev($3))));}
631 | con '{' '}' {$$ = gc3(ap(LABC,pair($1,NIL)));}
632 | error {syntaxError("data type definition");}
634 btype3 : btype2 '!' atype {$$ = gc3(ap($1,bang($3)));}
635 | btype3 '!' atype {$$ = gc3(ap($1,bang($3)));}
636 | btype3 atype {$$ = gc2(ap($1,$2));}
638 btype4 : btype2 bpolyType {$$ = gc2(ap($1,$2));}
639 | btype3 bpolyType {$$ = gc2(ap($1,$2));}
640 | btype4 bpolyType {$$ = gc2(ap($1,$2));}
641 | btype4 atype {$$ = gc2(ap($1,$2));}
642 | btype4 '!' atype {$$ = gc3(ap($1,bang($3)));}
644 bbtype : '!' btype {$$ = gc2(bang($2));}
646 | bpolyType {$$ = $1;}
648 nconstr : pconstr {$$ = gc1(singleton($1));}
650 fieldspecs: fieldspecs ',' fieldspec {$$ = gc3(cons($3,$1));}
651 | fieldspec {$$ = gc1(cons($1,NIL));}
653 fieldspec : vars COCO polyType {$$ = gc3(pair(rev($1),$3));}
654 | vars COCO type {$$ = gc3(pair(rev($1),$3));}
655 | vars COCO '!' type {$$ = gc4(pair(rev($1),bang($4)));}
657 deriving : /* empty */ {$$ = gc0(NIL);}
658 | DERIVING qconid {$$ = gc2(singleton($2));}
659 | DERIVING '(' derivs0 ')' {$$ = gc4($3);}
661 derivs0 : /* empty */ {$$ = gc0(NIL);}
662 | derivs {$$ = gc1(rev($1));}
664 derivs : derivs ',' qconid {$$ = gc3(cons($3,$1));}
665 | qconid {$$ = gc1(singleton($1));}
668 /*- Processing definitions of primitives ----------------------------------*/
670 topDecl : FOREIGN IMPORT callconv DYNAMIC unsafe_flag var COCO type
671 {$$=gc8(ap(M_FOREIGN_IM,z5ble($1,$3,NIL,$6,$8)));}
672 | FOREIGN IMPORT callconv ext_loc ext_name unsafe_flag var COCO type
673 {$$=gc9(ap(M_FOREIGN_IM,z5ble($1,$3,pair($4,$5),$7,$9)));}
674 | FOREIGN EXPORT callconv DYNAMIC qvarid COCO type
675 {$$=gc7(ap(M_FOREIGN_EX,z5ble($1,$3,$4,$5,$7)));}
678 callconv : CCALL {$$ = gc1(textCcall);}
679 | STDKALL {$$ = gc1(textStdcall);}
680 | /* empty */ {$$ = gc0(NIL);}
682 ext_loc : STRINGLIT {$$ = $1;}
684 ext_name : STRINGLIT {$$ = $1;}
686 unsafe_flag: /* empty */ {$$ = gc0(NIL);}
687 | UNSAFE {$$ = gc1(NIL); /* ignored */ }
691 /*- Class declarations: ---------------------------------------------------*/
693 topDecl : TCLASS crule fds wherePart {$$=gc4(ap(M_CLASS,z4ble($1,$2,$4,$3)));}
694 | TINSTANCE irule wherePart {$$=gc3(ap(M_INST,ztriple($1,$2,$3)));}
695 | DEFAULT '(' dtypes ')' {$$=gc4(ap(M_DEFAULT,zpair($1,$3)));}
696 | TCLASS error {syntaxError("class declaration");}
697 | TINSTANCE error {syntaxError("instance declaration");}
698 | DEFAULT error {syntaxError("default declaration");}
700 crule : context IMPLIES btype2 {$$ = gc3(pair($1,checkPred($3)));}
701 | btype2 {$$ = gc1(pair(NIL,checkPred($1)));}
703 irule : context IMPLIES btype2 {$$ = gc3(pair($1,checkPred($3)));}
704 | btype2 {$$ = gc1(pair(NIL,checkPred($1)));}
706 dtypes : /* empty */ {$$ = gc0(NIL);}
707 | dtypes1 {$$ = gc1(rev($1));}
709 dtypes1 : dtypes1 ',' type {$$ = gc3(cons($3,$1));}
710 | type {$$ = gc1(cons($1,NIL));}
713 fds : /* empty */ {$$ = gc0(NIL);}
714 | '|' fds1 {h98DoesntSupport(row,"dependent parameters");
717 fds1 : fds1 ',' fd {$$ = gc3(cons($3,$1));}
718 | fd {$$ = gc1(cons($1,NIL));}
721 fd : varids0 ARROW varids0 {$$ = gc3(pair(rev($1),rev($3)));}
723 varids0 : /* empty */ {$$ = gc0(NIL);}
724 | varids0 varid {$$ = gc2(cons($2,$1));}
727 /*- Type expressions: -----------------------------------------------------*/
729 topType : ALL varids '.' topType0 {$$ = gc4(ap(POLYTYPE,
731 | topType0 {$$ = $1;}
733 topType0 : context IMPLIES topType1 {$$ = gc3(qualify($1,$3));}
734 | topType1 {$$ = $1;}
736 topType1 : bpolyType ARROW topType1 {$$ = gc3(fn($1,$3));}
737 | btype1 ARROW topType1 {$$ = gc3(fn($1,$3));}
738 | btype2 ARROW topType1 {$$ = gc3(fn($1,$3));}
741 polyType : ALL varids '.' sigType {$$ = gc4(ap(POLYTYPE,
743 | context IMPLIES type {$$ = gc3(qualify($1,$3));}
744 | bpolyType {$$ = $1;}
746 bpolyType : '(' polyType ')' {$$ = gc3($2);}
748 varids : varids varid {$$ = gc2(cons($2,$1));}
749 | varid {$$ = gc1(singleton($1));}
751 sigType : context IMPLIES type {$$ = gc3(qualify($1,$3));}
754 context : '(' ')' {$$ = gc2(NIL);}
755 | btype2 {$$ = gc1(singleton(checkPred($1)));}
756 | '(' btype2 ')' {$$ = gc3(singleton(checkPred($2)));}
757 | '(' btypes2 ')' {$$ = gc3(checkCtxt(rev($2)));}
759 | lacks {$$ = gc1(singleton($1));}
760 | '(' lacks1 ')' {$$ = gc3(checkCtxt(rev($2)));}
762 lacks : varid '\\' varid {
764 $$ = gc3(ap(mkExt(textOf($3)),$1));
766 noTREX("a type context");
769 | IPVARID COCO type {
771 $$ = gc3(pair(mkIParam($1),$3));
773 noIP("a type context");
777 lacks1 : btypes2 ',' lacks {$$ = gc3(cons($3,$1));}
778 | lacks1 ',' btype2 {$$ = gc3(cons($3,$1));}
779 | lacks1 ',' lacks {$$ = gc3(cons($3,$1));}
780 | btype2 ',' lacks {$$ = gc3(cons($3,cons($1,NIL)));}
781 | lacks {$$ = gc1(singleton($1));}
785 type : type1 {$$ = $1;}
788 type1 : btype1 {$$ = $1;}
789 | btype1 ARROW type {$$ = gc3(fn($1,$3));}
790 | btype2 ARROW type {$$ = gc3(fn($1,$3));}
791 | error {syntaxError("type expression");}
793 btype : btype1 {$$ = $1;}
796 btype1 : btype1 atype {$$ = gc2(ap($1,$2));}
799 btype2 : btype2 atype {$$ = gc2(ap($1,$2));}
802 atype : atype1 {$$ = $1;}
805 atype1 : varid {$$ = $1;}
806 | '(' ')' {$$ = gc2(typeUnit);}
807 | '(' ARROW ')' {$$ = gc3(typeArrow);}
808 | '(' type1 ')' {$$ = gc3($2);}
809 | '(' btype2 ')' {$$ = gc3($2);}
810 | '(' tupCommas ')' {$$ = gc3($2);}
811 | '(' btypes2 ')' {$$ = gc3(buildTuple($2));}
812 | '(' typeTuple ')' {$$ = gc3(buildTuple($2));}
815 $$ = gc3(revOnto($2,typeNoRow));
820 | '(' tfields '|' type ')' {
822 $$ = gc5(revOnto($2,$4));
827 | '[' type ']' {$$ = gc3(ap(typeList,$2));}
828 | '[' ']' {$$ = gc2(typeList);}
829 | '_' {h98DoesntSupport(row,"anonymous type variables");
830 $$ = gc1(inventVar());}
832 btypes2 : btypes2 ',' btype2 {$$ = gc3(cons($3,$1));}
833 | btype2 ',' btype2 {$$ = gc3(cons($3,cons($1,NIL)));}
835 typeTuple : type1 ',' type {$$ = gc3(cons($3,cons($1,NIL)));}
836 | btype2 ',' type1 {$$ = gc3(cons($3,cons($1,NIL)));}
837 | btypes2 ',' type1 {$$ = gc3(cons($3,$1));}
838 | typeTuple ',' type {$$ = gc3(cons($3,$1));}
841 tfields : tfields ',' tfield {$$ = gc3(cons($3,$1));}
842 | tfield {$$ = gc1(singleton($1));}
844 tfield : varid COCO type {h98DoesntSupport(row,"extensible records");
845 $$ = gc3(ap(mkExt(textOf($1)),$3));}
849 /*- Value declarations: ---------------------------------------------------*/
851 gendecl : INFIXN optDigit ops {$$ = gc3(fixdecl($1,$3,NON_ASS,$2));}
852 | INFIXN error {syntaxError("fixity decl");}
853 | INFIXL optDigit ops {$$ = gc3(fixdecl($1,$3,LEFT_ASS,$2));}
854 | INFIXL error {syntaxError("fixity decl");}
855 | INFIXR optDigit ops {$$ = gc3(fixdecl($1,$3,RIGHT_ASS,$2));}
856 | INFIXR error {syntaxError("fixity decl");}
857 | vars COCO topType {$$ = gc3(sigdecl($2,$1,$3));}
858 | vars COCO error {syntaxError("type signature");}
860 optDigit : NUMLIT {$$ = gc1(checkPrec($1));}
861 | /* empty */ {$$ = gc0(mkInt(DEF_PREC));}
863 ops : ops ',' op {$$ = gc3(cons($3,$1));}
864 | op {$$ = gc1(singleton($1));}
866 vars : vars ',' var {$$ = gc3(cons($3,$1));}
867 | var {$$ = gc1(singleton($1));}
869 decls : '{' decls0 end {$$ = gc3($2);}
870 | '{' decls1 end {$$ = gc3($2);}
872 decls0 : /* empty */ {$$ = gc0(NIL);}
873 | decls0 ';' {$$ = gc2($1);}
874 | decls1 ';' {$$ = gc2($1);}
876 decls1 : decls0 decl {$$ = gc2(cons($2,$1));}
878 decl : gendecl {$$ = $1;}
879 | funlhs rhs {$$ = gc2(ap(FUNBIND,pair($1,$2)));}
880 | funlhs COCO type rhs {$$ = gc4(ap(FUNBIND,
883 | pat0 rhs {$$ = gc2(ap(PATBIND,pair($1,$2)));}
885 funlhs : funlhs0 {$$ = $1;}
889 funlhs0 : pat10_vI varop pat0 {$$ = gc3(ap2($2,$1,$3));}
890 | infixPat varop pat0 {$$ = gc3(ap2($2,$1,$3));}
891 | NUMLIT varop pat0 {$$ = gc3(ap2($2,$1,$3));}
892 | var varop_pl pat0 {$$ = gc3(ap2($2,$1,$3));}
893 | var '+' pat0_INT {$$ = gc3(ap2(varPlus,$1,$3));}
895 funlhs1 : '(' funlhs0 ')' apat {$$ = gc4(ap($2,$4));}
896 | '(' funlhs1 ')' apat {$$ = gc4(ap($2,$4));}
897 | '(' npk ')' apat {$$ = gc4(ap($2,$4));}
898 | var apat {$$ = gc2(ap($1,$2));}
899 | funlhs1 apat {$$ = gc2(ap($1,$2));}
901 rhs : rhs1 wherePart {$$ = gc2(letrec($2,$1));}
902 | error {syntaxError("declaration");}
904 rhs1 : '=' exp {$$ = gc2(pair($1,$2));}
905 | gdrhs {$$ = gc1(grded(rev($1)));}
907 gdrhs : gdrhs gddef {$$ = gc2(cons($2,$1));}
908 | gddef {$$ = gc1(singleton($1));}
910 gddef : '|' exp0 '=' exp {$$ = gc4(pair($3,pair($2,$4)));}
912 wherePart : /* empty */ {$$ = gc0(NIL);}
913 | WHERE decls {$$ = gc2($2);}
916 /*- Patterns: -------------------------------------------------------------*/
921 pat_npk : pat0 COCO type {$$ = gc3(ap(ESIGN,pair($1,$3)));}
924 npk : var '+' NUMLIT {$$ = gc3(ap2(varPlus,$1,$3));}
926 pat0 : var {$$ = $1;}
930 pat0_INT : var {$$ = $1;}
933 pat0_vI : pat10_vI {$$ = $1;}
934 | infixPat {$$ = gc1(ap(INFIX,$1));}
936 infixPat : '-' pat10 {$$ = gc2(ap(NEG,only($2)));}
937 | '-' error {syntaxError("pattern");}
938 | var qconop pat10 {$$ = gc3(ap(ap($2,only($1)),$3));}
939 | var qconop '-' pat10 {$$ = gc4(ap(NEG,ap2($2,only($1),$4)));}
940 | NUMLIT qconop pat10 {$$ = gc3(ap(ap($2,only($1)),$3));}
941 | NUMLIT qconop '-' pat10 {$$ = gc4(ap(NEG,ap2($2,only($1),$4)));}
942 | pat10_vI qconop pat10 {$$ = gc3(ap(ap($2,only($1)),$3));}
943 | pat10_vI qconop '-' pat10 {$$ = gc4(ap(NEG,ap2($2,only($1),$4)));}
944 | infixPat qconop pat10 {$$ = gc3(ap(ap($2,$1),$3));}
945 | infixPat qconop '-' pat10 {$$ = gc4(ap(NEG,ap(ap($2,$1),$4)));}
947 pat10 : fpat {$$ = $1;}
950 pat10_vI : fpat {$$ = $1;}
953 fpat : fpat apat {$$ = gc2(ap($1,$2));}
954 | gcon apat {$$ = gc2(ap($1,$2));}
956 apat : NUMLIT {$$ = $1;}
960 apat_vI : var '@' apat {$$ = gc3(ap(ASPAT,pair($1,$3)));}
962 | qcon '{' patbinds '}' {$$ = gc4(ap(CONFLDS,pair($1,$3)));}
964 | STRINGLIT {$$ = $1;}
965 | '_' {$$ = gc1(WILDCARD);}
966 | '(' pat_npk ')' {$$ = gc3($2);}
967 | '(' npk ')' {$$ = gc3($2);}
968 | '(' pats2 ')' {$$ = gc3(buildTuple($2));}
969 | '[' pats1 ']' {$$ = gc3(ap(FINLIST,rev($2)));}
970 | '~' apat {$$ = gc2(ap(LAZYPAT,$2));}
972 | '(' patfields ')' {
974 $$ = gc3(revOnto($2,nameNoRec));
979 | '(' patfields '|' pat ')' {$$ = gc5(revOnto($2,$4));}
982 pats2 : pats2 ',' pat {$$ = gc3(cons($3,$1));}
983 | pat ',' pat {$$ = gc3(cons($3,singleton($1)));}
985 pats1 : pats1 ',' pat {$$ = gc3(cons($3,$1));}
986 | pat {$$ = gc1(singleton($1));}
988 patbinds : /* empty */ {$$ = gc0(NIL);}
989 | patbinds1 {$$ = gc1(rev($1));}
991 patbinds1 : patbinds1 ',' patbind {$$ = gc3(cons($3,$1));}
992 | patbind {$$ = gc1(singleton($1));}
994 patbind : qvar '=' pat {$$ = gc3(pair($1,$3));}
998 patfields : patfields ',' patfield {$$ = gc3(cons($3,$1));}
999 | patfield {$$ = gc1(singleton($1));}
1001 patfield : varid '=' pat {
1003 $$ = gc3(ap(mkExt(textOf($1)),$3));
1005 noTREX("a pattern");
1011 /*- Expressions: ----------------------------------------------------------*/
1013 exp : exp_err {$$ = $1;}
1014 | error {syntaxError("expression");}
1016 exp_err : exp0a COCO sigType {$$ = gc3(ap(ESIGN,pair($1,$3)));}
1017 | exp0a WITH dbinds {
1019 $$ = gc3(ap(WITHEXP,pair($1,$3)));
1021 noIP("an expression");
1026 exp0 : exp0a {$$ = $1;}
1029 exp0a : infixExpa {$$ = gc1(ap(INFIX,$1));}
1032 exp0b : infixExpb {$$ = gc1(ap(INFIX,$1));}
1035 infixExpa : infixExpa qop '-' exp10a {$$ = gc4(ap(NEG,ap(ap($2,$1),$4)));}
1036 | infixExpa qop exp10a {$$ = gc3(ap(ap($2,$1),$3));}
1037 | '-' exp10a {$$ = gc2(ap(NEG,only($2)));}
1038 | exp10a qop '-' exp10a {$$ = gc4(ap(NEG,
1039 ap(ap($2,only($1)),$4)));}
1040 | exp10a qop exp10a {$$ = gc3(ap(ap($2,only($1)),$3));}
1042 infixExpb : infixExpa qop '-' exp10b {$$ = gc4(ap(NEG,ap(ap($2,$1),$4)));}
1043 | infixExpa qop exp10b {$$ = gc3(ap(ap($2,$1),$3));}
1044 | '-' exp10b {$$ = gc2(ap(NEG,only($2)));}
1045 | exp10a qop '-' exp10b {$$ = gc4(ap(NEG,
1046 ap(ap($2,only($1)),$4)));}
1047 | exp10a qop exp10b {$$ = gc3(ap(ap($2,only($1)),$3));}
1049 exp10a : CASEXP exp OF '{' alts end {$$ = gc6(ap(CASE,pair($2,rev($5))));}
1050 | DO '{' stmts end {$$ = gc4(ap(DOCOMP,checkDo($3)));}
1053 exp10b : '\\' pats ARROW exp {$$ = gc4(ap(LAMBDA,
1056 | LET decls IN exp {$$ = gc4(letrec($2,$4));}
1057 | IF exp THEN exp ELSE exp {$$ = gc6(ap(COND,triple($2,$4,$6)));}
1058 | DLET dbinds IN exp {
1060 $$ = gc4(ap(WITHEXP,pair($4,$2)));
1062 noIP("an expression");
1066 pats : pats apat {$$ = gc2(cons($2,$1));}
1067 | apat {$$ = gc1(cons($1,NIL));}
1069 appExp : appExp aexp {$$ = gc2(ap($1,$2));}
1072 aexp : qvar {$$ = $1;}
1073 | qvar '@' aexp {$$ = gc3(ap(ASPAT,pair($1,$3)));}
1074 | '~' aexp {$$ = gc2(ap(LAZYPAT,$2));}
1075 | IPVARID {$$ = $1;}
1076 | '_' {$$ = gc1(WILDCARD);}
1078 | qcon '{' fbinds '}' {$$ = gc4(ap(CONFLDS,pair($1,$3)));}
1079 | aexp '{' fbinds '}' {$$ = gc4(ap(UPDFLDS,
1080 triple($1,NIL,$3)));}
1082 | CHARLIT {$$ = $1;}
1083 | STRINGLIT {$$ = $1;}
1085 | '(' exp ')' {$$ = gc3($2);}
1086 | '(' exps2 ')' {$$ = gc3(buildTuple($2));}
1090 $$ = gc3(revOnto($2,nameNoRec));
1095 | '(' vfields '|' exp ')' {$$ = gc5(revOnto($2,$4));}
1096 | RECSELID {$$ = $1;}
1098 | '[' list ']' {$$ = gc3($2);}
1099 | '(' exp10a qop ')' {$$ = gc4(ap($3,$2));}
1100 | '(' qvarop_mi exp0 ')' {$$ = gc4(ap(ap(nameFlip,$2),$3));}
1101 | '(' qconop exp0 ')' {$$ = gc4(ap(ap(nameFlip,$2),$3));}
1103 exps2 : exps2 ',' exp {$$ = gc3(cons($3,$1));}
1104 | exp ',' exp {$$ = gc3(cons($3,cons($1,NIL)));}
1107 vfields : vfields ',' vfield {$$ = gc3(cons($3,$1));}
1108 | vfield {$$ = gc1(singleton($1));}
1110 vfield : varid '=' exp {
1112 $$ = gc3(ap(mkExt(textOf($1)),$3));
1114 noTREX("an expression");
1119 alts : alts1 {$$ = $1;}
1120 | alts1 ';' {$$ = gc2($1);}
1122 alts1 : alts1 ';' alt {$$ = gc3(cons($3,$1));}
1123 | alt {$$ = gc1(cons($1,NIL));}
1125 alt : pat altRhs wherePart {$$ = gc3(pair($1,letrec($3,$2)));}
1127 altRhs : guardAlts {$$ = gc1(grded(rev($1)));}
1128 | ARROW exp {$$ = gc2(pair($1,$2));}
1129 | error {syntaxError("case expression");}
1131 guardAlts : guardAlts guardAlt {$$ = gc2(cons($2,$1));}
1132 | guardAlt {$$ = gc1(cons($1,NIL));}
1134 guardAlt : '|' exp0 ARROW exp {$$ = gc4(pair($3,pair($2,$4)));}
1136 stmts : stmts1 ';' {$$ = gc2($1);}
1139 stmts1 : stmts1 ';' stmt {$$ = gc3(cons($3,$1));}
1140 | stmt {$$ = gc1(cons($1,NIL));}
1142 stmt : exp_err FROM exp {$$ = gc3(ap(FROMQUAL,pair($1,$3)));}
1143 | LET decls {$$ = gc2(ap(QWHERE,$2));}
1144 /* | IF exp {$$ = gc2(ap(BOOLQUAL,$2));}*/
1145 | exp_err {$$ = gc1(ap(DOQUAL,$1));}
1147 fbinds : /* empty */ {$$ = gc0(NIL);}
1148 | fbinds1 {$$ = gc1(rev($1));}
1150 fbinds1 : fbinds1 ',' fbind {$$ = gc3(cons($3,$1));}
1151 | fbind {$$ = gc1(singleton($1));}
1153 fbind : var {$$ = $1;}
1154 | qvar '=' exp {$$ = gc3(pair($1,$3));}
1157 dbinds : '{' dbs0 end {$$ = gc3($2);}
1158 | '{' dbs1 end {$$ = gc3($2);}
1160 dbs0 : /* empty */ {$$ = gc0(NIL);}
1161 | dbs0 ';' {$$ = gc2($1);}
1162 | dbs1 ';' {$$ = gc2($1);}
1164 dbs1 : dbs0 dbind {$$ = gc2(cons($2,$1));}
1166 dbind : IPVARID '=' exp {$$ = gc3(pair($1,$3));}
1169 /*- List Expressions: -------------------------------------------------------*/
1171 list : exp {$$ = gc1(ap(FINLIST,cons($1,NIL)));}
1172 | exps2 {$$ = gc1(ap(FINLIST,rev($1)));}
1173 | exp '|' quals {$$ = gc3(ap(COMP,pair($1,rev($3))));}
1174 | exp UPTO exp {$$ = gc3(ap(ap(nameFromTo,$1),$3));}
1175 | exp ',' exp UPTO {$$ = gc4(ap(ap(nameFromThen,$1),$3));}
1176 | exp UPTO {$$ = gc2(ap(nameFrom,$1));}
1177 | exp ',' exp UPTO exp {$$ = gc5(ap(ap(ap(nameFromThenTo,
1180 quals : quals ',' qual {$$ = gc3(cons($3,$1));}
1181 | qual {$$ = gc1(cons($1,NIL));}
1183 qual : exp FROM exp {$$ = gc3(ap(FROMQUAL,pair($1,$3)));}
1184 | exp {$$ = gc1(ap(BOOLQUAL,$1));}
1185 | LET decls {$$ = gc2(ap(QWHERE,$2));}
1188 /*- Identifiers and symbols: ----------------------------------------------*/
1190 gcon : qcon {$$ = $1;}
1191 | '(' ')' {$$ = gc2(nameUnit);}
1192 | '[' ']' {$$ = gc2(nameNil);}
1193 | '(' tupCommas ')' {$$ = gc3($2);}
1195 tupCommas : tupCommas ',' {$$ = gc2(mkTuple(tupleOf($1)+1));}
1196 | ',' {$$ = gc1(mkTuple(2));}
1198 varid : VARID {$$ = $1;}
1199 | HIDING {$$ = gc1(varHiding);}
1200 | QUALIFIED {$$ = gc1(varQualified);}
1201 | ASMOD {$$ = gc1(varAsMod);}
1202 | PRIVILEGED {$$ = gc1(varPrivileged);}
1204 qconid : QCONID {$$ = $1;}
1207 var : varid {$$ = $1;}
1208 | '(' VAROP ')' {$$ = gc3($2);}
1209 | '(' '+' ')' {$$ = gc3(varPlus);}
1210 | '(' '-' ')' {$$ = gc3(varMinus);}
1211 | '(' '!' ')' {$$ = gc3(varBang);}
1212 | '(' '.' ')' {$$ = gc3(varDot);}
1214 qvar : QVARID {$$ = $1;}
1215 | '(' QVAROP ')' {$$ = gc3($2);}
1218 con : CONID {$$ = $1;}
1219 | '(' CONOP ')' {$$ = gc3($2);}
1221 qcon : QCONID {$$ = $1;}
1222 | '(' QCONOP ')' {$$ = gc3($2);}
1225 varop : '+' {$$ = gc1(varPlus);}
1226 | '-' {$$ = gc1(varMinus);}
1227 | varop_mipl {$$ = $1;}
1229 varop_mi : '+' {$$ = gc1(varPlus);}
1230 | varop_mipl {$$ = $1;}
1232 varop_pl : '-' {$$ = gc1(varMinus);}
1233 | varop_mipl {$$ = $1;}
1235 varop_mipl: VAROP {$$ = $1;}
1236 | '`' varid '`' {$$ = gc3($2);}
1237 | '!' {$$ = gc1(varBang);}
1238 | '.' {$$ = gc1(varDot);}
1240 qvarop : '-' {$$ = gc1(varMinus);}
1241 | qvarop_mi {$$ = $1;}
1243 qvarop_mi : QVAROP {$$ = $1;}
1244 | '`' QVARID '`' {$$ = gc3($2);}
1245 | varop_mi {$$ = $1;}
1248 conop : CONOP {$$ = $1;}
1249 | '`' CONID '`' {$$ = gc3($2);}
1251 qconop : QCONOP {$$ = $1;}
1252 | '`' QCONID '`' {$$ = gc3($2);}
1255 op : varop {$$ = $1;}
1258 qop : qvarop {$$ = $1;}
1262 /*- Stuff from STG hugs ---------------------------------------------------*/
1264 qvarid : varid1 {$$ = gc1($1);}
1265 | QVARID {$$ = gc1($1);}
1267 varid1 : VARID {$$ = gc1($1);}
1268 | HIDING {$$ = gc1(varHiding);}
1269 | QUALIFIED {$$ = gc1(varQualified);}
1270 | ASMOD {$$ = gc1(varAsMod);}
1271 | PRIVILEGED {$$ = gc1(varPrivileged);}
1274 /*- Tricks to force insertion of leading and closing braces ---------------*/
1276 begin : error {yyerrok;
1277 if (offsideON) goOffside(startColumn);}
1280 end : '}' {$$ = $1;}
1282 if (offsideON && canUnOffside()) {
1284 /* insert extra token on stack*/
1286 pushed(0) = pushed(1);
1287 pushed(1) = mkInt(column);
1290 syntaxError("definition");
1294 /*-------------------------------------------------------------------------*/
1298 static Cell local gcShadow(n,e) /* keep parsed fragments on stack */
1301 /* If a look ahead token is held then the required stack transformation
1304 * x1 | ... | xn | la ===> e | la
1307 * Otherwise, the transformation is:
1309 * x1 | ... | xn ===> e
1313 pushed(n-1) = top();
1322 static Void local syntaxError(s) /* report on syntax error */
1324 ERRMSG(row) "Syntax error in %s (unexpected %s)", s, unexpected()
1328 static String local unexpected() { /* find name for unexpected token */
1329 static char buffer[100];
1330 static char *fmt = "%s \"%s\"";
1331 static char *kwd = "keyword";
1334 case 0 : return "end of input";
1336 #define keyword(kw) sprintf(buffer,fmt,kwd,kw); return buffer;
1337 case INFIXL : keyword("infixl");
1338 case INFIXR : keyword("infixr");
1339 case INFIXN : keyword("infix");
1340 case FOREIGN : keyword("foreign");
1341 case UNSAFE : keyword("unsafe");
1342 case TINSTANCE : keyword("instance");
1343 case TCLASS : keyword("class");
1344 case CASEXP : keyword("case");
1345 case OF : keyword("of");
1346 case IF : keyword("if");
1347 case THEN : keyword("then");
1348 case ELSE : keyword("else");
1349 case WHERE : keyword("where");
1350 case TYPE : keyword("type");
1351 case DATA : keyword("data");
1352 case TNEWTYPE : keyword("newtype");
1353 case LET : keyword("let");
1354 case IN : keyword("in");
1355 case DERIVING : keyword("deriving");
1356 case DEFAULT : keyword("default");
1357 case IMPORT : keyword("import");
1358 case TMODULE : keyword("module");
1359 /* AJG: Hugs98/Classic use the keyword forall
1360 rather than __forall.
1361 Agree on one or the other
1363 case ALL : keyword("__forall");
1365 case DLET : keyword("dlet");
1366 case WITH : keyword("with");
1370 case ARROW : return "`->'";
1371 case '=' : return "`='";
1372 case COCO : return "`::'";
1373 case '-' : return "`-'";
1374 case '!' : return "`!'";
1375 case ',' : return "comma";
1376 case '@' : return "`@'";
1377 case '(' : return "`('";
1378 case ')' : return "`)'";
1379 case '{' : return "`{', possibly due to bad layout";
1380 case '}' : return "`}', possibly due to bad layout";
1381 case '_' : return "`_'";
1382 case '|' : return "`|'";
1383 case '.' : return "`.'";
1384 case ';' : return "`;', possibly due to bad layout";
1385 case UPTO : return "`..'";
1386 case '[' : return "`['";
1387 case ']' : return "`]'";
1388 case FROM : return "`<-'";
1389 case '\\' : return "backslash (lambda)";
1390 case '~' : return "tilde";
1391 case '`' : return "backquote";
1393 case RECSELID : sprintf(buffer,"selector \"#%s\"",
1394 textToStr(extText(snd(yylval))));
1398 case IPVARID : sprintf(buffer,"implicit parameter \"?%s\"",
1399 textToStr(textOf(yylval)));
1405 case CONID : sprintf(buffer,"symbol \"%s\"",
1406 textToStr(textOf(yylval)));
1411 case QCONID : sprintf(buffer,"symbol \"%s\"",
1412 identToStr(yylval));
1414 case HIDING : return "symbol \"hiding\"";
1415 case QUALIFIED : return "symbol \"qualified\"";
1416 case PRIVILEGED : return "symbol \"privileged\"";
1417 case ASMOD : return "symbol \"as\"";
1418 case NUMLIT : return "numeric literal";
1419 case CHARLIT : return "character literal";
1420 case STRINGLIT : return "string literal";
1421 case IMPLIES : return "`=>'";
1422 default : return "token";
1426 static Cell local checkPrec(p) /* Check for valid precedence value*/
1428 if (!isInt(p) || intOf(p)<MIN_PREC || intOf(p)>MAX_PREC) {
1429 ERRMSG(row) "Precedence value must be an integer in the range [%d..%d]",
1436 static Cell local buildTuple(tup) /* build tuple (x1,...,xn) from */
1437 List tup; { /* list [xn,...,x1] */
1443 x = fst(t); /* / \ / \ */
1444 fst(t) = snd(t); /* xn . . xn */
1445 snd(t) = x; /* . ===> . */
1447 t = fun(x); /* . . */
1449 } while (nonNull(t)); /* x1 NIL (n) x1 */
1450 fst(x) = mkTuple(n);
1454 static List local checkCtxt(con) /* validate context */
1456 mapOver(checkPred, con);
1460 static Cell local checkPred(c) /* check that type expr is a valid */
1461 Cell c; { /* constraint */
1462 Cell cn = getHead(c);
1464 if (isExt(cn) && argCount==1)
1471 if (!isQCon(cn) /*|| argCount==0*/)
1472 syntaxError("class expression");
1476 static Pair local checkDo(dqs) /* convert reversed list of dquals */
1477 List dqs; { /* to an (expr,quals) pair */
1478 if (isNull(dqs) || whatIs(hd(dqs))!=DOQUAL) {
1479 ERRMSG(row) "Last generator in do {...} must be an expression"
1482 fst(dqs) = snd(fst(dqs)); /* put expression in fst of pair */
1483 snd(dqs) = rev(snd(dqs)); /* & reversed list of quals in snd */
1487 static Cell local checkTyLhs(c) /* check that lhs is of the form */
1488 Cell c; { /* T a1 ... a */
1490 while (isAp(tlhs) && whatIs(arg(tlhs))==VARIDCELL) {
1493 if (whatIs(tlhs)!=CONIDCELL) {
1494 ERRMSG(row) "Illegal left hand side in datatype definition"
1502 static Void local noTREX(where)
1504 ERRMSG(row) "Attempt to use TREX records while parsing %s.\n", where ETHEN
1505 ERRTEXT "(TREX is disabled in this build of Hugs)"
1510 static Void local noIP(where)
1512 ERRMSG(row) "Attempt to use Implicit Parameters while parsing %s.\n", where ETHEN
1513 ERRTEXT "(Implicit Parameters are disabled in this build of Hugs)"
1518 /*-------------------------------------------------------------------------*/