ghc/interpreter/parser.y

   1
   2 /* --------------------------------------------------------------------------
   3  * Hugs parser (included as part of input.c)
   4  *
   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.
   7  *
   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.
  12  *
  13  * $RCSfile: parser.y,v $
  14  * $Revision: 1.6 $
  15  * $Date: 1999/06/07 17:22:41 $
  16  * ------------------------------------------------------------------------*/
  17
  18 %{
  19 #ifndef lint
  20 #define lint
  21 #endif
  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, \
  32                                     mkCon(module(currentModule).text)))
  33 #define yyerror(s)               /* errors handled elsewhere */
  34 #define YYSTYPE                  Cell
  35
  36 static Cell   local gcShadow     Args((Int,Cell));
  37 static Void   local syntaxError  Args((String));
  38 static String local unexpected   Args((Void));
  39 static Cell   local checkPrec    Args((Cell));
  40 static Void   local fixDefn      Args((Syntax,Cell,Cell,List));
  41 static Cell   local buildTuple   Args((List));
  42 static List   local checkContext Args((List));
  43 static Cell   local checkPred    Args((Cell));
  44 static Pair   local checkDo      Args((List));
  45 static Cell   local checkTyLhs   Args((Cell));
  46 #if !TREX
  47 static Void   local noTREX       Args((String));
  48 #endif
  49
  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()
  56  * below.
  57  *
  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
  62  * of the parse.
  63  */
  64
  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
  74 %}
  75
  76 %token EXPR       SCRIPT
  77 %token CASEXP     OF         DATA       TYPE       IF
  78 %token THEN       ELSE       WHERE      LET        IN
  79 %token INFIXN     INFIXL     INFIXR     FOREIGN    TNEWTYPE
  80 %token DEFAULT    DERIVING   DO         TCLASS     TINSTANCE
  81 %token REPEAT     ALL        NUMLIT     CHARLIT    STRINGLIT
  82 %token VAROP      VARID      CONOP      CONID
  83 %token QVAROP     QVARID     QCONOP     QCONID
  84 /*#if TREX*/
  85 %token RECSELID
  86 /*#endif*/
  87 %token COCO       '='        UPTO       '@'        '\\'
  88 %token '|'        '-'        FROM       ARROW      '~'
  89 %token '!'        IMPLIES    '('        ','        ')'
  90 %token '['        ';'        ']'        '`'        '.'
  91 %token TMODULE    IMPORT     HIDING     QUALIFIED  ASMOD
  92 %token EXPORT     INTERFACE  REQUIRES   UNSAFE     INSTIMPORT
  93
  94 %%
  95 /*- Top level script/module structure -------------------------------------*/
  96
  97 start     : EXPR exp wherePart          {inputExpr = letrec($3,$2); sp-=2;}
  98           | SCRIPT topModule            {valDefns  = $2;            sp-=1;}
  99           | INTERFACE iface             {sp-=1;}
 100           | error                       {syntaxError("input");}
 101           ;
 102
 103
 104 /*- GHC interface file parsing: -------------------------------------------*/
 105
 106 /* Reading in an interface file is surprisingly like reading
 107  * a normal Haskell module: we read in a bunch of declarations,
 108  * construct symbol table entries, etc.  The "only" differences
 109  * are that there's no syntactic sugar to deal with and we don't
 110  * have to read in expressions.
 111  */
 112
 113 /*- Top-level interface files -----------------------------*/
 114 iface     : INTERFACE ifName NUMLIT checkVersion WHERE ifDecls
 115                                         {$$ = gc6(NIL); }
 116           | INTERFACE error             {syntaxError("interface file");}
 117           ;
 118 ifDecls:                                {$$=gc0(NIL);}
 119           | ifDecl ';' ifDecls          {$$=gc3(cons($1,$3));}
 120           ;
 121 varid_or_conid
 122           : VARID                       { $$=gc1($1); }
 123           | CONID                       { $$=gc1($1); }
 124           ;
 125 opt_bang  : '!'                         {$$=gc1(NIL);}
 126           |                             {$$=gc0(NIL);}
 127           ;
 128 ifName    : CONID                       {openGHCIface(textOf($1));
 129                                          $$ = gc1(NIL);}
 130 checkVersion
 131           : NUMLIT                      {$$ = gc1(NIL); }
 132           ;
 133 ifDecl
 134           : IMPORT CONID opt_bang NUMLIT COCO version_list_junk
 135                                         { addGHCImports(intOf($4),textOf($2),
 136                                                        $6);
 137                                           $$ = gc6(NIL);
 138                                         }
 139
 140           | INSTIMPORT CONID            {$$=gc2(NIL);}
 141
 142           | EXPORT CONID ifEntities     { addGHCExports($2,$3);
 143                                           $$=gc3(NIL);}
 144
 145           | NUMLIT INFIXL optDigit varid_or_conid
 146                                         {$$ = gc4(fixdecl($2,singleton($4),
 147                                                           LEFT_ASS,$3)); }
 148           | NUMLIT INFIXR optDigit varid_or_conid
 149                                         {$$ = gc4(fixdecl($2,singleton($4),
 150                                                           RIGHT_ASS,$3)); }
 151           | NUMLIT INFIXN optDigit varid_or_conid
 152                                         {$$ = gc4(fixdecl($2,singleton($4),
 153                                                           NON_ASS,$3)); }
 154
 155           | TINSTANCE ifCtxInst ifInstHd '=' ifVar
 156                                         { addGHCInstance(intOf($1),$2,$3,
 157                                           textOf($5));
 158                                           $$ = gc5(NIL); }
 159           | NUMLIT TYPE ifCon ifKindedTyvarL '=' ifType
 160                                         { addGHCSynonym(intOf($2),$3,$4,$6);
 161                                           $$ = gc6(NIL); }
 162
 163           | NUMLIT DATA ifCtxDecl ifConData ifKindedTyvarL ifConstrs
 164                                         { addGHCDataDecl(intOf($2),
 165                                                          $3,$4,$5,$6);
 166                                           $$ = gc6(NIL); }
 167
 168           | NUMLIT TNEWTYPE ifCtxDecl ifConData ifKindedTyvarL ifNewTypeConstr
 169                                         { addGHCNewType(intOf($2),
 170                                                         $3,$4,$5,$6);
 171                                           $$ = gc6(NIL); }
 172           | NUMLIT TCLASS ifCtxDecl ifCon ifTyvar ifCmeths
 173                                         { addGHCClass(intOf($2),$3,$4,$5,$6);
 174                                           $$ = gc6(NIL); }
 175           | NUMLIT ifVar COCO ifType
 176                                         { addGHCVar(intOf($3),textOf($2),$4);
 177                                           $$ = gc4(NIL); }
 178           | error                       { syntaxError(
 179                                              "interface declaration"); }
 180           ;
 181
 182
 183 /*- Interface variable and constructor ids ----------------*/
 184 ifTyvar   : VARID                       {$$ = $1;}
 185           ;
 186 ifVar     : VARID                       {$$ = gc1($1);}
 187           ;
 188 ifCon     : CONID                       {$$ = gc1($1);}
 189           ;
 190 ifQCon    : CONID                       {$$ = gc1($1);}
 191           | QCONID                      {$$ = gc1($1);}
 192           ;
 193 ifConData : ifCon                       {$$ = gc1($1);}
 194           | '(' ')'                     {$$ = gc2(typeUnit);}
 195           | '[' ']'                     {$$ = gc2(typeList);}
 196           | '(' ARROW ')'               {$$ = gc3(typeArrow);}
 197           ;
 198 ifTCName  : CONID                       { $$ = gc1($1); }
 199           | CONOP                       { $$ = gc1($1); }
 200           | '(' ARROW ')'               { $$ = gc3(typeArrow); }
 201           | '[' ']'                     { $$ = gc1(typeList);  }
 202           ;
 203 ifQTCName : ifTCName                    { $$ = gc1($1); }
 204           | QCONID                      { $$ = gc1($1); }
 205           | QCONOP                      { $$ = gc1($1); }
 206           ;
 207
 208
 209 /*- Interface contexts ------------------------------------*/
 210 ifCtxInst /* __forall [a b] {M.C1 a, M.C2 b} =>  */
 211           /* :: [(QConId, VarId)]                */
 212           : ALL ifForall ifCtxDecl      {$$=gc3($3);}
 213           | ALL ifForall IMPLIES        {$$=gc3(NIL);}
 214           |                             {$$=gc0(NIL);}
 215           ;
 216 ifInstHd  /* { Class aType }    :: (ConId, Type) */
 217           : '{' ifCon ifAType '}'       {$$=gc4(pair($2,$3));}
 218           ;
 219
 220 ifCtxDecl /* {M.C1 a, C2 b} :: [(QConId, VarId)] */
 221           :                             { $$ = gc0(NIL); }
 222           | '{' ifCtxDeclL '}' IMPLIES  { $$ = gc4($2);  }
 223           ;
 224 ifCtxDeclT /* {M.C1 a, C2 b} :: [(QConId, VarId)] */
 225           :                             { $$ = gc0(NIL); }
 226           | '{' ifCtxDeclL '}'          { $$ = gc3($2);  }
 227           ;
 228 ifCtxDeclL /* M.C1 a, C2 b :: [(QConId, VarId)] */
 229           : ifCtxDeclLE ',' ifCtxDeclL  {$$=gc3(cons($1,$3));}
 230           | ifCtxDeclLE                 {$$=gc1(cons($1,NIL));}
 231           |                             {$$=gc0(NIL);}
 232           ;
 233 ifCtxDeclLE /* M.C1 a   :: (QConId,VarId) */
 234           : ifQCon ifTyvar              {$$=gc2(pair($1,$2));}
 235           ;
 236
 237
 238 /*- Interface data declarations - constructor lists -------*/
 239 ifConstrs /* = Con1 | ... | ConN  :: [(ConId,[(Type,Text)],NIL)] */
 240           :                             {$$ = gc0(NIL);}
 241           | '=' ifConstrL               {$$ = gc2($2);}
 242           ;
 243 ifConstrL /* [(ConId,[(Type,Text)],NIL)] */
 244           : ifConstr                    {$$ = gc1(singleton($1));}
 245           | ifConstr '|' ifConstrL      {$$ = gc3(cons($1,$3));}
 246           ;
 247 ifConstr /* (ConId,[(Type,Text)],NIL) */
 248           : ifConData ifDataAnonFieldL  {$$ = gc2(triple($1,$2,NIL));}
 249           | ifConData '{' ifDataNamedFieldL '}'
 250                                         {$$ = gc4(triple($1,$3,NIL));}
 251           ;
 252 ifDataAnonFieldL /* [(Type,Text)] */
 253           :                             {$$=gc0(NIL);}
 254           | ifDataAnonField ifDataAnonFieldL
 255                                         {$$=gc2(cons($1,$2));}
 256           ;
 257 ifDataNamedFieldL /* [(Type,Text)] */
 258           :                             {$$=gc0(NIL);}
 259           | ifDataNamedField            {$$=gc1(cons($1,NIL));}
 260           | ifDataNamedField ',' ifDataNamedFieldL
 261                                         {$$=gc3(cons($1,$3));}
 262           ;
 263 ifDataAnonField /* (Type,Text) */
 264           : ifAType                     {$$=gc1(pair($1,NIL));}
 265           ;
 266 ifDataNamedField  /* (Type,Text) */
 267           : VARID COCO ifAType          {$$=gc3(pair($3,$1));}
 268           ;
 269
 270
 271 /*- Interface class declarations - methods ----------------*/
 272 ifCmeths /* [(VarId,Type)] */
 273           :                             { $$ = gc0(NIL); }
 274           | WHERE '{' ifCmethL '}'      { $$ = gc4($3); }
 275           ;
 276 ifCmethL /* [(VarId,Type)] */
 277           : ifCmeth                     { $$ = gc1(singleton($1)); }
 278           | ifCmeth ';' ifCmethL        { $$ = gc3(cons($1,$3));    }
 279           ;
 280 ifCmeth /* (VarId,Type) */
 281           : ifVar     COCO ifType       { $$ = gc3(pair($1,$3)); }
 282           | ifVar '=' COCO ifType       { $$ = gc4(pair($1,$4)); }
 283                                               /* has default method */
 284           ;
 285
 286
 287 /*- Interface newtype declararions ------------------------*/
 288 ifNewTypeConstr /* (ConId,Type) */
 289           : '=' ifCon ifAType           { $$ = gc3(pair($2,$3)); }
 290           ;
 291
 292
 293 /*- Interface type expressions ----------------------------*/
 294 ifType    : ALL ifForall ifCtxDeclT IMPLIES ifType
 295                                         { if ($3 == NIL)
 296                                            $$=gc5($5); else
 297                                            $$=gc5(pair(QUAL,pair($3,$5)));
 298                                         }
 299           | ifBType ARROW ifType        { $$ = gc3(fn($1,$3)); }
 300           | ifBType                     { $$ = gc1($1); }
 301           ;
 302 ifForall /* [(VarId,Kind)] */
 303           : '[' ifKindedTyvarL ']'      { $$ = gc3($2); }
 304           ;
 305 ifTypes2  : ifType ',' ifType           { $$ = gc3(doubleton($1,$3)); }
 306           | ifType ',' ifTypes2         { $$ = gc3(cons($1,$3));      }
 307           ;
 308 ifBType   : ifAType                     { $$ = gc1($1);        }
 309           | ifBType ifAType             { $$ = gc2(ap($1,$2)); }
 310           ;
 311 ifAType   : ifQTCName                   { $$ = gc1($1); }
 312           | ifTyvar                     { $$ = gc1($1); }
 313           | '(' ')'                     { $$ = gc2(typeUnit); }
 314           | '(' ifTypes2 ')'            { $$ = gc3(buildTuple($2)); }
 315           | '[' ifType ']'              { $$ = gc3(ap(typeList,$2));}
 316           | '{' ifQTCName ifATypes '}'  { $$ = gc4(ap(DICTAP,
 317                                                       pair($2,$3))); }
 318           | '(' ifType ')'              { $$ = gc3($2); }
 319           ;
 320 ifATypes  :                             { $$ = gc0(NIL);         }
 321           | ifAType ifATypes            { $$ = gc2(cons($1,$2)); }
 322           ;
 323
 324
 325 /*- Interface kinds ---------------------------------------*/
 326 ifKindedTyvarL /* [(VarId,Kind)] */
 327           :                              { $$ = gc0(NIL);         }
 328           | ifKindedTyvar ifKindedTyvarL { $$ = gc2(cons($1,$2)); }
 329           ;
 330 ifKindedTyvar /* (VarId,Kind) */
 331           : ifTyvar                     { $$ = gc1(pair($1,STAR)); }
 332           | ifTyvar COCO ifAKind        { $$ = gc3(pair($1,$3));   }
 333           ;
 334 ifKind    : ifAKind                     { $$ = gc1($1);        }
 335           | ifAKind ARROW ifKind        { $$ = gc3(fn($1,$3)); }
 336           ;
 337 ifAKind   : VAROP                       { $$ = gc1(STAR); }
 338                                             /* should be '*' */
 339           | '(' ifKind ')'              { $$ = gc3($2);   }
 340           ;
 341
 342
 343 /*- Interface version/export/import stuff -----------------*/
 344 ifEntities
 345           :                             { $$ = gc0(NIL);         }
 346           | ifEntity ifEntities         { $$ = gc2(cons($1,$2)); }
 347           ;
 348 ifEntity
 349           : ifEntityOcc                 {$$=gc1($1);}
 350           | ifEntityOcc ifStuffInside   {$$=gc2($1);}
 351           | ifEntityOcc '|' ifStuffInside {$$=gc3($1);}
 352                                        /* exporting datacons but not tycon */
 353           ;
 354 ifEntityOcc
 355           : ifVar                       { $$ = gc1($1); }
 356           | ifCon                       { $$ = gc1($1); }
 357           | ARROW                       { $$ = gc1(typeArrow); }
 358           | '(' ARROW ')'               { $$ = gc3(typeArrow); }
 359                                         /* why allow both? */
 360           ;
 361 ifStuffInside
 362           : '{' ifValOccs '}'           { $$ = gc3($2); }
 363           ;
 364 ifValOccs
 365           : ifValOcc                    { $$ = gc1(singleton($1)); }
 366           | ifValOcc ifValOccs          { $$ = gc2(cons($1,$2));   }
 367           ;
 368 ifValOcc
 369           : ifVar                       {$$ = gc1($1); }
 370           | ifCon                       {$$ = gc1($1); }
 371           ;
 372 version_list_junk
 373           :                                {$$=gc0(NIL);}
 374           | VARID NUMLIT version_list_junk {$$=gc3(cons($1,$3));}
 375           | CONID NUMLIT version_list_junk {$$=gc3(cons($1,$3));}
 376           ;
 377
 378
 379 /*- Haskell module header/import parsing: -----------------------------------
 380
 381  * Syntax for Haskell modules (module headers and imports) is parsed but
 382  * most of it is ignored.  However, module names in import declarations
 383  * are used, of course, if import chasing is turned on.
 384  *-------------------------------------------------------------------------*/
 385
 386 /* In Haskell 1.2, the default module header was "module Main where"
 387  * In 1.3, this changed to "module Main(main) where".
 388  * We use the 1.2 header because it breaks much less pre-module code.
 389  */
 390 topModule : startMain begin modBody end {
 391                                          setExportList(singleton(
 392                                             ap(MODULEENT,
 393                                             mkCon(module(currentModule).text)
 394                                             )));
 395                                          $$ = gc3($3);
 396                                         }
 397           | TMODULE modname expspec WHERE '{' modBody end
 398                                         {setExportList($3);   $$ = gc7($6);}
 399           | TMODULE error               {syntaxError("module definition");}
 400           ;
 401 /* To implement the Haskell module system, we have to keep track of the
 402  * current module.  We rely on the use of LALR parsing to ensure that this
 403  * side effect happens before any declarations within the module.
 404  */
 405 startMain : /* empty */                 {startModule(conMain);
 406                                          $$ = gc0(NIL);}
 407           ;
 408 modname   : CONID                       {startModule($1); $$ = gc1(NIL);}
 409           ;
 410 modid     : CONID                       {$$ = $1;}
 411           | STRINGLIT                   { extern String scriptFile;
 412                                           String modName
 413                                              = findPathname(scriptFile,
 414                                                  textToStr(textOf($1)));
 415                                           if (modName) {
 416                                               /* fillin pathname if known */
 417                                               $$ = mkStr(findText(modName));
 418                                           } else {
 419                                               $$ = $1;
 420                                           }
 421                                         }
 422           ;
 423 modBody   : topDecls                    {$$ = $1;}
 424           | impDecls chase              {$$ = gc2(NIL);}
 425           | impDecls ';' chase topDecls {$$ = gc4($4);}
 426           ;
 427
 428 /*- Exports: --------------------------------------------------------------*/
 429
 430 expspec   : /* empty */                 {$$ = gc0(exportSelf());}
 431           | '(' ')'                     {$$ = gc2(NIL);}
 432           | '(' exports ')'             {$$ = gc3($2);}
 433           | '(' exports ',' ')'         {$$ = gc4($2);}
 434           ;
 435 exports   : exports ',' export          {$$ = gc3(cons($3,$1));}
 436           | export                      {$$ = gc1(singleton($1));}
 437           ;
 438 /* The qcon should be qconid.
 439  * Relaxing the rule lets us explicitly export (:) from the Prelude.
 440  */
 441 export    : qvar                        {$$ = $1;}
 442           | qcon                        {$$ = $1;}
 443           | qconid '(' UPTO ')'         {$$ = gc4(pair($1,DOTDOT));}
 444           | qconid '(' qnames ')'       {$$ = gc4(pair($1,$3));}
 445           | TMODULE modid               {$$ = gc2(ap(MODULEENT,$2));}
 446           ;
 447 qnames    : /* empty */                 {$$ = gc0(NIL);}
 448           | ','                         {$$ = gc1(NIL);}
 449           | qnames1                     {$$ = $1;}
 450           | qnames1 ','                 {$$ = gc2($1);}
 451           ;
 452 qnames1   : qnames1 ',' qname           {$$ = gc3(cons($3,$1));}
 453           | qname                       {$$ = gc1(singleton($1));}
 454           ;
 455 qname     : qvar                        {$$ = $1;}
 456           | qcon                        {$$ = $1;}
 457           ;
 458
 459 /*- Import declarations: --------------------------------------------------*/
 460
 461 impDecls  : impDecls ';' impDecl        {imps = cons($3,imps); $$=gc3(NIL);}
 462           | impDecl                     {imps = singleton($1); $$=gc1(NIL);}
 463           ;
 464 chase     : /* empty */                 {if (chase(imps)) {
 465                                              clearStack();
 466                                              onto(imps);
 467                                              done();
 468                                              closeAnyInput();
 469                                              return 0;
 470                                          }
 471                                          $$ = gc0(NIL);
 472                                         }
 473           ;
 474 /* Note that qualified import ignores the import list. */
 475 impDecl   : IMPORT modid impspec        {addQualImport($2,$2);
 476                                          addUnqualImport($2,$3);
 477                                          $$ = gc3($2);}
 478           | IMPORT modid ASMOD modid impspec
 479                                         {addQualImport($2,$4);
 480                                          addUnqualImport($2,$5);
 481                                          $$ = gc5($2);}
 482           | IMPORT QUALIFIED modid ASMOD modid impspec
 483                                         {addQualImport($3,$5);
 484                                          $$ = gc6($3);}
 485           | IMPORT QUALIFIED modid impspec
 486                                         {addQualImport($3,$3);
 487                                          $$ = gc4($3);}
 488           | IMPORT error                {syntaxError("import declaration");}
 489           ;
 490 impspec   : /* empty */                 {$$ = gc0(DOTDOT);}
 491           | HIDING '(' imports ')'      {$$ = gc4(ap(HIDDEN,$3));}
 492           | '(' imports ')'             {$$ = gc3($2);}
 493           ;
 494 imports   : /* empty */                 {$$ = gc0(NIL);}
 495           | ','                         {$$ = gc1(NIL);}
 496           | imports1                    {$$ = $1;}
 497           | imports1 ','                {$$ = gc2($1);}
 498           ;
 499 imports1  : imports1 ',' import         {$$ = gc3(cons($3,$1));}
 500           | import                      {$$ = gc1(singleton($1));}
 501           ;
 502 import    : var                         {$$ = $1;}
 503           | CONID                       {$$ = $1;}
 504           | CONID '(' UPTO ')'          {$$ = gc4(pair($1,DOTDOT));}
 505           | CONID '(' names ')'         {$$ = gc4(pair($1,$3));}
 506           ;
 507 names     : /* empty */                 {$$ = gc0(NIL);}
 508           | ','                         {$$ = gc1(NIL);}
 509           | names1                      {$$ = $1;}
 510           | names1 ','                  {$$ = gc2($1);}
 511           ;
 512 names1    : names1 ',' name             {$$ = gc3(cons($3,$1));}
 513           | name                        {$$ = gc1(singleton($1));}
 514           ;
 515 name      : var                         {$$ = $1;}
 516           | con                         {$$ = $1;}
 517           ;
 518
 519 /*- Top-level declarations: -----------------------------------------------*/
 520
 521 topDecls  : /* empty */                 {$$ = gc0(NIL);}
 522           | ';'                         {$$ = gc1(NIL);}
 523           | topDecls1                   {$$ = $1;}
 524           | topDecls1 ';'               {$$ = gc2($1);}
 525           ;
 526 topDecls1 : topDecls1 ';' topDecl       {$$ = gc2($1);}
 527           | topDecls1 ';' decl          {$$ = gc3(cons($3,$1));}
 528           | topDecl                     {$$ = gc0(NIL);}
 529           | decl                        {$$ = gc1(cons($1,NIL));}
 530           ;
 531
 532 /*- Type declarations: ----------------------------------------------------*/
 533
 534 topDecl   : TYPE tyLhs '=' type         {defTycon(4,$3,$2,$4,SYNONYM);}
 535           | TYPE tyLhs '=' type IN invars
 536                                         {defTycon(6,$3,$2,
 537                                                     ap($4,$6),RESTRICTSYN);}
 538           | TYPE error                  {syntaxError("type definition");}
 539           | DATA btype2 '=' constrs deriving
 540                                         {defTycon(5,$3,checkTyLhs($2),
 541                                                    ap(rev($4),$5),DATATYPE);}
 542           | DATA context IMPLIES tyLhs '=' constrs deriving
 543                                         {defTycon(7,$5,$4,
 544                                                   ap(qualify($2,rev($6)),
 545                                                      $7),DATATYPE);}
 546           | DATA btype2                 {defTycon(2,$1,checkTyLhs($2),
 547                                                     ap(NIL,NIL),DATATYPE);}
 548           | DATA context IMPLIES tyLhs  {defTycon(4,$1,$4,
 549                                                   ap(qualify($2,NIL),
 550                                                      NIL),DATATYPE);}
 551           | DATA error                  {syntaxError("data definition");}
 552           | TNEWTYPE btype2 '=' nconstr deriving
 553                                         {defTycon(5,$3,checkTyLhs($2),
 554                                                     ap($4,$5),NEWTYPE);}
 555           | TNEWTYPE context IMPLIES tyLhs '=' nconstr deriving
 556                                         {defTycon(7,$5,$4,
 557                                                   ap(qualify($2,$6),
 558                                                      $7),NEWTYPE);}
 559           | TNEWTYPE error              {syntaxError("newtype definition");}
 560           ;
 561 tyLhs     : tyLhs varid                 {$$ = gc2(ap($1,$2));}
 562           | CONID                       {$$ = $1;}
 563           | error                       {syntaxError("type defn lhs");}
 564           ;
 565 invars    : invars ',' invar            {$$ = gc3(cons($3,$1));}
 566           | invar                       {$$ = gc1(cons($1,NIL));}
 567           ;
 568 invar     : var COCO topType            {$$ = gc3(sigdecl($2,singleton($1),
 569                                                                        $3));}
 570           | var                         {$$ = $1;}
 571           ;
 572 constrs   : constrs '|' pconstr         {$$ = gc3(cons($3,$1));}
 573           | pconstr                     {$$ = gc1(cons($1,NIL));}
 574           ;
 575 pconstr   : ALL varids '.' qconstr      {$$ = gc4(ap(POLYTYPE,
 576                                                      pair(rev($2),$4)));}
 577           | qconstr                     {$$ = $1;}
 578           ;
 579 qconstr   : context IMPLIES constr      {$$ = gc3(qualify($1,$3));}
 580           | constr                      {$$ = $1;}
 581           ;
 582 constr    : '!' btype conop bbtype      {$$ = gc4(ap(ap($3,bang($2)),$4));}
 583           | btype1    conop bbtype      {$$ = gc3(ap(ap($2,$1),$3));}
 584           | btype2    conop bbtype      {$$ = gc3(ap(ap($2,$1),$3));}
 585           | bpolyType conop bbtype      {$$ = gc3(ap(ap($2,$1),$3));}
 586           | btype2                      {$$ = $1;}
 587           | btype3                      {$$ = $1;}
 588           | btype4                      {$$ = $1;}
 589           | con '{' fieldspecs '}'      {$$ = gc4(ap(LABC,pair($1,rev($3))));}
 590           | con '{' '}'                 {$$ = gc3(ap(LABC,pair($1,NIL)));}
 591           | error                       {syntaxError("data type definition");}
 592           ;
 593 btype3    : btype2 '!' atype            {$$ = gc3(ap($1,bang($3)));}
 594           | btype3 '!' atype            {$$ = gc3(ap($1,bang($3)));}
 595           | btype3 atype                {$$ = gc2(ap($1,$2));}
 596           ;
 597 btype4    : btype2 bpolyType            {$$ = gc2(ap($1,$2));}
 598           | btype3 bpolyType            {$$ = gc2(ap($1,$2));}
 599           | btype4 bpolyType            {$$ = gc2(ap($1,$2));}
 600           | btype4 atype                {$$ = gc2(ap($1,$2));}
 601           | btype4 '!' atype            {$$ = gc3(ap($1,bang($3)));}
 602           ;
 603 bbtype    : '!' btype                   {$$ = gc2(bang($2));}
 604           | btype                       {$$ = $1;}
 605           | bpolyType                   {$$ = $1;}
 606           ;
 607 nconstr   : pconstr                     {$$ = gc1(singleton($1));}
 608           ;
 609 fieldspecs: fieldspecs ',' fieldspec    {$$ = gc3(cons($3,$1));}
 610           | fieldspec                   {$$ = gc1(cons($1,NIL));}
 611           ;
 612 fieldspec : vars COCO polyType          {$$ = gc3(pair(rev($1),$3));}
 613           | vars COCO type              {$$ = gc3(pair(rev($1),$3));}
 614           | vars COCO '!' type          {$$ = gc4(pair(rev($1),bang($4)));}
 615           ;
 616 deriving  : /* empty */                 {$$ = gc0(NIL);}
 617           | DERIVING qconid             {$$ = gc2(singleton($2));}
 618           | DERIVING '(' derivs0 ')'    {$$ = gc4($3);}
 619           ;
 620 derivs0   : /* empty */                 {$$ = gc0(NIL);}
 621           | derivs                      {$$ = gc1(rev($1));}
 622           ;
 623 derivs    : derivs ',' qconid           {$$ = gc3(cons($3,$1));}
 624           | qconid                      {$$ = gc1(singleton($1));}
 625           ;
 626
 627 /*- Processing definitions of primitives ----------------------------------*/
 628
 629 topDecl   : FOREIGN IMPORT callconv ext_loc ext_name unsafe_flag var COCO type
 630                                         {foreignImport($1,pair($4,$5),$7,$9); sp-=9;}
 631           | FOREIGN EXPORT callconv ext_name qvarid COCO type
 632                                         {foreignExport($1,$4,$5,$7); sp-=7;}
 633           ;
 634
 635 callconv  : var                  {$$ = gc1(NIL); /* ignored */ }
 636           ;
 637 ext_loc   : STRINGLIT            {$$ = $1;}
 638           ;
 639 ext_name  : STRINGLIT            {$$ = $1;}
 640           ;
 641 unsafe_flag: /* empty */         {$$ = gc0(NIL);}
 642           | UNSAFE               {$$ = gc1(NIL); /* ignored */ }
 643           ;
 644
 645
 646 /*- Class declarations: ---------------------------------------------------*/
 647
 648 topDecl   : TCLASS crule wherePart      {classDefn(intOf($1),$2,$3); sp-=3;}
 649           | TINSTANCE irule wherePart   {instDefn(intOf($1),$2,$3);  sp-=3;}
 650           | DEFAULT '(' dtypes ')'      {defaultDefn(intOf($1),$3);  sp-=4;}
 651           | TCLASS error                {syntaxError("class declaration");}
 652           | TINSTANCE error             {syntaxError("instance declaration");}
 653           | DEFAULT error               {syntaxError("default declaration");}
 654           ;
 655 crule     : context IMPLIES btype2      {$$ = gc3(pair($1,checkPred($3)));}
 656           | btype2                      {$$ = gc1(pair(NIL,checkPred($1)));}
 657           ;
 658 irule     : context IMPLIES btype2      {$$ = gc3(pair($1,checkPred($3)));}
 659           | btype2                      {$$ = gc1(pair(NIL,checkPred($1)));}
 660           ;
 661 dtypes    : /* empty */                 {$$ = gc0(NIL);}
 662           | dtypes1                     {$$ = gc1(rev($1));}
 663           ;
 664 dtypes1   : dtypes1 ',' type            {$$ = gc3(cons($3,$1));}
 665           | type                        {$$ = gc1(cons($1,NIL));}
 666           ;
 667
 668 /*- Type expressions: -----------------------------------------------------*/
 669
 670 topType   : context IMPLIES topType1    {$$ = gc3(qualify($1,$3));}
 671           | topType1                    {$$ = $1;}
 672           ;
 673 topType1  : bpolyType ARROW topType1    {$$ = gc3(fn($1,$3));}
 674           | btype1    ARROW topType1    {$$ = gc3(fn($1,$3));}
 675           | btype2    ARROW topType1    {$$ = gc3(fn($1,$3));}
 676           | btype                       {$$ = $1;}
 677           ;
 678 polyType  : ALL varids '.' sigType      {$$ = gc4(ap(POLYTYPE,
 679                                                      pair(rev($2),$4)));}
 680           | bpolyType                   {$$ = $1;}
 681           ;
 682 bpolyType : '(' polyType ')'            {$$ = gc3($2);}
 683           ;
 684 varids    : varids ',' varid            {$$ = gc3(cons($3,$1));}
 685           | varid                       {$$ = gc1(singleton($1));}
 686           ;
 687 sigType   : context IMPLIES type        {$$ = gc3(qualify($1,$3));}
 688           | type                        {$$ = $1;}
 689           ;
 690 context   : '(' ')'                     {$$ = gc2(NIL);}
 691           | btype2                      {$$ = gc1(singleton(checkPred($1)));}
 692           | '(' btype2 ')'              {$$ = gc3(singleton(checkPred($2)));}
 693           | '(' btypes2 ')'             {$$ = gc3(checkContext(rev($2)));}
 694 /*#if TREX*/
 695           | lacks                       {$$ = gc1(singleton($1));}
 696           | '(' lacks1 ')'              {$$ = gc3(checkContext(rev($2)));}
 697           ;
 698 lacks     : varid '\\' varid            {
 699 #if TREX
 700                                          $$ = gc3(ap(mkExt(textOf($3)),$1));
 701 #else
 702                                          noTREX("a type context");
 703 #endif
 704                                         }
 705           ;
 706 lacks1    : btypes2 ',' lacks           {$$ = gc3(cons($3,$1));}
 707           | lacks1  ',' btype2          {$$ = gc3(cons($3,$1));}
 708           | lacks1  ',' lacks           {$$ = gc3(cons($3,$1));}
 709           | btype2  ',' lacks           {$$ = gc3(cons($3,cons($1,NIL)));}
 710           | lacks                       {$$ = gc1(singleton($1));}
 711           ;
 712 /*#endif*/
 713
 714 type      : type1                       {$$ = $1;}
 715           | btype2                      {$$ = $1;}
 716           ;
 717 type1     : btype1                      {$$ = $1;}
 718           | btype1 ARROW type           {$$ = gc3(fn($1,$3));}
 719           | btype2 ARROW type           {$$ = gc3(fn($1,$3));}
 720           | error                       {syntaxError("type expression");}
 721           ;
 722 btype     : btype1                      {$$ = $1;}
 723           | btype2                      {$$ = $1;}
 724           ;
 725 btype1    : btype1 atype                {$$ = gc2(ap($1,$2));}
 726           | atype1                      {$$ = $1;}
 727           ;
 728 btype2    : btype2 atype                {$$ = gc2(ap($1,$2));}
 729           | qconid                      {$$ = $1;}
 730           ;
 731 atype     : atype1                      {$$ = $1;}
 732           | qconid                      {$$ = $1;}
 733           ;
 734 atype1    : varid                       {$$ = $1;}
 735           | '(' ')'                     {$$ = gc2(typeUnit);}
 736           | '(' ARROW ')'               {$$ = gc3(typeArrow);}
 737           | '(' type1 ')'               {$$ = gc3($2);}
 738           | '(' btype2 ')'              {$$ = gc3($2);}
 739           | '(' tupCommas ')'           {$$ = gc3($2);}
 740           | '(' btypes2 ')'             {$$ = gc3(buildTuple($2));}
 741           | '(' typeTuple ')'           {$$ = gc3(buildTuple($2));}
 742 /*#if TREX*/
 743           | '(' tfields ')'             {
 744 #if TREX
 745                                          $$ = gc3(revOnto($2,typeNoRow));
 746 #else
 747                                          noTREX("a type");
 748 #endif
 749                                         }
 750           | '(' tfields '|' type ')'    {$$ = gc5(revOnto($2,$4));}
 751 /*#endif*/
 752           | '[' type ']'                {$$ = gc3(ap(typeList,$2));}
 753           | '[' ']'                     {$$ = gc2(typeList);}
 754           | '_'                         {$$ = gc1(inventVar());}
 755           ;
 756 btypes2   : btypes2 ',' btype2          {$$ = gc3(cons($3,$1));}
 757           | btype2  ',' btype2          {$$ = gc3(cons($3,cons($1,NIL)));}
 758           ;
 759 typeTuple : type1     ',' type          {$$ = gc3(cons($3,cons($1,NIL)));}
 760           | btype2    ',' type1         {$$ = gc3(cons($3,cons($1,NIL)));}
 761           | btypes2   ',' type1         {$$ = gc3(cons($3,$1));}
 762           | typeTuple ',' type          {$$ = gc3(cons($3,$1));}
 763           ;
 764 /*#if TREX*/
 765 tfields   : tfields ',' tfield          {$$ = gc3(cons($3,$1));}
 766           | tfield                      {$$ = gc1(singleton($1));}
 767           ;
 768 tfield    : varid COCO type             {$$ = gc3(ap(mkExt(textOf($1)),$3));}
 769           ;
 770 /*#endif*/
 771
 772 /*- Value declarations: ---------------------------------------------------*/
 773
 774 gendecl   : INFIXN optDigit ops         {$$ = gc3(fixdecl($1,$3,NON_ASS,$2));}
 775           | INFIXN error                {syntaxError("fixity decl");}
 776           | INFIXL optDigit ops         {$$ = gc3(fixdecl($1,$3,LEFT_ASS,$2));}
 777           | INFIXL error                {syntaxError("fixity decl");}
 778           | INFIXR optDigit ops         {$$ = gc3(fixdecl($1,$3,RIGHT_ASS,$2));}
 779           | INFIXR error                {syntaxError("fixity decl");}
 780           | vars COCO topType           {$$ = gc3(sigdecl($2,$1,$3));}
 781           | vars COCO error             {syntaxError("type signature");}
 782           ;
 783 optDigit  : NUMLIT                      {$$ = gc1(checkPrec($1));}
 784           | /* empty */                 {$$ = gc0(mkInt(DEF_PREC));}
 785           ;
 786 ops       : ops ',' op                  {$$ = gc3(cons($3,$1));}
 787           | op                          {$$ = gc1(singleton($1));}
 788           ;
 789 vars      : vars ',' var                {$$ = gc3(cons($3,$1));}
 790           | var                         {$$ = gc1(singleton($1));}
 791           ;
 792 decls     : '{' decls0 end              {$$ = gc3($2);}
 793           | '{' decls1 end              {$$ = gc3($2);}
 794           ;
 795 decls0    : /* empty */                 {$$ = gc0(NIL);}
 796           | decls0 ';'                  {$$ = gc2($1);}
 797           | decls1 ';'                  {$$ = gc2($1);}
 798           ;
 799 decls1    : decls0 decl                 {$$ = gc2(cons($2,$1));}
 800           ;
 801 decl      : gendecl                     {$$ = $1;}
 802           | funlhs rhs                  {$$ = gc2(ap(FUNBIND,pair($1,$2)));}
 803           | funlhs COCO type rhs        {$$ = gc4(ap(FUNBIND,
 804                                                      pair($1,ap(RSIGN,
 805                                                                 ap($4,$3)))));}
 806           | pat0 rhs                    {$$ = gc2(ap(PATBIND,pair($1,$2)));}
 807           ;
 808 funlhs    : funlhs0                     {$$ = $1;}
 809           | funlhs1                     {$$ = $1;}
 810           | npk                         {$$ = $1;}
 811           ;
 812 funlhs0   : pat10_vI varop    pat0      {$$ = gc3(ap2($2,$1,$3));}
 813           | infixPat varop    pat0      {$$ = gc3(ap2($2,$1,$3));}
 814           | NUMLIT   varop    pat0      {$$ = gc3(ap2($2,$1,$3));}
 815           | var      varop_pl pat0      {$$ = gc3(ap2($2,$1,$3));}
 816           | var      '+'      pat0_INT  {$$ = gc3(ap2(varPlus,$1,$3));}
 817           ;
 818 funlhs1   : '(' funlhs0 ')' apat        {$$ = gc4(ap($2,$4));}
 819           | '(' funlhs1 ')' apat        {$$ = gc4(ap($2,$4));}
 820           | '(' npk     ')' apat        {$$ = gc4(ap($2,$4));}
 821           | var     apat                {$$ = gc2(ap($1,$2));}
 822           | funlhs1 apat                {$$ = gc2(ap($1,$2));}
 823           ;
 824 rhs       : rhs1 wherePart              {$$ = gc2(letrec($2,$1));}
 825           | error                       {syntaxError("declaration");}
 826           ;
 827 rhs1      : '=' exp                     {$$ = gc2(pair($1,$2));}
 828           | gdrhs                       {$$ = gc1(grded(rev($1)));}
 829           ;
 830 gdrhs     : gdrhs gddef                 {$$ = gc2(cons($2,$1));}
 831           | gddef                       {$$ = gc1(singleton($1));}
 832           ;
 833 gddef     : '|' exp0 '=' exp            {$$ = gc4(pair($3,pair($2,$4)));}
 834           ;
 835 wherePart : /* empty */                 {$$ = gc0(NIL);}
 836           | WHERE decls                 {$$ = gc2($2);}
 837           ;
 838
 839 /*- Patterns: -------------------------------------------------------------*/
 840
 841 pat       : npk                         {$$ = $1;}
 842           | pat_npk                     {$$ = $1;}
 843           ;
 844 pat_npk   : pat0 COCO type              {$$ = gc3(ap(ESIGN,pair($1,$3)));}
 845           | pat0                        {$$ = $1;}
 846           ;
 847 npk       : var '+' NUMLIT              {$$ = gc3(ap2(varPlus,$1,$3));}
 848           ;
 849 pat0      : var                         {$$ = $1;}
 850           | NUMLIT                      {$$ = $1;}
 851           | pat0_vI                     {$$ = $1;}
 852           ;
 853 pat0_INT  : var                         {$$ = $1;}
 854           | pat0_vI                     {$$ = $1;}
 855           ;
 856 pat0_vI   : pat10_vI                    {$$ = $1;}
 857           | infixPat                    {$$ = gc1(ap(INFIX,$1));}
 858           ;
 859 infixPat  : '-' pat10                   {$$ = gc2(ap(NEG,only($2)));}
 860           | var qconop pat10            {$$ = gc3(ap(ap($2,only($1)),$3));}
 861           | var qconop '-' pat10        {$$ = gc4(ap(NEG,ap2($2,only($1),$4)));}
 862           | NUMLIT qconop pat10         {$$ = gc3(ap(ap($2,only($1)),$3));}
 863           | NUMLIT qconop '-' pat10     {$$ = gc4(ap(NEG,ap2($2,only($1),$4)));}
 864           | pat10_vI qconop pat10       {$$ = gc3(ap(ap($2,only($1)),$3));}
 865           | pat10_vI qconop '-' pat10   {$$ = gc4(ap(NEG,ap2($2,only($1),$4)));}
 866           | infixPat qconop pat10       {$$ = gc3(ap(ap($2,$1),$3));}
 867           | infixPat qconop '-' pat10   {$$ = gc4(ap(NEG,ap(ap($2,$1),$4)));}
 868           ;
 869 pat10     : fpat                        {$$ = $1;}
 870           | apat                        {$$ = $1;}
 871           ;
 872 pat10_vI  : fpat                        {$$ = $1;}
 873           | apat_vI                     {$$ = $1;}
 874           ;
 875 fpat      : fpat apat                   {$$ = gc2(ap($1,$2));}
 876           | gcon apat                   {$$ = gc2(ap($1,$2));}
 877           ;
 878 apat      : NUMLIT                      {$$ = $1;}
 879           | var                         {$$ = $1;}
 880           | apat_vI                     {$$ = $1;}
 881           ;
 882 apat_vI   : var '@' apat                {$$ = gc3(ap(ASPAT,pair($1,$3)));}
 883           | gcon                        {$$ = $1;}
 884           | qcon '{' patbinds '}'       {$$ = gc4(ap(CONFLDS,pair($1,$3)));}
 885           | CHARLIT                     {$$ = $1;}
 886           | STRINGLIT                   {$$ = $1;}
 887           | '_'                         {$$ = gc1(WILDCARD);}
 888           | '(' pat_npk ')'             {$$ = gc3($2);}
 889           | '(' npk ')'                 {$$ = gc3($2);}
 890           | '(' pats2 ')'               {$$ = gc3(buildTuple($2));}
 891           | '[' pats1 ']'               {$$ = gc3(ap(FINLIST,rev($2)));}
 892           | '~' apat                    {$$ = gc2(ap(LAZYPAT,$2));}
 893 /*#if TREX*/
 894           | '(' patfields ')'           {
 895 #if TREX
 896                                          $$ = gc3(revOnto($2,nameNoRec));
 897 #else
 898                                          $$ = gc3(NIL);
 899 #endif
 900                                         }
 901           | '(' patfields '|' pat ')'   {$$ = gc5(revOnto($2,$4));}
 902 /*#endif TREX*/
 903           ;
 904 pats2     : pats2 ',' pat               {$$ = gc3(cons($3,$1));}
 905           | pat ',' pat                 {$$ = gc3(cons($3,singleton($1)));}
 906           ;
 907 pats1     : pats1 ',' pat               {$$ = gc3(cons($3,$1));}
 908           | pat                         {$$ = gc1(singleton($1));}
 909           ;
 910 patbinds  : /* empty */                 {$$ = gc0(NIL);}
 911           | patbinds1                   {$$ = gc1(rev($1));}
 912           ;
 913 patbinds1 : patbinds1 ',' patbind       {$$ = gc3(cons($3,$1));}
 914           | patbind                     {$$ = gc1(singleton($1));}
 915           ;
 916 patbind   : qvar '=' pat                {$$ = gc3(pair($1,$3));}
 917           | var                         {$$ = $1;}
 918           ;
 919 /*#if TREX*/
 920 patfields : patfields ',' patfield      {$$ = gc3(cons($3,$1));}
 921           | patfield                    {$$ = gc1(singleton($1));}
 922           ;
 923 patfield  : varid '=' pat               {
 924 #if TREX
 925                                          $$ = gc3(ap(mkExt(textOf($1)),$3));
 926 #else
 927                                          noTREX("a pattern");
 928 #endif
 929                                         }
 930           ;
 931 /*#endif TREX*/
 932
 933 /*- Expressions: ----------------------------------------------------------*/
 934
 935 exp       : exp_err                     {$$ = $1;}
 936           | error                       {syntaxError("expression");}
 937           ;
 938 exp_err   : exp0a COCO sigType          {$$ = gc3(ap(ESIGN,pair($1,$3)));}
 939           | exp0                        {$$ = $1;}
 940           ;
 941 exp0      : exp0a                       {$$ = $1;}
 942           | exp0b                       {$$ = $1;}
 943           ;
 944 exp0a     : infixExpa                   {$$ = gc1(ap(INFIX,$1));}
 945           | exp10a                      {$$ = $1;}
 946           ;
 947 exp0b     : infixExpb                   {$$ = gc1(ap(INFIX,$1));}
 948           | exp10b                      {$$ = $1;}
 949           ;
 950 infixExpa : infixExpa qop '-' exp10a    {$$ = gc4(ap(NEG,ap(ap($2,$1),$4)));}
 951           | infixExpa qop exp10a        {$$ = gc3(ap(ap($2,$1),$3));}
 952           | '-' exp10a                  {$$ = gc2(ap(NEG,only($2)));}
 953           | exp10a qop '-' exp10a       {$$ = gc4(ap(NEG,
 954                                                      ap(ap($2,only($1)),$4)));}
 955           | exp10a qop exp10a           {$$ = gc3(ap(ap($2,only($1)),$3));}
 956           ;
 957 infixExpb : infixExpa qop '-' exp10b    {$$ = gc4(ap(NEG,ap(ap($2,$1),$4)));}
 958           | infixExpa qop exp10b        {$$ = gc3(ap(ap($2,$1),$3));}
 959           | '-' exp10b                  {$$ = gc2(ap(NEG,only($2)));}
 960           | exp10a qop '-' exp10b       {$$ = gc4(ap(NEG,
 961                                                      ap(ap($2,only($1)),$4)));}
 962           | exp10a qop exp10b           {$$ = gc3(ap(ap($2,only($1)),$3));}
 963           ;
 964 exp10a    : CASEXP exp OF '{' alts end  {$$ = gc6(ap(CASE,pair($2,rev($5))));}
 965           | DO '{' stmts end            {$$ = gc4(ap(DOCOMP,checkDo($3)));}
 966           | appExp                      {$$ = $1;}
 967           ;
 968 exp10b    : '\\' pats ARROW exp         {$$ = gc4(ap(LAMBDA,
 969                                                      pair(rev($2),
 970                                                           pair($3,$4))));}
 971           | LET decls IN exp            {$$ = gc4(letrec($2,$4));}
 972           | IF exp THEN exp ELSE exp    {$$ = gc6(ap(COND,triple($2,$4,$6)));}
 973           ;
 974 pats      : pats apat                   {$$ = gc2(cons($2,$1));}
 975           | apat                        {$$ = gc1(cons($1,NIL));}
 976           ;
 977 appExp    : appExp aexp                 {$$ = gc2(ap($1,$2));}
 978           | aexp                        {$$ = $1;}
 979           ;
 980 aexp      : qvar                        {$$ = $1;}
 981           | qvar '@' aexp               {$$ = gc3(ap(ASPAT,pair($1,$3)));}
 982           | '~' aexp                    {$$ = gc2(ap(LAZYPAT,$2));}
 983           | '_'                         {$$ = gc1(WILDCARD);}
 984           | gcon                        {$$ = $1;}
 985           | qcon '{' fbinds '}'         {$$ = gc4(ap(CONFLDS,pair($1,$3)));}
 986           | aexp '{' fbinds '}'         {$$ = gc4(ap(UPDFLDS,
 987                                                      triple($1,NIL,$3)));}
 988           | NUMLIT                      {$$ = $1;}
 989           | CHARLIT                     {$$ = $1;}
 990           | STRINGLIT                   {$$ = $1;}
 991           | REPEAT                      {$$ = $1;}
 992           | '(' exp ')'                 {$$ = gc3($2);}
 993           | '(' exps2 ')'               {$$ = gc3(buildTuple($2));}
 994 /*#if TREX*/
 995           | '(' vfields ')'             {
 996 #if TREX
 997                                          $$ = gc3(revOnto($2,nameNoRec));
 998 #else
 999                                          $$ = gc3(NIL);
1000 #endif
1001                                         }
1002           | '(' vfields '|' exp ')'     {$$ = gc5(revOnto($2,$4));}
1003           | RECSELID                    {$$ = $1;}
1004 /*#endif*/
1005           | '[' list ']'                {$$ = gc3($2);}
1006           | '(' exp10a qop ')'          {$$ = gc4(ap($3,$2));}
1007           | '(' qvarop_mi exp0 ')'      {$$ = gc4(ap(ap(nameFlip,$2),$3));}
1008           | '(' qconop exp0 ')'         {$$ = gc4(ap(ap(nameFlip,$2),$3));}
1009           ;
1010 exps2     : exps2 ',' exp               {$$ = gc3(cons($3,$1));}
1011           | exp ',' exp                 {$$ = gc3(cons($3,cons($1,NIL)));}
1012           ;
1013 /*#if TREX*/
1014 vfields   : vfields ',' vfield          {$$ = gc3(cons($3,$1));}
1015           | vfield                      {$$ = gc1(singleton($1));}
1016           ;
1017 vfield    : varid '=' exp               {
1018 #if TREX
1019                                          $$ = gc3(ap(mkExt(textOf($1)),$3));
1020 #else
1021                                          noTREX("an expression");
1022 #endif
1023                                         }
1024           ;
1025 /*#endif*/
1026 alts      : alts1                       {$$ = $1;}
1027           | alts1 ';'                   {$$ = gc2($1);}
1028           ;
1029 alts1     : alts1 ';' alt               {$$ = gc3(cons($3,$1));}
1030           | alt                         {$$ = gc1(cons($1,NIL));}
1031           ;
1032 alt       : pat altRhs wherePart        {$$ = gc3(pair($1,letrec($3,$2)));}
1033           ;
1034 altRhs    : guardAlts                   {$$ = gc1(grded(rev($1)));}
1035           | ARROW exp                   {$$ = gc2(pair($1,$2));}
1036           | error                       {syntaxError("case expression");}
1037           ;
1038 guardAlts : guardAlts guardAlt          {$$ = gc2(cons($2,$1));}
1039           | guardAlt                    {$$ = gc1(cons($1,NIL));}
1040           ;
1041 guardAlt  : '|' exp0 ARROW exp          {$$ = gc4(pair($3,pair($2,$4)));}
1042           ;
1043 stmts     : stmts1 ';'                  {$$ = gc2($1);}
1044           | stmts1                      {$$ = $1;}
1045           ;
1046 stmts1    : stmts1 ';' stmt             {$$ = gc3(cons($3,$1));}
1047           | stmt                        {$$ = gc1(cons($1,NIL));}
1048           ;
1049 stmt      : exp_err FROM exp            {$$ = gc3(ap(FROMQUAL,pair($1,$3)));}
1050           | LET decls                   {$$ = gc2(ap(QWHERE,$2));}
1051 /*        | IF exp                      {$$ = gc2(ap(BOOLQUAL,$2));}*/
1052           | exp_err                     {$$ = gc1(ap(DOQUAL,$1));}
1053           ;
1054 fbinds    : /* empty */                 {$$ = gc0(NIL);}
1055           | fbinds1                     {$$ = gc1(rev($1));}
1056           ;
1057 fbinds1   : fbinds1 ',' fbind           {$$ = gc3(cons($3,$1));}
1058           | fbind                       {$$ = gc1(singleton($1));}
1059           ;
1060 fbind     : var                         {$$ = $1;}
1061           | qvar '=' exp                {$$ = gc3(pair($1,$3));}
1062           ;
1063
1064 /*- List Expressions: -------------------------------------------------------*/
1065
1066 list      : exp                         {$$ = gc1(ap(FINLIST,cons($1,NIL)));}
1067           | exps2                       {$$ = gc1(ap(FINLIST,rev($1)));}
1068           | exp '|' quals               {$$ = gc3(ap(COMP,pair($1,rev($3))));}
1069           | exp         UPTO exp        {$$ = gc3(ap(ap(nameFromTo,$1),$3));}
1070           | exp ',' exp UPTO            {$$ = gc4(ap(ap(nameFromThen,$1),$3));}
1071           | exp         UPTO            {$$ = gc2(ap(nameFrom,$1));}
1072           | exp ',' exp UPTO exp        {$$ = gc5(ap(ap(ap(nameFromThenTo,
1073                                                                 $1),$3),$5));}
1074           ;
1075 quals     : quals ',' qual              {$$ = gc3(cons($3,$1));}
1076           | qual                        {$$ = gc1(cons($1,NIL));}
1077           ;
1078 qual      : exp FROM exp                {$$ = gc3(ap(FROMQUAL,pair($1,$3)));}
1079           | exp                         {$$ = gc1(ap(BOOLQUAL,$1));}
1080           | LET decls                   {$$ = gc2(ap(QWHERE,$2));}
1081           ;
1082
1083 /*- Identifiers and symbols: ----------------------------------------------*/
1084
1085 gcon      : qcon                        {$$ = $1;}
1086           | '(' ')'                     {$$ = gc2(nameUnit);}
1087           | '[' ']'                     {$$ = gc2(nameNil);}
1088           | '(' tupCommas ')'           {$$ = gc3($2);}
1089           ;
1090 tupCommas : tupCommas ','               {$$ = gc2(mkTuple(tupleOf($1)+1));}
1091           | ','                         {$$ = gc1(mkTuple(2));}
1092           ;
1093 varid     : VARID                       {$$ = $1;}
1094           | HIDING                      {$$ = gc1(varHiding);}
1095           | QUALIFIED                   {$$ = gc1(varQualified);}
1096           | ASMOD                       {$$ = gc1(varAsMod);}
1097           ;
1098 qconid    : QCONID                      {$$ = $1;}
1099           | CONID                       {$$ = $1;}
1100           ;
1101 var       : varid                       {$$ = $1;}
1102           | '(' VAROP ')'               {$$ = gc3($2);}
1103           | '(' '+' ')'                 {$$ = gc3(varPlus);}
1104           | '(' '-' ')'                 {$$ = gc3(varMinus);}
1105           | '(' '!' ')'                 {$$ = gc3(varBang);}
1106           | '(' '.' ')'                 {$$ = gc3(varDot);}
1107           ;
1108 qvar      : QVARID                      {$$ = $1;}
1109           | '(' QVAROP ')'              {$$ = gc3($2);}
1110           | var                         {$$ = $1;}
1111           ;
1112 con       : CONID                       {$$ = $1;}
1113           | '(' CONOP ')'               {$$ = gc3($2);}
1114           ;
1115 qcon      : QCONID                      {$$ = $1;}
1116           | '(' QCONOP ')'              {$$ = gc3($2);}
1117           | con                         {$$ = $1;}
1118           ;
1119 varop     : '+'                         {$$ = gc1(varPlus);}
1120           | '-'                         {$$ = gc1(varMinus);}
1121           | varop_mipl                  {$$ = $1;}
1122           ;
1123 varop_mi  : '+'                         {$$ = gc1(varPlus);}
1124           | varop_mipl                  {$$ = $1;}
1125           ;
1126 varop_pl  : '-'                         {$$ = gc1(varMinus);}
1127           | varop_mipl                  {$$ = $1;}
1128           ;
1129 varop_mipl: VAROP                       {$$ = $1;}
1130           | '`' varid '`'               {$$ = gc3($2);}
1131           | '!'                         {$$ = gc1(varBang);}
1132           | '.'                         {$$ = gc1(varDot);}
1133           ;
1134 qvarop    : '-'                         {$$ = gc1(varMinus);}
1135           | qvarop_mi                   {$$ = $1;}
1136           ;
1137 qvarop_mi : QVAROP                      {$$ = $1;}
1138           | '`' QVARID '`'              {$$ = gc3($2);}
1139           | varop_mi                    {$$ = $1;}
1140           ;
1141
1142 conop     : CONOP                       {$$ = $1;}
1143           | '`' CONID  '`'              {$$ = gc3($2);}
1144           ;
1145 qconop    : QCONOP                      {$$ = $1;}
1146           | '`' QCONID '`'              {$$ = gc3($2);}
1147           | conop                       {$$ = $1;}
1148           ;
1149 op        : varop                       {$$ = $1;}
1150           | conop                       {$$ = $1;}
1151           ;
1152 qop       : qvarop                      {$$ = $1;}
1153           | qconop                      {$$ = $1;}
1154           ;
1155
1156 /*- Stuff from STG hugs ---------------------------------------------------*/
1157
1158 qvarid    : varid1                      {$$ = gc1($1);}
1159           | QVARID                      {$$ = gc1($1);}
1160
1161 varid1    : VARID                       {$$ = gc1($1);}
1162           | HIDING                      {$$ = gc1(varHiding);}
1163           | QUALIFIED                   {$$ = gc1(varQualified);}
1164           | ASMOD                       {$$ = gc1(varAsMod);}
1165           ;
1166
1167 /*- Tricks to force insertion of leading and closing braces ---------------*/
1168
1169 begin     : error                       {yyerrok;
1170                                          if (offsideON) goOffside(startColumn);}
1171           ;
1172                                         /* deal with trailing semicolon    */
1173 end       : '}'                         {$$ = $1;}
1174           | error                       {yyerrok;
1175                                          if (offsideON && canUnOffside()) {
1176                                              unOffside();
1177                                              /* insert extra token on stack*/
1178                                              push(NIL);
1179                                              pushed(0) = pushed(1);
1180                                              pushed(1) = mkInt(column);
1181                                          }
1182                                          else
1183                                              syntaxError("definition");
1184                                         }
1185           ;
1186
1187 /*-------------------------------------------------------------------------*/
1188
1189 %%
1190
1191 static Cell local gcShadow(n,e)         /* keep parsed fragments on stack  */
1192 Int  n;
1193 Cell e; {
1194     /* If a look ahead token is held then the required stack transformation
1195      * is:
1196      *   pushed: n               1     0          1     0
1197      *           x1  |  ...  |  xn  |  la   ===>  e  |  la
1198      *                                top()            top()
1199      *
1200      * Otherwise, the transformation is:
1201      *   pushed: n-1             0        0
1202      *           x1  |  ...  |  xn  ===>  e
1203      *                         top()     top()
1204      */
1205     if (yychar>=0) {
1206         pushed(n-1) = top();
1207         pushed(n)   = e;
1208     }
1209     else
1210         pushed(n-1) = e;
1211     sp -= (n-1);
1212     return e;
1213 }
1214
1215 static Void local syntaxError(s)        /* report on syntax error          */
1216 String s; {
1217     ERRMSG(row) "Syntax error in %s (unexpected %s)", s, unexpected()
1218     EEND;
1219 }
1220
1221 static String local unexpected() {     /* find name for unexpected token   */
1222     static char buffer[100];
1223     static char *fmt = "%s \"%s\"";
1224     static char *kwd = "keyword";
1225
1226     switch (yychar) {
1227         case 0         : return "end of input";
1228
1229 #define keyword(kw) sprintf(buffer,fmt,kwd,kw); return buffer;
1230         case INFIXL    : keyword("infixl");
1231         case INFIXR    : keyword("infixr");
1232         case INFIXN    : keyword("infix");
1233         case FOREIGN   : keyword("foreign");
1234         case UNSAFE    : keyword("unsafe");
1235         case TINSTANCE : keyword("instance");
1236         case TCLASS    : keyword("class");
1237         case CASEXP    : keyword("case");
1238         case OF        : keyword("of");
1239         case IF        : keyword("if");
1240         case THEN      : keyword("then");
1241         case ELSE      : keyword("else");
1242         case WHERE     : keyword("where");
1243         case TYPE      : keyword("type");
1244         case DATA      : keyword("data");
1245         case TNEWTYPE  : keyword("newtype");
1246         case LET       : keyword("let");
1247         case IN        : keyword("in");
1248         case DERIVING  : keyword("deriving");
1249         case DEFAULT   : keyword("default");
1250         case IMPORT    : keyword("import");
1251         case TMODULE   : keyword("module");
1252         case ALL       : keyword("__forall");
1253 #undef keyword
1254
1255         case ARROW     : return "`->'";
1256         case '='       : return "`='";
1257         case COCO      : return "`::'";
1258         case '-'       : return "`-'";
1259         case '!'       : return "`!'";
1260         case ','       : return "comma";
1261         case '@'       : return "`@'";
1262         case '('       : return "`('";
1263         case ')'       : return "`)'";
1264         case '{'       : return "`{'";
1265         case '}'       : return "`}'";
1266         case '_'       : return "`_'";
1267         case '|'       : return "`|'";
1268         case '.'       : return "`.'";
1269         case ';'       : return "`;'";
1270         case UPTO      : return "`..'";
1271         case '['       : return "`['";
1272         case ']'       : return "`]'";
1273         case FROM      : return "`<-'";
1274         case '\\'      : return "backslash (lambda)";
1275         case '~'       : return "tilde";
1276         case '`'       : return "backquote";
1277 #if TREX
1278         case RECSELID  : sprintf(buffer,"selector \"#%s\"",
1279                                  textToStr(extText(snd(yylval))));
1280                          return buffer;
1281 #endif
1282         case VAROP     :
1283         case VARID     :
1284         case CONOP     :
1285         case CONID     : sprintf(buffer,"symbol \"%s\"",
1286                                  textToStr(textOf(yylval)));
1287                          return buffer;
1288         case QVAROP    :
1289         case QVARID    :
1290         case QCONOP    :
1291         case QCONID    : sprintf(buffer,"symbol \"%s\"",
1292                                  identToStr(yylval));
1293                          return buffer;
1294         case HIDING    : return "symbol \"hiding\"";
1295         case QUALIFIED : return "symbol \"qualified\"";
1296         case ASMOD     : return "symbol \"as\"";
1297         case NUMLIT    : return "numeric literal";
1298         case CHARLIT   : return "character literal";
1299         case STRINGLIT : return "string literal";
1300         case IMPLIES   : return "`=>'";
1301         default        : return "token";
1302     }
1303 }
1304
1305 static Cell local checkPrec(p)          /* Check for valid precedence value*/
1306 Cell p; {
1307     if (!isInt(p) || intOf(p)<MIN_PREC || intOf(p)>MAX_PREC) {
1308         ERRMSG(row) "Precedence value must be an integer in the range [%d..%d]",
1309                     MIN_PREC, MAX_PREC
1310         EEND;
1311     }
1312     return p;
1313 }
1314
1315 static Cell local buildTuple(tup)       /* build tuple (x1,...,xn) from    */
1316 List tup; {                             /* list [xn,...,x1]                */
1317     Int  n = 0;
1318     Cell t = tup;
1319     Cell x;
1320
1321     do {                                /*    .                    .       */
1322         x      = fst(t);                /*   / \                  / \      */
1323         fst(t) = snd(t);                /*  xn  .                .   xn    */
1324         snd(t) = x;                     /*       .    ===>      .          */
1325         x      = t;                     /*        .            .           */
1326         t      = fun(x);                /*         .          .            */
1327         n++;                            /*        / \        / \           */
1328     } while (nonNull(t));               /*       x1  NIL   (n)  x1         */
1329     fst(x) = mkTuple(n);
1330     return tup;
1331 }
1332
1333 static List local checkContext(con)     /* validate context                */
1334 Type con; {
1335     mapOver(checkPred, con);
1336     return con;
1337 }
1338
1339 static Cell local checkPred(c)          /* check that type expr is a valid */
1340 Cell c; {                               /* constraint                      */
1341     Cell cn = getHead(c);
1342 #if TREX
1343     if (isExt(cn) && argCount==1)
1344         return c;
1345 #endif
1346     if (!isQCon(cn) || argCount==0)
1347         syntaxError("class expression");
1348     return c;
1349 }
1350
1351 static Pair local checkDo(dqs)          /* convert reversed list of dquals */
1352 List dqs; {                             /* to an (expr,quals) pair         */
1353     if (isNull(dqs) || whatIs(hd(dqs))!=DOQUAL) {
1354         ERRMSG(row) "Last generator in do {...} must be an expression"
1355         EEND;
1356     }
1357     fst(dqs) = snd(fst(dqs));           /* put expression in fst of pair   */
1358     snd(dqs) = rev(snd(dqs));           /* & reversed list of quals in snd */
1359     return dqs;
1360 }
1361
1362 static Cell local checkTyLhs(c)         /* check that lhs is of the form   */
1363 Cell c; {                               /* T a1 ... a                      */
1364     Cell tlhs = c;
1365     while (isAp(tlhs) && whatIs(arg(tlhs))==VARIDCELL)
1366         tlhs = fun(tlhs);
1367     switch (whatIs(tlhs)) {
1368         case CONIDCELL  : return c;
1369
1370         default :
1371             ERRMSG(row) "Illegal left hand side in datatype definition"
1372             EEND;
1373     }
1374     return 0; /* NOTREACHED */
1375 }
1376
1377 #if !TREX
1378 static Void local noTREX(where)
1379 String where; {
1380     ERRMSG(row) "Attempt to use TREX records while parsing %s.\n", where ETHEN
1381     ERRTEXT     "(TREX is disabled in this build of Hugs)"
1382     EEND;
1383 }
1384 #endif
1385
1386 /*-------------------------------------------------------------------------*/