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/03/13 11:37:16 $
17 * ------------------------------------------------------------------------*/
23 #define defTycon(n,l,lhs,rhs,w) tyconDefn(intOf(l),lhs,rhs,w); sp-=n
24 #define sigdecl(l,vs,t) ap(SIGDECL,triple(l,vs,t))
25 #define fixdecl(l,ops,a,p) ap(FIXDECL,\
26 triple(l,ops,mkInt(mkSyntax(a,intOf(p)))))
27 #define grded(gs) ap(GUARDED,gs)
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, \
32 mkCon(module(currentModule).text)))
33 #define yyerror(s) /* errors handled elsewhere */
36 static Cell local gcShadow ( Int,Cell );
37 static Void local syntaxError ( String );
38 static String local unexpected ( Void );
39 static Cell local checkPrec ( Cell );
40 static Void local fixDefn ( Syntax,Cell,Cell,List );
41 static Cell local buildTuple ( List );
42 static List local checkCtxt ( List );
43 static Cell local checkPred ( Cell );
44 static Pair local checkDo ( List );
45 static Cell local checkTyLhs ( Cell );
47 static Void local noTREX ( String );
50 static Void local noIP ( String );
53 /* For the purposes of reasonably portable garbage collection, it is
54 * necessary to simulate the YACC stack on the Hugs stack to keep
55 * track of all intermediate constructs. The lexical analyser
56 * pushes a token onto the stack for each token that is found, with
57 * these elements being removed as reduce actions are performed,
58 * taking account of look-ahead tokens as described by gcShadow()
61 * Of the non-terminals used below, only start, topDecl & begin
62 * do not leave any values on the Hugs stack. The same is true for the
63 * terminals EXPR and SCRIPT. At the end of a successful parse, there
64 * should only be one element left on the stack, containing the result
68 #define gc0(e) gcShadow(0,e)
69 #define gc1(e) gcShadow(1,e)
70 #define gc2(e) gcShadow(2,e)
71 #define gc3(e) gcShadow(3,e)
72 #define gc4(e) gcShadow(4,e)
73 #define gc5(e) gcShadow(5,e)
74 #define gc6(e) gcShadow(6,e)
75 #define gc7(e) gcShadow(7,e)
79 %token EXPR CONTEXT SCRIPT
80 %token CASEXP OF DATA TYPE IF
81 %token THEN ELSE WHERE LET IN
82 %token INFIXN INFIXL INFIXR FOREIGN TNEWTYPE
83 %token DEFAULT DERIVING DO TCLASS TINSTANCE
87 %token REPEAT ALL NUMLIT CHARLIT STRINGLIT
88 %token VAROP VARID CONOP CONID
89 %token QVAROP QVARID QCONOP QCONID
91 %token RECSELID IPVARID
93 %token COCO '=' UPTO '@' '\\'
94 %token '|' '-' FROM ARROW '~'
95 %token '!' IMPLIES '(' ',' ')'
96 %token '[' ';' ']' '`' '.'
97 %token TMODULE IMPORT HIDING QUALIFIED ASMOD
98 %token EXPORT UUEXPORT INTERFACE REQUIRES UNSAFE
99 %token INSTIMPORT DYNAMIC CCALL STDKALL
100 %token UTL UTR UUUSAGE
104 /*- Top level script/module structure -------------------------------------*/
106 start : EXPR exp wherePart {inputExpr = letrec($3,$2); sp-=2;}
107 | CONTEXT context {inputContext = $2; sp-=1;}
108 | SCRIPT topModule {valDefns = $2; sp-=1;}
109 | INTERFACE iface {sp-=1;}
110 | error {syntaxError("input");}
114 /*- GHC interface file parsing: -------------------------------------------*/
116 /* Reading in an interface file is surprisingly like reading
117 * a normal Haskell module: we read in a bunch of declarations,
118 * construct symbol table entries, etc. The "only" differences
119 * are that there's no syntactic sugar to deal with and we don't
120 * have to read in expressions.
123 /*- Top-level interface files -----------------------------*/
124 iface : INTERFACE ifCon NUMLIT ifOrphans ifCheckVersion WHERE ifTopDecls
125 {$$ = gc7(ap(I_INTERFACE,
127 | INTERFACE error {syntaxError("interface file");}
130 ifTopDecls: {$$=gc0(NIL);}
131 | ifTopDecl ';' ifTopDecls {$$=gc3(cons($1,$3));}
135 : IMPORT CONID NUMLIT ifOrphans ifOptCOCO ifVersionList
136 {$$=gc6(ap(I_IMPORT,zpair($2,$6))); }
138 | INSTIMPORT CONID {$$=gc2(ap(I_INSTIMPORT,NIL));}
140 | UUEXPORT CONID ifEntities {$$=gc3(ap(I_EXPORT,zpair($2,$3)));}
142 | NUMLIT INFIXL optDigit ifVarCon
143 {$$=gc4(ap(I_FIXDECL,
144 ztriple($3,mkInt(LEFT_ASS),$4)));}
145 | NUMLIT INFIXR optDigit ifVarCon
146 {$$=gc4(ap(I_FIXDECL,
147 ztriple($3,mkInt(RIGHT_ASS),$4)));}
148 | NUMLIT INFIXN optDigit ifVarCon
149 {$$=gc4(ap(I_FIXDECL,
150 ztriple($3,mkInt(NON_ASS),$4)));}
152 | TINSTANCE ifCtxInst ifInstHdL '=' ifVar
153 {$$=gc5(ap(I_INSTANCE,
154 z5ble($1,$2,$3,$5,NIL)));}
156 | NUMLIT TYPE ifCon ifKindedTyvarL '=' ifType
158 z4ble($2,$3,$4,$6)));}
160 | NUMLIT DATA ifCtxDecl ifConData ifKindedTyvarL ifConstrs
162 z5ble($2,$3,$4,$5,$6)));}
164 | NUMLIT TNEWTYPE ifCtxDecl ifConData ifKindedTyvarL ifNewTypeConstr
165 {$$=gc6(ap(I_NEWTYPE,
166 z5ble($2,$3,$4,$5,$6)));}
168 | NUMLIT TCLASS ifCtxDecl ifCon ifKindedTyvar ifCmeths
171 singleton($5),$6)));}
173 | NUMLIT ifVar COCO ifType
175 ztriple($3,$2,$4)));}
177 | error { syntaxError(
178 "interface declaration"); }
182 /*- Top-level misc interface stuff ------------------------*/
183 ifOrphans : '!' {$$=gc1(NIL);}
186 ifOptCOCO : COCO {$$=gc1(NIL);}
190 : NUMLIT {$$ = gc1(NIL); }
195 /*- Interface variable and constructor ids ----------------*/
196 ifTyvar : VARID {$$ = $1;}
198 ifVar : VARID {$$ = gc1($1);}
200 ifCon : CONID {$$ = gc1($1);}
203 ifVarCon : VARID {$$ = gc1($1);}
204 | CONID {$$ = gc1($1);}
207 ifQCon : CONID {$$ = gc1($1);}
208 | QCONID {$$ = gc1($1);}
210 ifConData : ifCon {$$ = gc1($1);}
211 | '(' ')' {$$ = gc2(typeUnit);}
212 | '[' ']' {$$ = gc2(typeList);}
213 | '(' ARROW ')' {$$ = gc3(typeArrow);}
215 ifTCName : CONID { $$ = gc1($1); }
216 | CONOP { $$ = gc1($1); }
217 | '(' ARROW ')' { $$ = gc3(typeArrow); }
218 | '[' ']' { $$ = gc1(typeList); }
220 ifQTCName : ifTCName { $$ = gc1($1); }
221 | QCONID { $$ = gc1($1); }
222 | QCONOP { $$ = gc1($1); }
226 /*- Interface contexts ------------------------------------*/
227 ifCtxInst /* __forall [a b] => :: [((VarId,Kind))] */
228 : ALL ifForall IMPLIES {$$=gc3($2);}
231 ifInstHd /* { Class aType } :: ((ConId, Type)) */
232 : '{' ifQCon ifAType '}' {$$=gc4(ap(DICTAP,
236 ifInstHdL /* { C a1 } -> { C2 a2 } -> ... -> { Cn an } :: Type */
237 : ifInstHd ARROW ifInstHdL {$$=gc3(ap($1,$3));}
238 | ifInstHd {$$=gc1($1);}
241 ifCtxDecl /* {M.C1 a, C2 b} => :: [(QConId, VarId)] */
242 : ifCtxDeclT IMPLIES { $$ = gc2($1); }
245 ifCtxDeclT /* {M.C1 a, C2 b} :: [(QConId, VarId)] */
247 | '{' ifCtxDeclL '}' { $$ = gc3($2); }
250 ifCtxDeclL /* M.C1 a, C2 b :: [(QConId, VarId)] */
251 : ifCtxDeclLE ',' ifCtxDeclL {$$=gc3(cons($1,$3));}
252 | ifCtxDeclLE {$$=gc1(cons($1,NIL));}
255 ifCtxDeclLE /* M.C1 a :: (QConId,VarId) */
256 : ifQCon ifTyvar {$$=gc2(zpair($1,$2));}
260 /*- Interface data declarations - constructor lists -------*/
261 /* The (Type,VarId,Int) are (field type, name (or NIL), strictness).
262 Strictness is a number: mkInt(0) indicates lazy, mkInt(1)
263 indicates a strict field (!type) as in standard H98, and
264 mkInt(2) indicates unpacked -- a GHC extension.
267 ifConstrs /* = Con1 | ... | ConN :: [((ConId,[((Type,VarId,Int))]))] */
269 | '=' ifConstrL {$$ = gc2($2);}
271 ifConstrL /* [((ConId,[((Type,VarId,Int))]))] */
272 : ifConstr {$$ = gc1(singleton($1));}
273 | ifConstr '|' ifConstrL {$$ = gc3(cons($1,$3));}
275 ifConstr /* ((ConId,[((Type,VarId,Int))])) */
276 : ifConData ifDataAnonFieldL {$$ = gc2(zpair($1,$2));}
277 | ifConData '{' ifDataNamedFieldL '}'
278 {$$ = gc4(zpair($1,$3));}
280 ifDataAnonFieldL /* [((Type,VarId,Int))] */
282 | ifDataAnonField ifDataAnonFieldL
283 {$$=gc2(cons($1,$2));}
285 ifDataNamedFieldL /* [((Type,VarId,Int))] */
287 | ifDataNamedField {$$=gc1(cons($1,NIL));}
288 | ifDataNamedField ',' ifDataNamedFieldL
289 {$$=gc3(cons($1,$3));}
291 ifDataAnonField /* ((Type,VarId,Int)) */
292 : ifAType {$$=gc1(ztriple($1,NIL,mkInt(0)));}
293 | '!' ifAType {$$=gc2(ztriple($2,NIL,mkInt(1)));}
294 | '!' '!' ifAType {$$=gc3(ztriple($3,NIL,mkInt(2)));}
296 ifDataNamedField /* ((Type,VarId,Int)) */
297 : ifVar COCO ifAType {$$=gc3(ztriple($3,$1,mkInt(0)));}
298 | ifVar COCO '!' ifAType {$$=gc4(ztriple($4,$1,mkInt(1)));}
299 | ifVar COCO '!' '!' ifAType {$$=gc5(ztriple($5,$1,mkInt(2)));}
303 /*- Interface class declarations - methods ----------------*/
304 ifCmeths /* [((VarId,Type))] */
306 | WHERE '{' ifCmethL '}' { $$ = gc4($3); }
308 ifCmethL /* [((VarId,Type))] */
309 : ifCmeth { $$ = gc1(singleton($1)); }
310 | ifCmeth ';' ifCmethL { $$ = gc3(cons($1,$3)); }
312 ifCmeth /* ((VarId,Type)) */
313 : ifVar COCO ifType { $$ = gc3(zpair($1,$3)); }
314 | ifVar '=' COCO ifType { $$ = gc4(zpair($1,$4)); }
315 /* has default method */
319 /*- Interface newtype declararions ------------------------*/
320 ifNewTypeConstr /* ((ConId,Type)) */
321 : '=' ifCon ifAType { $$ = gc3(zpair($2,$3)); }
325 /*- Interface type expressions ----------------------------*/
326 ifType : ALL ifForall ifCtxDeclT IMPLIES ifType
329 $$=gc5(pair(QUAL,pair($3,$5)));
331 | ifBType ARROW ifType { $$ = gc3(fn($1,$3)); }
332 | ifBType { $$ = gc1($1); }
334 ifForall /* [((VarId,Kind))] */
335 : '[' ifKindedTyvarL ']' { $$ = gc3($2); }
338 ifTypeL2 /* [Type], 2 or more */
339 : ifType ',' ifType { $$ = gc3(doubleton($1,$3)); }
340 | ifType ',' ifTypeL2 { $$ = gc3(cons($1,$3)); }
343 ifTypeL /* [Type], 0 or more */
344 : ifType ',' ifTypeL { $$ = gc3(cons($1,$3)); }
345 | ifType { $$ = gc1(singleton($1)); }
349 ifBType : ifAType { $$ = gc1($1); }
350 | ifBType ifAType { $$ = gc2(ap($1,$2)); }
351 | UUUSAGE ifUsage ifAType { $$ = gc3($3); }
354 ifAType : ifQTCName { $$ = gc1($1); }
355 | ifTyvar { $$ = gc1($1); }
356 | '(' ')' { $$ = gc2(typeUnit); }
357 | '(' ifTypeL2 ')' { $$ = gc3(buildTuple(reverse($2))); }
358 | '[' ifType ']' { $$ = gc3(ap(mkCon(tycon(typeList).text),
360 | '{' ifQTCName ifAType '}' { $$ = gc4(ap(DICTAP,
362 | '(' ifType ')' { $$ = gc3($2); }
363 | UTL ifTypeL UTR { $$ = gc3(ap(UNBOXEDTUP,$2)); }
367 /*- KW's usage stuff --------------------------------------*/
368 ifUsage : '-' { $$ = gc1(NIL); }
369 | '!' { $$ = gc1(NIL); }
370 | ifVar { $$ = gc1(NIL); }
374 /*- Interface kinds ---------------------------------------*/
375 ifKindedTyvarL /* [((VarId,Kind))] */
377 | ifKindedTyvar ifKindedTyvarL { $$ = gc2(cons($1,$2)); }
379 ifKindedTyvar /* ((VarId,Kind)) */
380 : ifTyvar { $$ = gc1(zpair($1,STAR)); }
381 | ifTyvar COCO ifAKind { $$ = gc3(zpair($1,$3)); }
383 ifKind : ifAKind { $$ = gc1($1); }
384 | ifAKind ARROW ifKind { $$ = gc3(ap($1,$3)); }
386 ifAKind : VAROP { $$ = gc1(STAR); }
388 | '(' ifKind ')' { $$ = gc3($2); }
392 /*- Interface version/export/import stuff -----------------*/
395 | ifEntity ifEntities { $$ = gc2(cons($1,$2)); }
398 : ifEntityOcc {$$=gc1($1);}
399 | ifEntityOcc ifStuffInside {$$=gc2(zpair($1,$2));}
402 : ifVar { $$ = gc1($1); }
403 | ifCon { $$ = gc1($1); }
404 | ARROW { $$ = gc1(typeArrow); }
405 | '(' ARROW ')' { $$ = gc3(typeArrow); }
406 /* why allow both? */
409 : '{' ifValOccs '}' { $$ = gc3($2); }
413 | ifVar ifValOccs { $$ = gc2(cons($1,$2)); }
414 | ifCon ifValOccs { $$ = gc2(cons($1,$2)); }
419 | VARID NUMLIT ifVersionList {$$=gc3(cons($1,$3));}
420 | CONID NUMLIT ifVersionList {$$=gc3(cons($1,$3));}
424 /*- Haskell module header/import parsing: -----------------------------------
425 * Syntax for Haskell modules (module headers and imports) is parsed but
426 * most of it is ignored. However, module names in import declarations
427 * are used, of course, if import chasing is turned on.
428 *-------------------------------------------------------------------------*/
430 /* In Haskell 1.2, the default module header was "module Main where"
431 * In 1.3, this changed to "module Main(main) where".
432 * We use the 1.2 header because it breaks much less pre-module code.
434 topModule : startMain begin modBody end {
435 setExportList(singleton(
437 mkCon(module(currentModule).text)
441 | TMODULE modname expspec WHERE '{' modBody end
442 {setExportList($3); $$ = gc7($6);}
443 | TMODULE error {syntaxError("module definition");}
445 /* To implement the Haskell module system, we have to keep track of the
446 * current module. We rely on the use of LALR parsing to ensure that this
447 * side effect happens before any declarations within the module.
449 startMain : /* empty */ {startModule(conMain);
452 modname : CONID {startModule($1); $$ = gc1(NIL);}
454 modid : CONID {$$ = $1;}
455 | STRINGLIT { extern String scriptFile;
457 = findPathname(scriptFile,
458 textToStr(textOf($1)));
460 /* fillin pathname if known */
461 $$ = mkStr(findText(modName));
467 modBody : topDecls {$$ = $1;}
468 | impDecls chase {$$ = gc2(NIL);}
469 | impDecls ';' chase topDecls {$$ = gc4($4);}
472 /*- Exports: --------------------------------------------------------------*/
474 expspec : /* empty */ {$$ = gc0(exportSelf());}
475 | '(' ')' {$$ = gc2(NIL);}
476 | '(' exports ')' {$$ = gc3($2);}
477 | '(' exports ',' ')' {$$ = gc4($2);}
479 exports : exports ',' export {$$ = gc3(cons($3,$1));}
480 | export {$$ = gc1(singleton($1));}
482 /* The qcon should be qconid.
483 * Relaxing the rule lets us explicitly export (:) from the Prelude.
485 export : qvar {$$ = $1;}
487 | qconid '(' UPTO ')' {$$ = gc4(pair($1,DOTDOT));}
488 | qconid '(' qnames ')' {$$ = gc4(pair($1,$3));}
489 | TMODULE modid {$$ = gc2(ap(MODULEENT,$2));}
491 qnames : /* empty */ {$$ = gc0(NIL);}
492 | ',' {$$ = gc1(NIL);}
494 | qnames1 ',' {$$ = gc2($1);}
496 qnames1 : qnames1 ',' qname {$$ = gc3(cons($3,$1));}
497 | qname {$$ = gc1(singleton($1));}
499 qname : qvar {$$ = $1;}
503 /*- Import declarations: --------------------------------------------------*/
505 impDecls : impDecls ';' impDecl {imps = cons($3,imps); $$=gc3(NIL);}
506 | impDecl {imps = singleton($1); $$=gc1(NIL);}
508 chase : /* empty */ {if (chase(imps)) {
518 /* Note that qualified import ignores the import list. */
519 impDecl : IMPORT modid impspec {addQualImport($2,$2);
520 addUnqualImport($2,$3);
522 | IMPORT modid ASMOD modid impspec
523 {addQualImport($2,$4);
524 addUnqualImport($2,$5);
526 | IMPORT QUALIFIED modid ASMOD modid impspec
527 {addQualImport($3,$5);
529 | IMPORT QUALIFIED modid impspec
530 {addQualImport($3,$3);
532 | IMPORT PRIVILEGED modid '(' imports ')'
533 {addUnqualImport($3,ap(STAR,$5));
535 | IMPORT error {syntaxError("import declaration");}
537 impspec : /* empty */ {$$ = gc0(DOTDOT);}
538 | HIDING '(' imports ')' {$$ = gc4(ap(HIDDEN,$3));}
539 | '(' imports ')' {$$ = gc3($2);}
541 imports : /* empty */ {$$ = gc0(NIL);}
542 | ',' {$$ = gc1(NIL);}
543 | imports1 {$$ = $1;}
544 | imports1 ',' {$$ = gc2($1);}
546 imports1 : imports1 ',' import {$$ = gc3(cons($3,$1));}
547 | import {$$ = gc1(singleton($1));}
549 import : var {$$ = $1;}
551 | CONID '(' UPTO ')' {$$ = gc4(pair($1,DOTDOT));}
552 | CONID '(' names ')' {$$ = gc4(pair($1,$3));}
554 names : /* empty */ {$$ = gc0(NIL);}
555 | ',' {$$ = gc1(NIL);}
557 | names1 ',' {$$ = gc2($1);}
559 names1 : names1 ',' name {$$ = gc3(cons($3,$1));}
560 | name {$$ = gc1(singleton($1));}
562 name : var {$$ = $1;}
566 /*- Top-level declarations: -----------------------------------------------*/
568 topDecls : /* empty */ {$$ = gc0(NIL);}
569 | ';' {$$ = gc1(NIL);}
570 | topDecls1 {$$ = $1;}
571 | topDecls1 ';' {$$ = gc2($1);}
573 topDecls1 : topDecls1 ';' topDecl {$$ = gc2($1);}
574 | topDecls1 ';' decl {$$ = gc3(cons($3,$1));}
575 | topDecl {$$ = gc0(NIL);}
576 | decl {$$ = gc1(cons($1,NIL));}
579 /*- Type declarations: ----------------------------------------------------*/
581 topDecl : TYPE tyLhs '=' type {defTycon(4,$3,$2,$4,SYNONYM);}
582 | TYPE tyLhs '=' type IN invars
584 ap($4,$6),RESTRICTSYN);}
585 | TYPE error {syntaxError("type definition");}
586 | DATA btype2 '=' constrs deriving
587 {defTycon(5,$3,checkTyLhs($2),
588 ap(rev($4),$5),DATATYPE);}
589 | DATA context IMPLIES tyLhs '=' constrs deriving
591 ap(qualify($2,rev($6)),
593 | DATA btype2 {defTycon(2,$1,checkTyLhs($2),
594 ap(NIL,NIL),DATATYPE);}
595 | DATA context IMPLIES tyLhs {defTycon(4,$1,$4,
598 | DATA error {syntaxError("data definition");}
599 | TNEWTYPE btype2 '=' nconstr deriving
600 {defTycon(5,$3,checkTyLhs($2),
602 | TNEWTYPE context IMPLIES tyLhs '=' nconstr deriving
606 | TNEWTYPE error {syntaxError("newtype definition");}
608 tyLhs : tyLhs varid {$$ = gc2(ap($1,$2));}
610 | error {syntaxError("type defn lhs");}
612 invars : invars ',' invar {$$ = gc3(cons($3,$1));}
613 | invar {$$ = gc1(cons($1,NIL));}
615 invar : var COCO topType {$$ = gc3(sigdecl($2,singleton($1),
619 constrs : constrs '|' pconstr {$$ = gc3(cons($3,$1));}
620 | pconstr {$$ = gc1(cons($1,NIL));}
622 pconstr : ALL varids '.' qconstr {$$ = gc4(ap(POLYTYPE,
626 qconstr : context IMPLIES constr {$$ = gc3(qualify($1,$3));}
629 constr : '!' btype conop bbtype {$$ = gc4(ap(ap($3,bang($2)),$4));}
630 | btype1 conop bbtype {$$ = gc3(ap(ap($2,$1),$3));}
631 | btype2 conop bbtype {$$ = gc3(ap(ap($2,$1),$3));}
632 | bpolyType conop bbtype {$$ = gc3(ap(ap($2,$1),$3));}
636 | con '{' fieldspecs '}' {$$ = gc4(ap(LABC,pair($1,rev($3))));}
637 | con '{' '}' {$$ = gc3(ap(LABC,pair($1,NIL)));}
638 | error {syntaxError("data type definition");}
640 btype3 : btype2 '!' atype {$$ = gc3(ap($1,bang($3)));}
641 | btype3 '!' atype {$$ = gc3(ap($1,bang($3)));}
642 | btype3 atype {$$ = gc2(ap($1,$2));}
644 btype4 : btype2 bpolyType {$$ = gc2(ap($1,$2));}
645 | btype3 bpolyType {$$ = gc2(ap($1,$2));}
646 | btype4 bpolyType {$$ = gc2(ap($1,$2));}
647 | btype4 atype {$$ = gc2(ap($1,$2));}
648 | btype4 '!' atype {$$ = gc3(ap($1,bang($3)));}
650 bbtype : '!' btype {$$ = gc2(bang($2));}
652 | bpolyType {$$ = $1;}
654 nconstr : pconstr {$$ = gc1(singleton($1));}
656 fieldspecs: fieldspecs ',' fieldspec {$$ = gc3(cons($3,$1));}
657 | fieldspec {$$ = gc1(cons($1,NIL));}
659 fieldspec : vars COCO polyType {$$ = gc3(pair(rev($1),$3));}
660 | vars COCO type {$$ = gc3(pair(rev($1),$3));}
661 | vars COCO '!' type {$$ = gc4(pair(rev($1),bang($4)));}
663 deriving : /* empty */ {$$ = gc0(NIL);}
664 | DERIVING qconid {$$ = gc2(singleton($2));}
665 | DERIVING '(' derivs0 ')' {$$ = gc4($3);}
667 derivs0 : /* empty */ {$$ = gc0(NIL);}
668 | derivs {$$ = gc1(rev($1));}
670 derivs : derivs ',' qconid {$$ = gc3(cons($3,$1));}
671 | qconid {$$ = gc1(singleton($1));}
674 /*- Processing definitions of primitives ----------------------------------*/
676 topDecl : FOREIGN IMPORT callconv DYNAMIC unsafe_flag var COCO type
677 {foreignImport($1,$3,NIL,$6,$8); sp-=8;}
678 | FOREIGN IMPORT callconv ext_loc ext_name unsafe_flag var COCO type
679 {foreignImport($1,$3,pair($4,$5),$7,$9); sp-=9;}
680 | FOREIGN EXPORT callconv DYNAMIC qvarid COCO type
681 {foreignExport($1,$3,$4,$5,$7); sp-=7;}
684 callconv : CCALL {$$ = gc1(textCcall);}
685 | STDKALL {$$ = gc1(textStdcall);}
686 | /* empty */ {$$ = gc0(NIL);}
688 ext_loc : STRINGLIT {$$ = $1;}
690 ext_name : STRINGLIT {$$ = $1;}
692 unsafe_flag: /* empty */ {$$ = gc0(NIL);}
693 | UNSAFE {$$ = gc1(NIL); /* ignored */ }
697 /*- Class declarations: ---------------------------------------------------*/
699 topDecl : TCLASS crule fds wherePart {classDefn(intOf($1),$2,$4,$3); sp-=4;}
700 | TINSTANCE irule wherePart {instDefn(intOf($1),$2,$3); sp-=3;}
701 | DEFAULT '(' dtypes ')' {defaultDefn(intOf($1),$3); sp-=4;}
702 | TCLASS error {syntaxError("class declaration");}
703 | TINSTANCE error {syntaxError("instance declaration");}
704 | DEFAULT error {syntaxError("default declaration");}
706 crule : context IMPLIES btype2 {$$ = gc3(pair($1,checkPred($3)));}
707 | btype2 {$$ = gc1(pair(NIL,checkPred($1)));}
709 irule : context IMPLIES btype2 {$$ = gc3(pair($1,checkPred($3)));}
710 | btype2 {$$ = gc1(pair(NIL,checkPred($1)));}
712 dtypes : /* empty */ {$$ = gc0(NIL);}
713 | dtypes1 {$$ = gc1(rev($1));}
715 dtypes1 : dtypes1 ',' type {$$ = gc3(cons($3,$1));}
716 | type {$$ = gc1(cons($1,NIL));}
719 fds : /* empty */ {$$ = gc0(NIL);}
720 | '|' fds1 {h98DoesntSupport(row,"dependent parameters");
723 fds1 : fds1 ',' fd {$$ = gc3(cons($3,$1));}
724 | fd {$$ = gc1(cons($1,NIL));}
727 fd : varids0 ARROW varids0 {$$ = gc3(pair(rev($1),rev($3)));}
729 varids0 : /* empty */ {$$ = gc0(NIL);}
730 | varids0 varid {$$ = gc2(cons($2,$1));}
733 /*- Type expressions: -----------------------------------------------------*/
735 topType : ALL varids '.' topType0 {$$ = gc4(ap(POLYTYPE,
737 | topType0 {$$ = $1;}
739 topType0 : context IMPLIES topType1 {$$ = gc3(qualify($1,$3));}
740 | topType1 {$$ = $1;}
742 topType1 : bpolyType ARROW topType1 {$$ = gc3(fn($1,$3));}
743 | btype1 ARROW topType1 {$$ = gc3(fn($1,$3));}
744 | btype2 ARROW topType1 {$$ = gc3(fn($1,$3));}
747 polyType : ALL varids '.' sigType {$$ = gc4(ap(POLYTYPE,
749 | context IMPLIES type {$$ = gc3(qualify($1,$3));}
750 | bpolyType {$$ = $1;}
752 bpolyType : '(' polyType ')' {$$ = gc3($2);}
754 varids : varids varid {$$ = gc2(cons($2,$1));}
755 | varid {$$ = gc1(singleton($1));}
757 sigType : context IMPLIES type {$$ = gc3(qualify($1,$3));}
760 context : '(' ')' {$$ = gc2(NIL);}
761 | btype2 {$$ = gc1(singleton(checkPred($1)));}
762 | '(' btype2 ')' {$$ = gc3(singleton(checkPred($2)));}
763 | '(' btypes2 ')' {$$ = gc3(checkCtxt(rev($2)));}
765 | lacks {$$ = gc1(singleton($1));}
766 | '(' lacks1 ')' {$$ = gc3(checkCtxt(rev($2)));}
768 lacks : varid '\\' varid {
770 $$ = gc3(ap(mkExt(textOf($3)),$1));
772 noTREX("a type context");
775 | IPVARID COCO type {
777 $$ = gc3(pair(mkIParam($1),$3));
779 noIP("a type context");
783 lacks1 : btypes2 ',' lacks {$$ = gc3(cons($3,$1));}
784 | lacks1 ',' btype2 {$$ = gc3(cons($3,$1));}
785 | lacks1 ',' lacks {$$ = gc3(cons($3,$1));}
786 | btype2 ',' lacks {$$ = gc3(cons($3,cons($1,NIL)));}
787 | lacks {$$ = gc1(singleton($1));}
791 type : type1 {$$ = $1;}
794 type1 : btype1 {$$ = $1;}
795 | btype1 ARROW type {$$ = gc3(fn($1,$3));}
796 | btype2 ARROW type {$$ = gc3(fn($1,$3));}
797 | error {syntaxError("type expression");}
799 btype : btype1 {$$ = $1;}
802 btype1 : btype1 atype {$$ = gc2(ap($1,$2));}
805 btype2 : btype2 atype {$$ = gc2(ap($1,$2));}
808 atype : atype1 {$$ = $1;}
811 atype1 : varid {$$ = $1;}
812 | '(' ')' {$$ = gc2(typeUnit);}
813 | '(' ARROW ')' {$$ = gc3(typeArrow);}
814 | '(' type1 ')' {$$ = gc3($2);}
815 | '(' btype2 ')' {$$ = gc3($2);}
816 | '(' tupCommas ')' {$$ = gc3($2);}
817 | '(' btypes2 ')' {$$ = gc3(buildTuple($2));}
818 | '(' typeTuple ')' {$$ = gc3(buildTuple($2));}
821 $$ = gc3(revOnto($2,typeNoRow));
826 | '(' tfields '|' type ')' {
828 $$ = gc5(revOnto($2,$4));
833 | '[' type ']' {$$ = gc3(ap(typeList,$2));}
834 | '[' ']' {$$ = gc2(typeList);}
835 | '_' {h98DoesntSupport(row,"anonymous type variables");
836 $$ = gc1(inventVar());}
838 btypes2 : btypes2 ',' btype2 {$$ = gc3(cons($3,$1));}
839 | btype2 ',' btype2 {$$ = gc3(cons($3,cons($1,NIL)));}
841 typeTuple : type1 ',' type {$$ = gc3(cons($3,cons($1,NIL)));}
842 | btype2 ',' type1 {$$ = gc3(cons($3,cons($1,NIL)));}
843 | btypes2 ',' type1 {$$ = gc3(cons($3,$1));}
844 | typeTuple ',' type {$$ = gc3(cons($3,$1));}
847 tfields : tfields ',' tfield {$$ = gc3(cons($3,$1));}
848 | tfield {$$ = gc1(singleton($1));}
850 tfield : varid COCO type {h98DoesntSupport(row,"extensible records");
851 $$ = gc3(ap(mkExt(textOf($1)),$3));}
855 /*- Value declarations: ---------------------------------------------------*/
857 gendecl : INFIXN optDigit ops {$$ = gc3(fixdecl($1,$3,NON_ASS,$2));}
858 | INFIXN error {syntaxError("fixity decl");}
859 | INFIXL optDigit ops {$$ = gc3(fixdecl($1,$3,LEFT_ASS,$2));}
860 | INFIXL error {syntaxError("fixity decl");}
861 | INFIXR optDigit ops {$$ = gc3(fixdecl($1,$3,RIGHT_ASS,$2));}
862 | INFIXR error {syntaxError("fixity decl");}
863 | vars COCO topType {$$ = gc3(sigdecl($2,$1,$3));}
864 | vars COCO error {syntaxError("type signature");}
866 optDigit : NUMLIT {$$ = gc1(checkPrec($1));}
867 | /* empty */ {$$ = gc0(mkInt(DEF_PREC));}
869 ops : ops ',' op {$$ = gc3(cons($3,$1));}
870 | op {$$ = gc1(singleton($1));}
872 vars : vars ',' var {$$ = gc3(cons($3,$1));}
873 | var {$$ = gc1(singleton($1));}
875 decls : '{' decls0 end {$$ = gc3($2);}
876 | '{' decls1 end {$$ = gc3($2);}
878 decls0 : /* empty */ {$$ = gc0(NIL);}
879 | decls0 ';' {$$ = gc2($1);}
880 | decls1 ';' {$$ = gc2($1);}
882 decls1 : decls0 decl {$$ = gc2(cons($2,$1));}
884 decl : gendecl {$$ = $1;}
885 | funlhs rhs {$$ = gc2(ap(FUNBIND,pair($1,$2)));}
886 | funlhs COCO type rhs {$$ = gc4(ap(FUNBIND,
889 | pat0 rhs {$$ = gc2(ap(PATBIND,pair($1,$2)));}
891 funlhs : funlhs0 {$$ = $1;}
895 funlhs0 : pat10_vI varop pat0 {$$ = gc3(ap2($2,$1,$3));}
896 | infixPat varop pat0 {$$ = gc3(ap2($2,$1,$3));}
897 | NUMLIT varop pat0 {$$ = gc3(ap2($2,$1,$3));}
898 | var varop_pl pat0 {$$ = gc3(ap2($2,$1,$3));}
899 | var '+' pat0_INT {$$ = gc3(ap2(varPlus,$1,$3));}
901 funlhs1 : '(' funlhs0 ')' apat {$$ = gc4(ap($2,$4));}
902 | '(' funlhs1 ')' apat {$$ = gc4(ap($2,$4));}
903 | '(' npk ')' apat {$$ = gc4(ap($2,$4));}
904 | var apat {$$ = gc2(ap($1,$2));}
905 | funlhs1 apat {$$ = gc2(ap($1,$2));}
907 rhs : rhs1 wherePart {$$ = gc2(letrec($2,$1));}
908 | error {syntaxError("declaration");}
910 rhs1 : '=' exp {$$ = gc2(pair($1,$2));}
911 | gdrhs {$$ = gc1(grded(rev($1)));}
913 gdrhs : gdrhs gddef {$$ = gc2(cons($2,$1));}
914 | gddef {$$ = gc1(singleton($1));}
916 gddef : '|' exp0 '=' exp {$$ = gc4(pair($3,pair($2,$4)));}
918 wherePart : /* empty */ {$$ = gc0(NIL);}
919 | WHERE decls {$$ = gc2($2);}
922 /*- Patterns: -------------------------------------------------------------*/
927 pat_npk : pat0 COCO type {$$ = gc3(ap(ESIGN,pair($1,$3)));}
930 npk : var '+' NUMLIT {$$ = gc3(ap2(varPlus,$1,$3));}
932 pat0 : var {$$ = $1;}
936 pat0_INT : var {$$ = $1;}
939 pat0_vI : pat10_vI {$$ = $1;}
940 | infixPat {$$ = gc1(ap(INFIX,$1));}
942 infixPat : '-' pat10 {$$ = gc2(ap(NEG,only($2)));}
943 | '-' error {syntaxError("pattern");}
944 | var qconop pat10 {$$ = gc3(ap(ap($2,only($1)),$3));}
945 | var qconop '-' pat10 {$$ = gc4(ap(NEG,ap2($2,only($1),$4)));}
946 | NUMLIT qconop pat10 {$$ = gc3(ap(ap($2,only($1)),$3));}
947 | NUMLIT qconop '-' pat10 {$$ = gc4(ap(NEG,ap2($2,only($1),$4)));}
948 | pat10_vI qconop pat10 {$$ = gc3(ap(ap($2,only($1)),$3));}
949 | pat10_vI qconop '-' pat10 {$$ = gc4(ap(NEG,ap2($2,only($1),$4)));}
950 | infixPat qconop pat10 {$$ = gc3(ap(ap($2,$1),$3));}
951 | infixPat qconop '-' pat10 {$$ = gc4(ap(NEG,ap(ap($2,$1),$4)));}
953 pat10 : fpat {$$ = $1;}
956 pat10_vI : fpat {$$ = $1;}
959 fpat : fpat apat {$$ = gc2(ap($1,$2));}
960 | gcon apat {$$ = gc2(ap($1,$2));}
962 apat : NUMLIT {$$ = $1;}
966 apat_vI : var '@' apat {$$ = gc3(ap(ASPAT,pair($1,$3)));}
968 | qcon '{' patbinds '}' {$$ = gc4(ap(CONFLDS,pair($1,$3)));}
970 | STRINGLIT {$$ = $1;}
971 | '_' {$$ = gc1(WILDCARD);}
972 | '(' pat_npk ')' {$$ = gc3($2);}
973 | '(' npk ')' {$$ = gc3($2);}
974 | '(' pats2 ')' {$$ = gc3(buildTuple($2));}
975 | '[' pats1 ']' {$$ = gc3(ap(FINLIST,rev($2)));}
976 | '~' apat {$$ = gc2(ap(LAZYPAT,$2));}
978 | '(' patfields ')' {
980 $$ = gc3(revOnto($2,nameNoRec));
985 | '(' patfields '|' pat ')' {$$ = gc5(revOnto($2,$4));}
988 pats2 : pats2 ',' pat {$$ = gc3(cons($3,$1));}
989 | pat ',' pat {$$ = gc3(cons($3,singleton($1)));}
991 pats1 : pats1 ',' pat {$$ = gc3(cons($3,$1));}
992 | pat {$$ = gc1(singleton($1));}
994 patbinds : /* empty */ {$$ = gc0(NIL);}
995 | patbinds1 {$$ = gc1(rev($1));}
997 patbinds1 : patbinds1 ',' patbind {$$ = gc3(cons($3,$1));}
998 | patbind {$$ = gc1(singleton($1));}
1000 patbind : qvar '=' pat {$$ = gc3(pair($1,$3));}
1004 patfields : patfields ',' patfield {$$ = gc3(cons($3,$1));}
1005 | patfield {$$ = gc1(singleton($1));}
1007 patfield : varid '=' pat {
1009 $$ = gc3(ap(mkExt(textOf($1)),$3));
1011 noTREX("a pattern");
1017 /*- Expressions: ----------------------------------------------------------*/
1019 exp : exp_err {$$ = $1;}
1020 | error {syntaxError("expression");}
1022 exp_err : exp0a COCO sigType {$$ = gc3(ap(ESIGN,pair($1,$3)));}
1023 | exp0a WITH dbinds {
1025 $$ = gc3(ap(WITHEXP,pair($1,$3)));
1027 noIP("an expression");
1032 exp0 : exp0a {$$ = $1;}
1035 exp0a : infixExpa {$$ = gc1(ap(INFIX,$1));}
1038 exp0b : infixExpb {$$ = gc1(ap(INFIX,$1));}
1041 infixExpa : infixExpa qop '-' exp10a {$$ = gc4(ap(NEG,ap(ap($2,$1),$4)));}
1042 | infixExpa qop exp10a {$$ = gc3(ap(ap($2,$1),$3));}
1043 | '-' exp10a {$$ = gc2(ap(NEG,only($2)));}
1044 | exp10a qop '-' exp10a {$$ = gc4(ap(NEG,
1045 ap(ap($2,only($1)),$4)));}
1046 | exp10a qop exp10a {$$ = gc3(ap(ap($2,only($1)),$3));}
1048 infixExpb : infixExpa qop '-' exp10b {$$ = gc4(ap(NEG,ap(ap($2,$1),$4)));}
1049 | infixExpa qop exp10b {$$ = gc3(ap(ap($2,$1),$3));}
1050 | '-' exp10b {$$ = gc2(ap(NEG,only($2)));}
1051 | exp10a qop '-' exp10b {$$ = gc4(ap(NEG,
1052 ap(ap($2,only($1)),$4)));}
1053 | exp10a qop exp10b {$$ = gc3(ap(ap($2,only($1)),$3));}
1055 exp10a : CASEXP exp OF '{' alts end {$$ = gc6(ap(CASE,pair($2,rev($5))));}
1056 | DO '{' stmts end {$$ = gc4(ap(DOCOMP,checkDo($3)));}
1059 exp10b : '\\' pats ARROW exp {$$ = gc4(ap(LAMBDA,
1062 | LET decls IN exp {$$ = gc4(letrec($2,$4));}
1063 | IF exp THEN exp ELSE exp {$$ = gc6(ap(COND,triple($2,$4,$6)));}
1064 | DLET dbinds IN exp {
1066 $$ = gc4(ap(WITHEXP,pair($4,$2)));
1068 noIP("an expression");
1072 pats : pats apat {$$ = gc2(cons($2,$1));}
1073 | apat {$$ = gc1(cons($1,NIL));}
1075 appExp : appExp aexp {$$ = gc2(ap($1,$2));}
1078 aexp : qvar {$$ = $1;}
1079 | qvar '@' aexp {$$ = gc3(ap(ASPAT,pair($1,$3)));}
1080 | '~' aexp {$$ = gc2(ap(LAZYPAT,$2));}
1081 | IPVARID {$$ = $1;}
1082 | '_' {$$ = gc1(WILDCARD);}
1084 | qcon '{' fbinds '}' {$$ = gc4(ap(CONFLDS,pair($1,$3)));}
1085 | aexp '{' fbinds '}' {$$ = gc4(ap(UPDFLDS,
1086 triple($1,NIL,$3)));}
1088 | CHARLIT {$$ = $1;}
1089 | STRINGLIT {$$ = $1;}
1091 | '(' exp ')' {$$ = gc3($2);}
1092 | '(' exps2 ')' {$$ = gc3(buildTuple($2));}
1096 $$ = gc3(revOnto($2,nameNoRec));
1101 | '(' vfields '|' exp ')' {$$ = gc5(revOnto($2,$4));}
1102 | RECSELID {$$ = $1;}
1104 | '[' list ']' {$$ = gc3($2);}
1105 | '(' exp10a qop ')' {$$ = gc4(ap($3,$2));}
1106 | '(' qvarop_mi exp0 ')' {$$ = gc4(ap(ap(nameFlip,$2),$3));}
1107 | '(' qconop exp0 ')' {$$ = gc4(ap(ap(nameFlip,$2),$3));}
1109 exps2 : exps2 ',' exp {$$ = gc3(cons($3,$1));}
1110 | exp ',' exp {$$ = gc3(cons($3,cons($1,NIL)));}
1113 vfields : vfields ',' vfield {$$ = gc3(cons($3,$1));}
1114 | vfield {$$ = gc1(singleton($1));}
1116 vfield : varid '=' exp {
1118 $$ = gc3(ap(mkExt(textOf($1)),$3));
1120 noTREX("an expression");
1125 alts : alts1 {$$ = $1;}
1126 | alts1 ';' {$$ = gc2($1);}
1128 alts1 : alts1 ';' alt {$$ = gc3(cons($3,$1));}
1129 | alt {$$ = gc1(cons($1,NIL));}
1131 alt : pat altRhs wherePart {$$ = gc3(pair($1,letrec($3,$2)));}
1133 altRhs : guardAlts {$$ = gc1(grded(rev($1)));}
1134 | ARROW exp {$$ = gc2(pair($1,$2));}
1135 | error {syntaxError("case expression");}
1137 guardAlts : guardAlts guardAlt {$$ = gc2(cons($2,$1));}
1138 | guardAlt {$$ = gc1(cons($1,NIL));}
1140 guardAlt : '|' exp0 ARROW exp {$$ = gc4(pair($3,pair($2,$4)));}
1142 stmts : stmts1 ';' {$$ = gc2($1);}
1145 stmts1 : stmts1 ';' stmt {$$ = gc3(cons($3,$1));}
1146 | stmt {$$ = gc1(cons($1,NIL));}
1148 stmt : exp_err FROM exp {$$ = gc3(ap(FROMQUAL,pair($1,$3)));}
1149 | LET decls {$$ = gc2(ap(QWHERE,$2));}
1150 /* | IF exp {$$ = gc2(ap(BOOLQUAL,$2));}*/
1151 | exp_err {$$ = gc1(ap(DOQUAL,$1));}
1153 fbinds : /* empty */ {$$ = gc0(NIL);}
1154 | fbinds1 {$$ = gc1(rev($1));}
1156 fbinds1 : fbinds1 ',' fbind {$$ = gc3(cons($3,$1));}
1157 | fbind {$$ = gc1(singleton($1));}
1159 fbind : var {$$ = $1;}
1160 | qvar '=' exp {$$ = gc3(pair($1,$3));}
1163 dbinds : '{' dbs0 end {$$ = gc3($2);}
1164 | '{' dbs1 end {$$ = gc3($2);}
1166 dbs0 : /* empty */ {$$ = gc0(NIL);}
1167 | dbs0 ';' {$$ = gc2($1);}
1168 | dbs1 ';' {$$ = gc2($1);}
1170 dbs1 : dbs0 dbind {$$ = gc2(cons($2,$1));}
1172 dbind : IPVARID '=' exp {$$ = gc3(pair($1,$3));}
1175 /*- List Expressions: -------------------------------------------------------*/
1177 list : exp {$$ = gc1(ap(FINLIST,cons($1,NIL)));}
1178 | exps2 {$$ = gc1(ap(FINLIST,rev($1)));}
1179 | exp '|' quals {$$ = gc3(ap(COMP,pair($1,rev($3))));}
1180 | exp UPTO exp {$$ = gc3(ap(ap(nameFromTo,$1),$3));}
1181 | exp ',' exp UPTO {$$ = gc4(ap(ap(nameFromThen,$1),$3));}
1182 | exp UPTO {$$ = gc2(ap(nameFrom,$1));}
1183 | exp ',' exp UPTO exp {$$ = gc5(ap(ap(ap(nameFromThenTo,
1186 quals : quals ',' qual {$$ = gc3(cons($3,$1));}
1187 | qual {$$ = gc1(cons($1,NIL));}
1189 qual : exp FROM exp {$$ = gc3(ap(FROMQUAL,pair($1,$3)));}
1190 | exp {$$ = gc1(ap(BOOLQUAL,$1));}
1191 | LET decls {$$ = gc2(ap(QWHERE,$2));}
1194 /*- Identifiers and symbols: ----------------------------------------------*/
1196 gcon : qcon {$$ = $1;}
1197 | '(' ')' {$$ = gc2(nameUnit);}
1198 | '[' ']' {$$ = gc2(nameNil);}
1199 | '(' tupCommas ')' {$$ = gc3($2);}
1201 tupCommas : tupCommas ',' {$$ = gc2(mkTuple(tupleOf($1)+1));}
1202 | ',' {$$ = gc1(mkTuple(2));}
1204 varid : VARID {$$ = $1;}
1205 | HIDING {$$ = gc1(varHiding);}
1206 | QUALIFIED {$$ = gc1(varQualified);}
1207 | ASMOD {$$ = gc1(varAsMod);}
1208 | PRIVILEGED {$$ = gc1(varPrivileged);}
1210 qconid : QCONID {$$ = $1;}
1213 var : varid {$$ = $1;}
1214 | '(' VAROP ')' {$$ = gc3($2);}
1215 | '(' '+' ')' {$$ = gc3(varPlus);}
1216 | '(' '-' ')' {$$ = gc3(varMinus);}
1217 | '(' '!' ')' {$$ = gc3(varBang);}
1218 | '(' '.' ')' {$$ = gc3(varDot);}
1220 qvar : QVARID {$$ = $1;}
1221 | '(' QVAROP ')' {$$ = gc3($2);}
1224 con : CONID {$$ = $1;}
1225 | '(' CONOP ')' {$$ = gc3($2);}
1227 qcon : QCONID {$$ = $1;}
1228 | '(' QCONOP ')' {$$ = gc3($2);}
1231 varop : '+' {$$ = gc1(varPlus);}
1232 | '-' {$$ = gc1(varMinus);}
1233 | varop_mipl {$$ = $1;}
1235 varop_mi : '+' {$$ = gc1(varPlus);}
1236 | varop_mipl {$$ = $1;}
1238 varop_pl : '-' {$$ = gc1(varMinus);}
1239 | varop_mipl {$$ = $1;}
1241 varop_mipl: VAROP {$$ = $1;}
1242 | '`' varid '`' {$$ = gc3($2);}
1243 | '!' {$$ = gc1(varBang);}
1244 | '.' {$$ = gc1(varDot);}
1246 qvarop : '-' {$$ = gc1(varMinus);}
1247 | qvarop_mi {$$ = $1;}
1249 qvarop_mi : QVAROP {$$ = $1;}
1250 | '`' QVARID '`' {$$ = gc3($2);}
1251 | varop_mi {$$ = $1;}
1254 conop : CONOP {$$ = $1;}
1255 | '`' CONID '`' {$$ = gc3($2);}
1257 qconop : QCONOP {$$ = $1;}
1258 | '`' QCONID '`' {$$ = gc3($2);}
1261 op : varop {$$ = $1;}
1264 qop : qvarop {$$ = $1;}
1268 /*- Stuff from STG hugs ---------------------------------------------------*/
1270 qvarid : varid1 {$$ = gc1($1);}
1271 | QVARID {$$ = gc1($1);}
1273 varid1 : VARID {$$ = gc1($1);}
1274 | HIDING {$$ = gc1(varHiding);}
1275 | QUALIFIED {$$ = gc1(varQualified);}
1276 | ASMOD {$$ = gc1(varAsMod);}
1277 | PRIVILEGED {$$ = gc1(varPrivileged);}
1280 /*- Tricks to force insertion of leading and closing braces ---------------*/
1282 begin : error {yyerrok;
1283 if (offsideON) goOffside(startColumn);}
1285 /* deal with trailing semicolon */
1286 end : '}' {$$ = $1;}
1288 if (offsideON && canUnOffside()) {
1290 /* insert extra token on stack*/
1292 pushed(0) = pushed(1);
1293 pushed(1) = mkInt(column);
1296 syntaxError("definition");
1300 /*-------------------------------------------------------------------------*/
1304 static Cell local gcShadow(n,e) /* keep parsed fragments on stack */
1307 /* If a look ahead token is held then the required stack transformation
1310 * x1 | ... | xn | la ===> e | la
1313 * Otherwise, the transformation is:
1315 * x1 | ... | xn ===> e
1319 pushed(n-1) = top();
1328 static Void local syntaxError(s) /* report on syntax error */
1330 ERRMSG(row) "Syntax error in %s (unexpected %s)", s, unexpected()
1334 static String local unexpected() { /* find name for unexpected token */
1335 static char buffer[100];
1336 static char *fmt = "%s \"%s\"";
1337 static char *kwd = "keyword";
1340 case 0 : return "end of input";
1342 #define keyword(kw) sprintf(buffer,fmt,kwd,kw); return buffer;
1343 case INFIXL : keyword("infixl");
1344 case INFIXR : keyword("infixr");
1345 case INFIXN : keyword("infix");
1346 case FOREIGN : keyword("foreign");
1347 case UNSAFE : keyword("unsafe");
1348 case TINSTANCE : keyword("instance");
1349 case TCLASS : keyword("class");
1350 case CASEXP : keyword("case");
1351 case OF : keyword("of");
1352 case IF : keyword("if");
1353 case THEN : keyword("then");
1354 case ELSE : keyword("else");
1355 case WHERE : keyword("where");
1356 case TYPE : keyword("type");
1357 case DATA : keyword("data");
1358 case TNEWTYPE : keyword("newtype");
1359 case LET : keyword("let");
1360 case IN : keyword("in");
1361 case DERIVING : keyword("deriving");
1362 case DEFAULT : keyword("default");
1363 case IMPORT : keyword("import");
1364 case TMODULE : keyword("module");
1365 /* AJG: Hugs98/Classic use the keyword forall
1366 rather than __forall.
1367 Agree on one or the other
1369 case ALL : keyword("__forall");
1371 case DLET : keyword("dlet");
1372 case WITH : keyword("with");
1376 case ARROW : return "`->'";
1377 case '=' : return "`='";
1378 case COCO : return "`::'";
1379 case '-' : return "`-'";
1380 case '!' : return "`!'";
1381 case ',' : return "comma";
1382 case '@' : return "`@'";
1383 case '(' : return "`('";
1384 case ')' : return "`)'";
1385 case '{' : return "`{', possibly due to bad layout";
1386 case '}' : return "`}', possibly due to bad layout";
1387 case '_' : return "`_'";
1388 case '|' : return "`|'";
1389 case '.' : return "`.'";
1390 case ';' : return "`;', possibly due to bad layout";
1391 case UPTO : return "`..'";
1392 case '[' : return "`['";
1393 case ']' : return "`]'";
1394 case FROM : return "`<-'";
1395 case '\\' : return "backslash (lambda)";
1396 case '~' : return "tilde";
1397 case '`' : return "backquote";
1399 case RECSELID : sprintf(buffer,"selector \"#%s\"",
1400 textToStr(extText(snd(yylval))));
1404 case IPVARID : sprintf(buffer,"implicit parameter \"?%s\"",
1405 textToStr(textOf(yylval)));
1411 case CONID : sprintf(buffer,"symbol \"%s\"",
1412 textToStr(textOf(yylval)));
1417 case QCONID : sprintf(buffer,"symbol \"%s\"",
1418 identToStr(yylval));
1420 case HIDING : return "symbol \"hiding\"";
1421 case QUALIFIED : return "symbol \"qualified\"";
1422 case PRIVILEGED : return "symbol \"privileged\"";
1423 case ASMOD : return "symbol \"as\"";
1424 case NUMLIT : return "numeric literal";
1425 case CHARLIT : return "character literal";
1426 case STRINGLIT : return "string literal";
1427 case IMPLIES : return "`=>'";
1428 default : return "token";
1432 static Cell local checkPrec(p) /* Check for valid precedence value*/
1434 if (!isInt(p) || intOf(p)<MIN_PREC || intOf(p)>MAX_PREC) {
1435 ERRMSG(row) "Precedence value must be an integer in the range [%d..%d]",
1442 static Cell local buildTuple(tup) /* build tuple (x1,...,xn) from */
1443 List tup; { /* list [xn,...,x1] */
1449 x = fst(t); /* / \ / \ */
1450 fst(t) = snd(t); /* xn . . xn */
1451 snd(t) = x; /* . ===> . */
1453 t = fun(x); /* . . */
1455 } while (nonNull(t)); /* x1 NIL (n) x1 */
1456 fst(x) = mkTuple(n);
1460 static List local checkCtxt(con) /* validate context */
1462 mapOver(checkPred, con);
1466 static Cell local checkPred(c) /* check that type expr is a valid */
1467 Cell c; { /* constraint */
1468 Cell cn = getHead(c);
1470 if (isExt(cn) && argCount==1)
1477 if (!isQCon(cn) /*|| argCount==0*/)
1478 syntaxError("class expression");
1482 static Pair local checkDo(dqs) /* convert reversed list of dquals */
1483 List dqs; { /* to an (expr,quals) pair */
1484 if (isNull(dqs) || whatIs(hd(dqs))!=DOQUAL) {
1485 ERRMSG(row) "Last generator in do {...} must be an expression"
1488 fst(dqs) = snd(fst(dqs)); /* put expression in fst of pair */
1489 snd(dqs) = rev(snd(dqs)); /* & reversed list of quals in snd */
1493 static Cell local checkTyLhs(c) /* check that lhs is of the form */
1494 Cell c; { /* T a1 ... a */
1496 while (isAp(tlhs) && whatIs(arg(tlhs))==VARIDCELL) {
1499 if (whatIs(tlhs)!=CONIDCELL) {
1500 ERRMSG(row) "Illegal left hand side in datatype definition"
1508 static Void local noTREX(where)
1510 ERRMSG(row) "Attempt to use TREX records while parsing %s.\n", where ETHEN
1511 ERRTEXT "(TREX is disabled in this build of Hugs)"
1516 static Void local noIP(where)
1518 ERRMSG(row) "Attempt to use Implicit Parameters while parsing %s.\n", where ETHEN
1519 ERRTEXT "(Implicit Parameters are disabled in this build of Hugs)"
1524 /*-------------------------------------------------------------------------*/