ghc/interpreter/parser.y

   1 /* -*- mode: hugs-c; -*- */
   2 /* --------------------------------------------------------------------------
   3  * Hugs parser (included as part of input.c)
   4  *
   5  * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
   6  * All rights reserved. See NOTICE for details and conditions of use etc...
   7  * Hugs version 1.4, December 1997
   8  *
   9  * Expect 24 shift/reduce conflicts when passing this grammar through yacc,
  10  * but don't worry; they will all be resolved in an appropriate manner.
  11  *
  12  * $RCSfile: parser.y,v $
  13  * $Revision: 1.2 $
  14  * $Date: 1998/12/02 13:22:26 $
  15  * ------------------------------------------------------------------------*/
  16
  17 %{
  18 #ifndef lint
  19 #define lint
  20 #endif
  21 #define defTycon(n,l,lhs,rhs,w)  tyconDefn(intOf(l),lhs,rhs,w); sp-=n
  22 #define sigdecl(l,vs,t)          ap(SIGDECL,triple(l,vs,t))
  23 #define grded(gs)                ap(GUARDED,gs)
  24 #define bang(t)                  ap(BANG,t)
  25 #define only(t)                  ap(ONLY,t)
  26 #define letrec(bs,e)             (nonNull(bs) ? ap(LETREC,pair(bs,e)) : e)
  27 #define exportSelf()             singleton(ap(MODULEENT,mkCon(module(currentModule).text)))
  28 #define yyerror(s)               /* errors handled elsewhere */
  29 #define YYSTYPE                  Cell
  30
  31 static Cell   local gcShadow     Args((Int,Cell));
  32 static Void   local syntaxError  Args((String));
  33 static String local unexpected   Args((Void));
  34 static Cell   local checkPrec    Args((Cell));
  35 static Void   local fixDefn      Args((Syntax,Cell,Cell,List));
  36 static Void   local setSyntax    Args((Int,Syntax,Cell));
  37 static Cell   local buildTuple   Args((List));
  38 static List   local checkContext Args((List));
  39 static Cell   local checkPred    Args((Cell));
  40 static Pair   local checkDo      Args((List));
  41 static Cell   local checkTyLhs   Args((Cell));
  42 #if !TREX
  43 static Void   local noTREX       Args((String));
  44 #endif
  45 static Cell   local tidyInfix    Args((Cell));
  46
  47 /* For the purposes of reasonably portable garbage collection, it is
  48  * necessary to simulate the YACC stack on the Hugs stack to keep
  49  * track of all intermediate constructs.  The lexical analyser
  50  * pushes a token onto the stack for each token that is found, with
  51  * these elements being removed as reduce actions are performed,
  52  * taking account of look-ahead tokens as described by gcShadow()
  53  * below.
  54  *
  55  * Of the non-terminals used below, only start, topDecl, fixDecl & begin
  56  * do not leave any values on the Hugs stack.  The same is true for the
  57  * terminals EXPR and SCRIPT.  At the end of a successful parse, there
  58  * should only be one element left on the stack, containing the result
  59  * of the parse.
  60  */
  61
  62 #define gc0(e)                   gcShadow(0,e)
  63 #define gc1(e)                   gcShadow(1,e)
  64 #define gc2(e)                   gcShadow(2,e)
  65 #define gc3(e)                   gcShadow(3,e)
  66 #define gc4(e)                   gcShadow(4,e)
  67 #define gc5(e)                   gcShadow(5,e)
  68 #define gc6(e)                   gcShadow(6,e)
  69 #define gc7(e)                   gcShadow(7,e)
  70
  71 %}
  72
  73 %token EXPR       SCRIPT
  74 %token CASEXP     OF         DATA       TYPE       IF
  75 %token THEN       ELSE       WHERE      LET        IN
  76 %token INFIX      INFIXL     INFIXR     FOREIGN    TNEWTYPE
  77 %token DEFAULT    DERIVING   DO         TCLASS     TINSTANCE
  78 %token REPEAT     ALL
  79 %token VAROP      VARID      NUMLIT     CHARLIT    STRINGLIT
  80 %token CONOP      CONID
  81 %token QVAROP     QVARID     QCONOP     QCONID
  82 /*#if TREX*/
  83 %token RECSELID
  84 /*#endif*/
  85 %token COCO       '='        UPTO       '@'        '\\'
  86 %token '|'        '-'        FROM       ARROW      '~'
  87 %token '!'        IMPLIES    '('        ','        ')'
  88 %token '['        ';'        ']'        '`'        '.'
  89 %token MODULETOK  IMPORT     HIDING     QUALIFIED  ASMOD
  90 %token EXPORT     INTERFACE  REQUIRES   UNSAFE
  91
  92 %%
  93 /*- Top level script/module structure: ------------------------------------*/
  94
  95 start     : EXPR exp wherePart          {inputExpr = letrec($3,$2); sp-=2;}
  96           | SCRIPT topModule            {valDefns  = $2;            sp-=1;}
  97           | INTERFACE iface             {sp-=1;}
  98           | error                       {syntaxError("input");}
  99           ;
 100
 101 /*- GHC interface file parsing: -------------------------------------------*/
 102
 103 /* Reading in an interface file is surprisingly like reading
 104  * a normal Haskell module: we read in a bunch of declarations,
 105  * construct symbol table entries, etc.  The "only" differences
 106  * are that there's no syntactic sugar to deal with and we don't
 107  * have to read in expressions.
 108  */
 109
 110 iface     : INTERFACE ifaceName NUMLIT checkVersion ifaceDecls { $$ = gc5(NIL); }
 111           | INTERFACE error             {syntaxError("interface file");}
 112           ;
 113
 114 ifaceName : CONID                       {openGHCIface(textOf($1)); $$ = gc1(NIL);}
 115           ;
 116
 117 ifaceDecls:                             {$$=gc0(NIL);}
 118           | ifaceDecl ';' ifaceDecls    {$$=gc3(cons($1,$2));}
 119           ;
 120
 121 /* We use ifaceData in data decls so as to include () */
 122 ifaceDecl : IMPORT CONID NUMLIT         { extern String scriptFile;
 123                                           String fileName = findPathname(scriptFile,textToStr(textOf($2)));
 124                                           addGHCImport(intOf($1),textOf($2),fileName);
 125                                           $$ = gc3(NIL);
 126                                         }
 127           | EXPORT CONID ifaceEntities  {}
 128           | REQUIRES STRINGLIT          { extern String scriptFile;
 129                                           String fileName = findPathname(scriptFile,textToStr(textOf($2)));
 130                                           loadSharedLib(fileName);
 131                                           $$ = gc2(NIL);
 132                                         }
 133           | INFIXL optdigit op                                                   { fixDefn(LEFT_ASS,$1,$2,$3);                 $$ = gc3(NIL); }
 134           | INFIXR optdigit op                                                   { fixDefn(RIGHT_ASS,$1,$2,$3);                $$ = gc3(NIL); }
 135           | INFIX  optdigit op                                                   { fixDefn(NON_ASS,$1,$2,$3);                  $$ = gc3(NIL); }
 136           | TINSTANCE ifaceQuant ifaceClass '=' ifaceVar                         { addGHCInstance(intOf($1),$2,$3,textOf($5)); $$ = gc5(NIL); }
 137           | NUMLIT TYPE     ifaceTCName ifaceTVBndrs '=' ifaceType               { addGHCSynonym(intOf($2),$3,$4,$6);          $$ = gc6(NIL); }
 138           | NUMLIT DATA     ifaceData   ifaceTVBndrs ifaceConstrs ifaceSels      { addGHCDataDecl(intOf($2),$3,$4,$5,$6);      $$ = gc6(NIL); }
 139           | NUMLIT TNEWTYPE ifaceTCName ifaceTVBndrs ifaceNewTypeConstr          { addGHCNewType(intOf($2),$3,$4,$5);          $$ = gc5(NIL); }
 140           | NUMLIT TCLASS   ifaceDeclContext ifaceTCName ifaceTVBndrs ifaceCSigs { addGHCClass(intOf($2),$3,$4,$5,$6);         $$ = gc6(NIL); }
 141           | NUMLIT ifaceVar COCO ifaceType                                       { addGHCVar(intOf($3),textOf($2),$4);         $$ = gc4(NIL); }
 142           | error                                                                { syntaxError("interface declaration"); }
 143           ;
 144
 145 checkVersion
 146           : NUMLIT                      { $$ = gc1(NIL); }
 147           ;
 148
 149 ifaceSels /* [(VarId,Type)] */
 150           :                             { $$ = gc0(NIL); }
 151           | WHERE '{' ifaceSels1 '}'    { $$ = gc4($3); }
 152           ;
 153
 154 ifaceSels1 /* [(VarId,Type)] */
 155           : ifaceSel                    { $$ = gc1(singleton($1)); }
 156           | ifaceSel ';' ifaceSels1     { $$ = gc3(cons($1,$3)); }
 157           ;
 158
 159 ifaceSel /* (VarId,Type) */
 160           : ifaceVarName COCO ifaceType { $$ = gc3(pair($1,$3)); }
 161           ;
 162
 163 ifaceCSigs /* [(VarId,Type)] */
 164           :                             { $$ = gc0(NIL); }
 165           | WHERE '{' ifaceCSigs1 '}'   { $$ = gc4($3); }
 166           ;
 167
 168 ifaceCSigs1 /* [(VarId,Type)] */
 169           : ifaceCSig                   { $$ = gc1(singleton($1)); }
 170           | ifaceCSig ';' ifaceCSigs1   { $$ = gc3(cons($1,$3));    }
 171           ;
 172
 173 ifaceCSig /* (VarId,Type) */
 174           : ifaceVarName     COCO ifaceType { $$ = gc3(pair($1,$3)); }
 175           | ifaceVarName '=' COCO ifaceType { $$ = gc4(pair($1,$4)); } /* has default method */
 176           ;
 177
 178 ifaceConstrs /* [(ConId,[VarId],Type)] */
 179           :                             { $$ = gc0(NIL); }
 180           | '=' ifaceConstrs1           { $$ = gc2($2);  }
 181           ;
 182
 183 ifaceConstrs1 /* [(ConId,[VarId],Type)] */
 184           : ifaceConstr                   { $$ = gc1(singleton($1)); }
 185           | ifaceConstr '|' ifaceConstrs1 { $$ = gc3(cons($1,$3));   }
 186           ;
 187
 188 /* We use ifaceData so as to include () */
 189 ifaceConstr /* (ConId,[VarId],Type) */
 190           : ifaceData                        COCO ifaceType { $$ = gc3(triple($1,NIL,$3)); }
 191           | ifaceData '{' ifaceVarNames1 '}' COCO ifaceType { $$ = gc6(triple($1,$3,$6));  }
 192           ;
 193
 194 ifaceNewTypeConstr /* (ConId,Type) */
 195           :                                   { $$ = gc0(NIL);         }
 196           | '=' ifaceDataName COCO ifaceType  { $$ = gc4(pair($2,$4)); }
 197           ;
 198
 199 ifaceQuant /* Maybe ([(VarId,Kind)],[(ConId, [Type])]) */
 200           :                                      { $$ = gc0(NIL); }
 201           | ALL ifaceForall ifaceContext IMPLIES { $$ = gc4(pair($2,$3)); }
 202           ;
 203
 204 ifaceType
 205           : ALL ifaceForall ifaceContext IMPLIES ifaceType { $$ = gc5(ap(POLYTYPE,triple($2,$3,$5))); }
 206           | ifaceBType ARROW ifaceType          { $$ = gc3(fn($1,$3)); }
 207           | ifaceBType                          { $$ = gc1($1); }
 208           ;
 209
 210 ifaceForall /* [(VarId,Kind)] */
 211           : '[' ifaceTVBndrs ']'                { $$ = gc3($2); }
 212           ;
 213
 214 ifaceDeclContext /* [(ConId, [Type])] */
 215           :                                     { $$ = gc0(NIL); }
 216           | '{' ifaceContextList1 '}' IMPLIES   { $$ = gc4($2);  }
 217           ;
 218
 219 ifaceContext /* [(ConId, [Type])] */
 220           :                                     { $$ = gc0(NIL); }
 221           | '{' ifaceContextList1 '}'           { $$ = gc3($2);  }
 222           ;
 223
 224 ifaceContextList1 /* [(ConId, [Type])] */
 225           : ifaceClass                          { $$ = gc1(singleton($1)); }
 226           | ifaceClass ',' ifaceContextList1    { $$ = gc3(cons($1,$3));   }
 227           ;
 228
 229 ifaceClass /* (ConId, [Type]) */
 230           : ifaceQTCName ifaceATypes            { $$ = gc2(pair($1,$2)); }
 231           ;
 232
 233 ifaceTypes2
 234           : ifaceType ',' ifaceType             { $$ = gc3(doubleton($1,$3)); }
 235           | ifaceType ',' ifaceTypes2           { $$ = gc3(cons($1,$3));      }
 236           ;
 237
 238 ifaceBType
 239           : ifaceAType                          { $$ = gc1($1);        }
 240           | ifaceBType ifaceAType               { $$ = gc2(ap($1,$2)); }
 241           ;
 242
 243 ifaceAType
 244           : ifaceQTCName                        { $$ = gc1($1); }
 245           | ifaceTVName                         { $$ = gc1($1); }
 246           | '(' ')'                             { $$ = gc2(conPreludeUnit); }
 247           | '(' ifaceTypes2 ')'                 { $$ = gc3(buildTuple($2)); }
 248           | '[' ifaceType ']'                   { $$ = gc3(ap(conPreludeList,$2));}
 249           | '{' ifaceQTCName ifaceATypes '}'    { $$ = gc4(ap(DICTAP,pair($2,$3))); }
 250           | '(' ifaceType ')'                   { $$ = gc3($2); }
 251           ;
 252
 253 ifaceATypes
 254           :                                     { $$ = gc0(NIL);         }
 255           | ifaceAType ifaceATypes              { $$ = gc2(cons($1,$2)); }
 256           ;
 257
 258 ifaceEntities
 259           :                                     { $$ = gc0(NIL);         }
 260           | ifaceEntity ifaceEntities           { $$ = gc2(cons($1,$2)); }
 261           ;
 262
 263 ifaceEntity
 264           : ifaceEntityOcc                      {}
 265           | ifaceEntityOcc ifaceStuffInside     {}
 266 | ifaceEntityOcc '|' ifaceStuffInside {} /* exporting datacons but not tycon */
 267           ;
 268
 269 ifaceEntityOcc
 270           : ifaceVar                    { $$ = gc1($1); }
 271           | ifaceData                   { $$ = gc1($1); }
 272           | ARROW                       { $$ = gc3(typeArrow); }
 273           | '(' ARROW ')'               { $$ = gc3(typeArrow); }  /* why allow both? */
 274           ;
 275
 276 ifaceStuffInside
 277           : '{' ifaceValOccs '}'        { $$ = gc1($1); }
 278           ;
 279
 280
 281 ifaceValOccs
 282           : ifaceValOcc                 { $$ = gc1(singleton($1)); }
 283           | ifaceValOcc ifaceValOccs    { $$ = gc2(cons($1,$2));   }
 284           ;
 285
 286 ifaceValOcc
 287           : ifaceVar                    {$$ = gc1($1); }
 288           | ifaceData                   {$$ = gc1($1); }
 289           ;
 290
 291 ifaceVar  : VARID                       {$$ = gc1($1);      }
 292           | VAROP                       {$$ = gc1($1);      }
 293           | '!'                         {$$ = gc1(varBang); }
 294           | '.'                         {$$ = gc1(varDot);  }
 295           | '-'                         {$$ = gc1(varMinus);}
 296           ;
 297
 298 ifaceData /* ConId | QualConId */
 299           : CONID                       {$$ = gc1($1);}
 300           | CONOP                       {$$ = gc1($1);}
 301           | '(' ')'                     {$$ = gc2(conPreludeUnit);}
 302           | '[' ']'                     {$$ = gc2(conPreludeList);}
 303           ;
 304
 305 ifaceVarName /* VarId */
 306           : ifaceVar                    { $$ = gc1($1); }
 307           ;
 308
 309 ifaceDataName /* ConId|QualConId */
 310           : ifaceData                   { $$ = gc1($1); }
 311           ;
 312
 313 ifaceVarNames1 /* [VarId] */
 314           : ifaceVarName                { $$ = gc1(singleton($1)); }
 315           | ifaceVarName ifaceVarNames1 { $$ = gc2(cons($1,$2));   }
 316           ;
 317
 318 ifaceTVName /* VarId */
 319           : VARID                       { $$ = gc1($1); }
 320           ;
 321
 322 ifaceTVBndrs /* [(VarId,Kind)] */
 323           :                             { $$ = gc0(NIL);         }
 324           | ifaceTVBndr ifaceTVBndrs    { $$ = gc2(cons($1,$2)); }
 325           ;
 326
 327 ifaceTVBndr /* (VarId,Kind) */
 328           : ifaceTVName                 { $$ = gc1(pair($1,STAR)); }
 329           | ifaceTVName COCO ifaceAKind { $$ = gc3(pair($1,$3));   }
 330           ;
 331
 332 ifaceKind
 333           : ifaceAKind                  { $$ = gc1($1);        }
 334           | ifaceAKind ARROW ifaceKind  { $$ = gc3(fn($1,$3)); }
 335           ;
 336
 337 ifaceAKind
 338           : VAROP                       { $$ = gc1(STAR); } /* should be '*' */
 339           | '(' ifaceKind ')'           { $$ = gc1($1);   }
 340           ;
 341
 342 ifaceTCName
 343           : CONID                       { $$ = gc1($1); }
 344           | CONOP                       { $$ = gc1($1); }
 345           | '(' ARROW ')'               { $$ = gc3(typeArrow); }
 346           | '[' ']'                     { $$ = gc1(conPreludeList);  }
 347           ;
 348
 349 ifaceQTCName
 350           : ifaceTCName                 { $$ = gc1($1); }
 351           | QCONID                      { $$ = gc1($1); }
 352           | QCONOP                      { $$ = gc1($1); }
 353           ;
 354
 355 /*- Haskell module header/import parsing: ---------------------------------*/
 356
 357 /* In Haskell 1.2, the default module header was "module Main where"
 358  * In 1.3, this changed to "module Main(main) where".
 359  * We use the 1.2 header because it breaks much less pre-module code.
 360  */
 361 topModule : startMain begin modBody end {
 362                                          setExportList(singleton(ap(MODULEENT,mkCon(module(currentModule).text))));
 363                                          $$ = gc3($3);
 364                                         }
 365           | MODULETOK modname expspec WHERE '{' modBody end
 366                                         {setExportList($3);   $$ = gc7($6);}
 367           | MODULETOK error             {syntaxError("module definition");}
 368           ;
 369 /* To implement the Haskell module system, we have to keep track of the
 370  * current module.  We rely on the use of LALR parsing to ensure that this
 371  * side effect happens before any declarations within the module.
 372  */
 373 startMain : /* empty */                 {startModule(conMain);
 374                                          $$ = gc0(NIL);}
 375           ;
 376 modname   : CONID                       {startModule($1); $$ = gc1(NIL);}
 377           ;
 378 modid     : CONID                       {$$ = gc1($1);}
 379           | STRINGLIT                   { extern String scriptFile;
 380                                           String modName = findPathname(scriptFile,textToStr(textOf($1)));
 381                                           if (modName) { /* fillin pathname if known */
 382                                               $$ = mkStr(findText(modName));
 383                                           } else {
 384                                               $$ = $1;
 385                                           }
 386                                         }
 387           ;
 388 modBody   : topDecls                    {$$ = gc1($1);}
 389           | fixDecls ';' topDecls       {$$ = gc3($3);}
 390           | impDecls chase              {$$ = gc2(NIL);}
 391           | impDecls ';' chase topDecls {$$ = gc4($4);}
 392           | impDecls ';' chase fixDecls ';' topDecls
 393                                         {$$ = gc6($6);}
 394           ;
 395
 396 /*- Exports: --------------------------------------------------------------*/
 397
 398 expspec   : /* empty */                 {$$ = gc0(exportSelf());}
 399           | '(' ')'                     {$$ = gc2(NIL);}
 400           | '(' exports ')'             {$$ = gc3($2);}
 401           | '(' exports ',' ')'         {$$ = gc4($2);}
 402           ;
 403 exports   : exports ',' export          {$$ = gc3(cons($3,$1));}
 404           | export                      {$$ = gc1(singleton($1));}
 405           ;
 406 /* The qcon should be qconid.
 407  * Relaxing the rule lets us explicitly export (:) from the Prelude.
 408  */
 409 export    : qvar                        {$$ = gc1($1);}
 410           | qcon                        {$$ = gc1($1);}
 411           | qcon2 '(' UPTO ')'          {$$ = gc4(pair($1,DOTDOT));}
 412           | qcon2 '(' qnames ')'        {$$ = gc4(pair($1,$3));}
 413           | MODULETOK modid             {$$ = gc2(ap(MODULEENT,$2));}
 414           ;
 415 qnames    : /* empty */                 {$$ = gc0(NIL);}
 416           | ','                         {$$ = gc1(NIL);}
 417           | qnames1                     {$$ = gc1($1);}
 418           | qnames1 ','                 {$$ = gc2($1);}
 419           ;
 420 qnames1   : qnames1 ',' qname           {$$ = gc3(cons($3,$1));}
 421           | qname                       {$$ = gc1(singleton($1));}
 422           ;
 423 qname     : qvar                        {$$ = gc1($1);}
 424           | qcon                        {$$ = gc1($1);}
 425           | '(' ')'                     {$$ = gc2(conPreludeUnit);}
 426           | '[' ']'                     {$$ = gc2(conPreludeList);}
 427           ;
 428 qcon2     : '(' ')'                     {$$ = gc2(conPreludeUnit);}
 429           | '[' ']'                     {$$ = gc2(conPreludeList);}
 430           | qconid                      {$$ = gc1($1);}
 431           ;
 432
 433 /*- Import declarations: --------------------------------------------------*/
 434
 435 impDecls  : impDecls ';' impDecl        {imps = cons($3,imps); $$=gc3(NIL);}
 436           | impDecl                     {imps = singleton($1); $$=gc1(NIL);}
 437           ;
 438 chase     : /* empty */                 {if (chase(imps)) {
 439                                              clearStack();
 440                                              onto(imps);
 441                                              done();
 442                                              closeAnyInput();
 443                                              return 0;
 444                                          }
 445                                          $$ = gc0(NIL);
 446                                         }
 447           ;
 448 /* Note that qualified import ignores the import list. */
 449 impDecl   : IMPORT modid impspec        {addQualImport($2,$2);
 450                                          addUnqualImport($2,$3);
 451                                          $$ = gc3($2);}
 452           | IMPORT modid ASMOD modid impspec
 453                                         {addQualImport($2,$4);
 454                                          addUnqualImport($2,$5);
 455                                          $$ = gc5($2);}
 456           | IMPORT QUALIFIED modid ASMOD modid impspec
 457                                         {addQualImport($3,$5);
 458                                          $$ = gc6($3);}
 459           | IMPORT QUALIFIED modid impspec
 460                                         {addQualImport($3,$3);
 461                                          $$ = gc4($3);}
 462           | IMPORT error                {syntaxError("import declaration");}
 463           ;
 464 impspec   : /* empty */                 {$$ = gc0(DOTDOT);}
 465           | HIDING '(' imports ')'      {$$ = gc4(ap(HIDDEN,$3));}
 466           | '(' imports ')'             {$$ = gc3($2);}
 467           ;
 468 imports   : /* empty */                 {$$ = gc0(NIL);}
 469           | ','                         {$$ = gc1(NIL);}
 470           | imports1                    {$$ = gc1($1);}
 471           | imports1 ','                {$$ = gc2($1);}
 472           ;
 473 imports1  : imports1 ',' import         {$$ = gc3(cons($3,$1));}
 474           | import                      {$$ = gc1(singleton($1));}
 475           ;
 476 import    : var                         {$$ = gc1($1);}
 477           | CONID                       {$$ = gc1($1);}
 478           | CONID '(' UPTO ')'          {$$ = gc4(pair($1,DOTDOT));}
 479           | CONID '(' names ')'         {$$ = gc4(pair($1,$3));}
 480           ;
 481 names     : /* empty */                 {$$ = gc0(NIL);}
 482           | ','                         {$$ = gc1(NIL);}
 483           | names1                      {$$ = gc1($1);}
 484           | names1 ','                  {$$ = gc2($1);}
 485           ;
 486 names1    : names1 ',' name             {$$ = gc3(cons($3,$1));}
 487           | name                        {$$ = gc1(singleton($1));}
 488           ;
 489 name      : var                         {$$ = gc1($1);}
 490           | con                       {$$ = gc1($1);}
 491           ;
 492
 493 /*- Fixity declarations: --------------------------------------------------*/
 494
 495 fixDecls  : fixDecls ';' fixDecl        {$$ = gc2(NIL);}
 496           | fixDecl                     {$$ = gc0(NIL);}
 497           ;
 498 fixDecl   : INFIXL optdigit ops         {fixDefn(LEFT_ASS,$1,$2,$3); sp-=3;}
 499           | INFIXR optdigit ops         {fixDefn(RIGHT_ASS,$1,$2,$3);sp-=3;}
 500           | INFIX  optdigit ops         {fixDefn(NON_ASS,$1,$2,$3);  sp-=3;}
 501           ;
 502 optdigit  : NUMLIT                      {$$ = gc1(checkPrec($1));}
 503           | /* empty */                 {$$ = gc0(mkInt(DEF_PREC));}
 504           ;
 505 ops       : ops ',' op                  {$$ = gc3(cons($3,$1));}
 506           | op                          {$$ = gc1(cons($1,NIL));}
 507           ;
 508
 509 /*- Top-level declarations: -----------------------------------------------*/
 510
 511 topDecls  : /* empty */                 {$$ = gc0(NIL);}
 512           | ';'                         {$$ = gc1(NIL);}
 513           | topDecls1                   {$$ = gc1($1);}
 514           | topDecls1 ';'               {$$ = gc2($1);}
 515           ;
 516 topDecls1 : topDecls1 ';' topDecl       {$$ = gc2($1);}
 517           | topDecls1 ';' decl          {$$ = gc3(cons($3,$1));}
 518           | topDecl                     {$$ = gc0(NIL);}
 519           | decl                        {$$ = gc1(cons($1,NIL));}
 520           ;
 521
 522 /*- Type declarations: ----------------------------------------------------*/
 523
 524 topDecl   : TYPE tyLhs '=' type         {defTycon(4,$3,$2,$4,SYNONYM);}
 525           | TYPE tyLhs '=' type IN invars
 526                                         {defTycon(6,$3,$2,
 527                                                     ap($4,$6),RESTRICTSYN);}
 528           | DATA btype2 '=' constrs deriving
 529                                         {defTycon(5,$3,checkTyLhs($2),
 530                                                     ap(rev($4),$5),DATATYPE);}
 531           | DATA context IMPLIES tyLhs '=' constrs deriving
 532                                         {defTycon(7,$5,$4,
 533                                                   ap(ap(QUAL,pair($2,rev($6))),
 534                                                      $7),DATATYPE);}
 535           | DATA btype2                 {defTycon(2,$1,checkTyLhs($2),
 536                                                     ap(NIL,NIL),DATATYPE);}
 537           | DATA context IMPLIES tyLhs  {defTycon(4,$1,$4,
 538                                                   ap(ap(QUAL,pair($2,NIL)),
 539                                                      NIL),DATATYPE);}
 540           | TNEWTYPE btype2 '=' nconstr deriving
 541                                         {defTycon(5,$3,checkTyLhs($2),
 542                                                     ap($4,$5),NEWTYPE);}
 543           | TNEWTYPE context IMPLIES tyLhs '=' nconstr deriving
 544                                         {defTycon(7,$5,$4,
 545                                                   ap(ap(QUAL,pair($2,$6)),
 546                                                      $7),NEWTYPE);}
 547           ;
 548 tyLhs     : tyLhs varid1                {$$ = gc2(ap($1,$2));}
 549           | CONID                       {$$ = gc1($1);}
 550           | '[' type ']'                {$$ = gc3(ap(conList,$2));}
 551           | '(' ')'                     {$$ = gc2(conUnit);}
 552           | '(' typeTuple ')'           {$$ = gc3(buildTuple($2));}
 553           | error                       {syntaxError("type defn lhs");}
 554           ;
 555 invars    : invars ',' invar            {$$ = gc3(cons($3,$1));}
 556           | invar                       {$$ = gc1(cons($1,NIL));}
 557           ;
 558 invar     : qvar COCO topType           {$$ = gc3(sigdecl($2,singleton($1),
 559                                                              $3));}
 560           | qvar                        {$$ = gc1($1);}
 561           ;
 562 constrs   : constrs '|' constr          {$$ = gc3(cons($3,$1));}
 563           | constr                      {$$ = gc1(cons($1,NIL));}
 564           ;
 565 constr    : '!' btype conop bbtype      {$$ = gc4(ap2($3,bang($2),$4));}
 566           | btype1    conop bbtype      {$$ = gc3(ap2($2,$1,$3));}
 567           | btype2    conop bbtype      {$$ = gc3(ap2($2,$1,$3));}
 568           | bpolyType conop bbtype      {$$ = gc3(ap2($2,$1,$3));}
 569           | btype2                      {$$ = gc1($1);}
 570           | btype3                      {$$ = gc1($1);}
 571           | btype4                      {$$ = gc1($1);}
 572           | con '{' fieldspecs '}'      {$$ = gc4(ap(LABC,pair($1,rev($3))));}
 573           | '[' ']'                     {$$ = gc2(conNil);}
 574           | '(' ')'                     {$$ = gc2(conUnit);}
 575           | '(' typeTuple ')'           {$$ = gc3(buildTuple($2));}
 576           | error                       {syntaxError("data type definition");}
 577           ;
 578 btype3    : btype2 '!' atype            {$$ = gc3(ap($1,bang($3)));}
 579           | btype3 '!' atype            {$$ = gc3(ap($1,bang($3)));}
 580           | btype3 atype                {$$ = gc2(ap($1,$2));}
 581           ;
 582 btype4    : btype2 bpolyType            {$$ = gc2(ap($1,$2));}
 583           | btype3 bpolyType            {$$ = gc2(ap($1,$2));}
 584           | btype4 bpolyType            {$$ = gc2(ap($1,$2));}
 585           | btype4 atype                {$$ = gc2(ap($1,$2));}
 586           | btype4 '!' atype            {$$ = gc3(ap($1,bang($3)));}
 587           ;
 588 bbtype    : '!' btype                   {$$ = gc2(bang($2));}
 589           | btype                       {$$ = gc1($1);}
 590           | bpolyType                   {$$ = gc1($1);}
 591           ;
 592 fieldspecs: fieldspecs ',' fieldspec    {$$ = gc3(cons($3,$1));}
 593           | fieldspec                   {$$ = gc1(cons($1,NIL));}
 594           ;
 595 fieldspec : vars COCO polyType          {$$ = gc3(pair(rev($1),$3));}
 596           | vars COCO type              {$$ = gc3(pair(rev($1),$3));}
 597           ;
 598 nconstr   : con atype                   {$$ = gc2(singleton(ap($1,$2)));}
 599           | con bpolyType               {$$ = gc2(singleton(ap($1,$2)));}
 600           ;
 601 deriving  : /* empty */                 {$$ = gc0(NIL);}
 602           | DERIVING qconid             {$$ = gc2(singleton($2));}
 603           | DERIVING '(' derivs0 ')'    {$$ = gc4($3);}
 604           ;
 605 derivs0   : /* empty */                 {$$ = gc0(NIL);}
 606           | derivs                      {$$ = gc1(rev($1));}
 607           ;
 608 derivs    : derivs ',' qconid           {$$ = gc3(cons($3,$1));}
 609           | qconid                      {$$ = gc1(singleton($1));}
 610           ;
 611
 612 /*- Processing definitions of primitives ----------------------------------*/
 613
 614 topDecl   : FOREIGN IMPORT callconv ext_loc ext_name unsafe_flag var COCO type
 615                                         {foreignImport($1,pair($4,$5),$7,$9); sp-=9;}
 616           | FOREIGN EXPORT callconv ext_name qvarid COCO type
 617                                         {foreignExport($1,$4,$5,$7); sp-=7;}
 618           ;
 619
 620 callconv  : var                  {$$ = gc1(NIL); /* ignored */ }
 621           ;
 622 ext_loc   : STRINGLIT            {$$ = $1;}
 623           ;
 624 ext_name  : STRINGLIT            {$$ = $1;}
 625           ;
 626 unsafe_flag: /* empty */         {$$ = gc0(NIL);}
 627           | UNSAFE               {$$ = gc1(NIL); /* ignored */ }
 628           ;
 629
 630
 631 /*- Class declarations: ---------------------------------------------------*/
 632
 633 topDecl   : TCLASS crule wherePart      {classDefn(intOf($1),$2,$3); sp-=3;}
 634           | TINSTANCE irule wherePart   {instDefn(intOf($1),$2,$3);  sp-=3;}
 635           | DEFAULT '(' dtypes ')'      {defaultDefn(intOf($1),$3);  sp-=4;}
 636           ;
 637 crule     : context IMPLIES btype2      {$$ = gc3(pair($1,checkPred($3)));}
 638           | btype2                      {$$ = gc1(pair(NIL,checkPred($1)));}
 639           ;
 640 irule     : context IMPLIES btype2      {$$ = gc3(pair($1,checkPred($3)));}
 641           | btype2                      {$$ = gc1(pair(NIL,checkPred($1)));}
 642           ;
 643 dtypes    : /* empty */                 {$$ = gc0(NIL);}
 644           | dtypes1                     {$$ = gc1(rev($1));}
 645           ;
 646 dtypes1   : dtypes1 ',' type            {$$ = gc3(cons($3,$1));}
 647           | type                        {$$ = gc1(cons($1,NIL));}
 648           ;
 649
 650 /*- Type expressions: -----------------------------------------------------*/
 651
 652 sigType   : context IMPLIES type        {$$ = gc3(ap(QUAL,pair($1,$3)));}
 653           | type                        {$$ = gc1($1);}
 654           ;
 655 topType   : context IMPLIES topType1    {$$ = gc3(ap(QUAL,pair($1,$3)));}
 656           | topType1                    {$$ = gc1($1);}
 657           ;
 658 topType1  : bpolyType ARROW topType1    {$$ = gc3(fn($1,$3));}
 659           | btype1    ARROW topType1    {$$ = gc3(fn($1,$3));}
 660           | btype2    ARROW topType1    {$$ = gc3(fn($1,$3));}
 661           | btype                       {$$ = gc1($1);}
 662           ;
 663 polyType  : ALL varid1s '.' sigType     {$$ = gc4(ap(POLYTYPE,
 664                                                      pair(rev($2),$4)));}
 665           | bpolyType                   {$$ = gc1($1);}
 666           ;
 667 bpolyType : '(' polyType ')'            {$$ = gc3($2);}
 668           ;
 669 varid1s   : varid1s ',' varid1          {$$ = gc3(cons($3,$1));}
 670           | varid1                      {$$ = gc1(cons($1,NIL));}
 671           ;
 672 context   : '(' ')'                     {$$ = gc2(NIL);}
 673           | btype2                      {$$ = gc1(singleton(checkPred($1)));}
 674           | '(' btype2 ')'              {$$ = gc3(singleton(checkPred($2)));}
 675           | '(' btypes2 ')'             {$$ = gc3(checkContext($2));}
 676 /*#if TREX*/
 677           | lacks                       {$$ = gc1(singleton($1));}
 678           | '(' lacks1 ')'              {$$ = gc3(checkContext($2));}
 679           ;
 680 lacks     : varid1 '\\' varid1          {
 681 #if TREX
 682                                          $$ = gc3(ap(mkExt(textOf($3)),$1));
 683 #else
 684                                          noTREX("a type context");
 685 #endif
 686                                         }
 687           ;
 688 lacks1    : btypes2 ',' lacks           {$$ = gc3(cons($3,$1));}
 689           | lacks1  ',' btype2          {$$ = gc3(cons($3,$1));}
 690           | lacks1  ',' lacks           {$$ = gc3(cons($3,$1));}
 691           | btype2  ',' lacks           {$$ = gc3(cons($3,cons($1,NIL)));}
 692           | lacks                       {$$ = gc1(singleton($1));}
 693           ;
 694 /*#endif*/
 695
 696 type      : type1                       {$$ = gc1($1);}
 697           | btype2                      {$$ = gc1($1);}
 698           ;
 699 type1     : btype1                      {$$ = gc1($1);}
 700           | btype1 ARROW type           {$$ = gc3(fn($1,$3));}
 701           | btype2 ARROW type           {$$ = gc3(fn($1,$3));}
 702           | error                       {syntaxError("type expression");}
 703           ;
 704 btype     : btype1                      {$$ = gc1($1);}
 705           | btype2                      {$$ = gc1($1);}
 706           ;
 707 btype1    : btype1 atype                {$$ = gc2(ap($1,$2));}
 708           | atype1                      {$$ = gc1($1);}
 709           ;
 710 btype2    : btype2 atype                {$$ = gc2(ap($1,$2));}
 711           | qconid                      {$$ = gc1($1);}
 712           ;
 713 atype     : atype1                      {$$ = gc1($1);}
 714           | qconid                      {$$ = gc1($1);}
 715           ;
 716 atype1    : varid1                      {$$ = gc1($1);}
 717           | '(' ')'                     {$$ = gc2(conPreludeUnit);}
 718           | '(' ARROW ')'               {$$ = gc3(typeArrow);}
 719           | '(' type1 ')'               {$$ = gc3($2);}
 720           | '(' btype2 ')'              {$$ = gc3($2);}
 721           | '(' tupCommas ')'           {$$ = gc3($2);}
 722           | '(' btypes2 ')'             {$$ = gc3(buildTuple($2));}
 723           | '(' typeTuple ')'           {$$ = gc3(buildTuple($2));}
 724 /*#if TREX*/
 725           | '(' tfields ')'             {
 726 #if TREX
 727                                          $$ = gc3(revOnto($2,typeNoRow));
 728 #else
 729                                          noTREX("a type");
 730 #endif
 731                                         }
 732           | '(' tfields '|' type ')'    {$$ = gc5(revOnto($2,$4));}
 733 /*#endif*/
 734           | '[' type ']'                {$$ = gc3(ap(conPreludeList,$2));}
 735           | '[' ']'                     {$$ = gc2(conPreludeList);}
 736           | '_'                         {$$ = gc1(inventVar());}
 737           ;
 738 tupCommas : tupCommas ','               {$$ = gc2(mkTuple(tupleOf($1)+1));}
 739           | ','                         {$$ = gc1(mkTuple(2));}
 740           ;
 741 btypes2   : btypes2 ',' btype2          {$$ = gc3(cons($3,$1));}
 742           | btype2  ',' btype2          {$$ = gc3(cons($3,cons($1,NIL)));}
 743           ;
 744 typeTuple : type1     ',' type          {$$ = gc3(cons($3,cons($1,NIL)));}
 745           | btype2    ',' type1         {$$ = gc3(cons($3,cons($1,NIL)));}
 746           | btypes2   ',' type1         {$$ = gc3(cons($3,$1));}
 747           | typeTuple ',' type          {$$ = gc3(cons($3,$1));}
 748           ;
 749 /*#if TREX*/
 750 tfields   : tfields ',' tfield          {$$ = gc3(cons($3,$1));}
 751           | tfield                      {$$ = gc1(singleton($1));}
 752           ;
 753 tfield    : varid COCO type             {$$ = gc3(ap(mkExt(textOf($1)),$3));}
 754           ;
 755 /*#endif*/
 756
 757 /*- Value declarations: ---------------------------------------------------*/
 758
 759 decllist  : '{' decls end               {$$ = gc3($2);}
 760           ;
 761 decls     : /* empty */                 {$$ = gc0(NIL);}
 762           | ';'                         {$$ = gc1(NIL);}
 763           | decls1                      {$$ = gc1($1);}
 764           | decls1 ';'                  {$$ = gc2($1);}
 765           ;
 766 decls1    : decls1 ';' decl             {$$ = gc3(cons($3,$1));}
 767           | decl                        {$$ = gc1(cons($1,NIL));}
 768           ;
 769 /* Sneakily using qvars to eliminate a conflict... */
 770 decl      : qvars COCO topType          {$$ = gc3(sigdecl($2,$1,$3));}
 771           | opExp rhs                   {$$ = gc2(pair($1,$2));}
 772           ;
 773 rhs       : rhs1 wherePart              {$$ = gc2(letrec($2,$1));}
 774           | error                       {syntaxError("declaration");}
 775           ;
 776 rhs1      : '=' exp                     {$$ = gc2(pair($1,$2));}
 777           | gdefs                       {$$ = gc1(grded(rev($1)));}
 778           ;
 779 wherePart : WHERE decllist              {$$ = gc2($2);}
 780           | /*empty*/                   {$$ = gc0(NIL);}
 781           ;
 782 gdefs     : gdefs gdef                  {$$ = gc2(cons($2,$1));}
 783           | gdef                        {$$ = gc1(cons($1,NIL));}
 784           ;
 785 gdef      : '|' exp '=' exp             {$$ = gc4(pair($3,pair($2,$4)));}
 786           ;
 787 vars      : vars ',' var                {$$ = gc3(cons($3,$1));}
 788           | var                         {$$ = gc1(cons($1,NIL));}
 789           ;
 790 qvars     : qvars ',' qvar              {$$ = gc3(cons($3,$1));}
 791           | qvar                        {$$ = gc1(cons($1,NIL));}
 792           ;
 793
 794
 795
 796 var       : varid                       {$$ = gc1($1);}
 797           | '(' '-' ')'                 {$$ = gc3(varMinus);}
 798           ;
 799 varid     : varid1                      {$$ = gc1($1);}
 800           | '(' VAROP ')'               {$$ = gc3($2);}
 801           | '(' '!' ')'                 {$$ = gc3(varBang);}
 802           | '(' '.' ')'                 {$$ = gc3(varDot);}
 803           ;
 804 varid1    : VARID                       {$$ = gc1($1);}
 805           | HIDING                      {$$ = gc1(varHiding);}
 806           | QUALIFIED                   {$$ = gc1(varQualified);}
 807           | ASMOD                       {$$ = gc1(varAsMod);}
 808           ;
 809 qvar      : qvarid                      {$$ = gc1($1);}
 810           | '(' qvarsym ')'             {$$ = gc3($2);}
 811           | '(' '.' ')'                 {$$ = gc3(varDot);}
 812           | '(' '!' ')'                 {$$ = gc3(varBang);}
 813           | '(' '-' ')'                 {$$ = gc3(varMinus);}
 814           ;
 815 qvarid    : varid1                      {$$ = gc1($1);}
 816           | QVARID                      {$$ = gc1($1);}
 817           ;
 818
 819 op        : varop                       {$$ = gc1($1);}
 820           | conop                       {$$ = gc1($1);}
 821           | '-'                         {$$ = gc1(varMinus);}
 822           ;
 823 qop       : qvarop                      {$$ = gc1($1);}
 824           | qconop                      {$$ = gc1($1);}
 825           | '-'                         {$$ = gc1(varMinus);}
 826           ;
 827
 828 varop     : VAROP                       {$$ = gc1($1);}
 829           | '!'                         {$$ = gc1(varBang);}
 830           | '.'                         {$$ = gc1(varDot);}
 831           | '`' varid1 '`'              {$$ = gc3($2);}
 832           ;
 833 qvarop    : qvarsym                     {$$ = gc1($1);}
 834           | '!'                         {$$ = gc1(varBang);}
 835           | '.'                         {$$ = gc1(varDot);}
 836           | '`' qvarid '`'              {$$ = gc3($2);}
 837           ;
 838 qvarsym   : VAROP                       {$$ = gc1($1);}
 839           | QVAROP                      {$$ = gc1($1);}
 840           ;
 841
 842 con       : CONID                       {$$ = gc1($1);}
 843           | '(' CONOP ')'               {$$ = gc3($2);}
 844           ;
 845 qcon      : qconid                      {$$ = gc1($1);}
 846           | '(' qconsym ')'             {$$ = gc3($2);}
 847           ;
 848 qconid    : CONID                       {$$ = gc1($1);}
 849           | QCONID                      {$$ = gc1($1);}
 850           ;
 851 qconsym   : CONOP                       {$$ = gc1($1);}
 852           | QCONOP                      {$$ = gc1($1);}
 853           ;
 854
 855 conop     : CONOP                       {$$ = gc1($1);}
 856           | '`' CONID '`'               {$$ = gc3($2);}
 857           ;
 858 qconop    : qconsym                     {$$ = gc1($1);}
 859           | '`' qconid '`'              {$$ = gc3($2);}
 860           ;
 861
 862 /*- Expressions: ----------------------------------------------------------*/
 863
 864 exp       : exp1                        {$$ = gc1($1);}
 865           | error                       {syntaxError("expression");}
 866           ;
 867 exp1      : opExp COCO sigType          {$$ = gc3(ap(ESIGN,pair($1,$3)));}
 868           | opExp                       {$$ = gc1($1);}
 869           ;
 870 opExp     : opExp0                      {$$ = gc1(tidyInfix($1));}
 871           | pfxExp                      {$$ = gc1($1);}
 872           ;
 873 opExp0    : opExp0 qop '-' pfxExp       {$$ = gc4(ap(NEG,ap(ap($2,$1),$4)));}
 874           | opExp0 qop pfxExp           {$$ = gc3(ap2($2,$1,$3));}
 875           | '-' pfxExp                  {$$ = gc2(ap(NEG,only($2)));}
 876           | pfxExp qop pfxExp           {$$ = gc3(ap(ap($2,only($1)),$3));}
 877           | pfxExp qop '-' pfxExp       {$$ = gc4(ap(NEG,
 878                                                      ap(ap($2,only($1)),$4)));}
 879           ;
 880 pfxExp    : '\\' pats ARROW exp         {$$ = gc4(ap(LAMBDA,
 881                                                      pair(rev($2),
 882                                                           pair($3,$4))));}
 883           | LET decllist IN exp         {$$ = gc4(letrec($2,$4));}
 884           | IF exp THEN exp ELSE exp    {$$ = gc6(ap(COND,triple($2,$4,$6)));}
 885           | CASEXP exp OF '{' alts end  {$$ = gc6(ap(CASE,pair($2,rev($5))));}
 886           | DO '{' stmts end            {$$ = gc4(ap(DOCOMP,checkDo($3)));}
 887           | appExp                      {$$ = gc1($1);}
 888           ;
 889 pats      : pats atomic                 {$$ = gc2(cons($2,$1));}
 890           | atomic                      {$$ = gc1(cons($1,NIL));}
 891           ;
 892 appExp    : appExp atomic               {$$ = gc2(ap($1,$2));}
 893           | atomic                      {$$ = gc1($1);}
 894           ;
 895 atomic    : qvar                        {$$ = gc1($1);}
 896           | qvar '@' atomic             {$$ = gc3(ap(ASPAT,pair($1,$3)));}
 897           | '~' atomic                  {$$ = gc2(ap(LAZYPAT,$2));}
 898           | '_'                         {$$ = gc1(WILDCARD);}
 899           | qcon                        {$$ = gc1($1);}
 900           | qcon '{' fbinds '}'         {$$ = gc4(ap(CONFLDS,pair($1,$3)));}
 901           | atomic '{' fbinds '}'       {$$ = gc4(ap(UPDFLDS,
 902                                                      triple($1,NIL,$3)));}
 903           | '(' ')'                     {$$ = gc2(conPreludeUnit);}
 904           | NUMLIT                      {$$ = gc1($1);}
 905           | CHARLIT                     {$$ = gc1($1);}
 906           | STRINGLIT                   {$$ = gc1($1);}
 907           | REPEAT                      {$$ = gc1($1);}
 908           | '(' exp ')'                 {$$ = gc3($2);}
 909           | '(' exps2 ')'               {$$ = gc3(buildTuple($2));}
 910 /*#if TREX*/
 911           | '(' vfields ')'             {
 912 #if TREX
 913                                          $$ = gc3(revOnto($2,nameNoRec));
 914 #else
 915                                          $$ = gc3(NIL);
 916 #endif
 917                                         }
 918           | '(' vfields '|' exp ')'     {$$ = gc5(revOnto($2,$4));}
 919           | RECSELID                    {$$ = gc1($1);}
 920 /*#endif*/
 921           | '[' list ']'                {$$ = gc3($2);}
 922           | '(' pfxExp qop ')'          {$$ = gc4(ap($3,$2));}
 923           | '(' qvarop atomic ')'       {$$ = gc4(ap2(varFlip,$2,$3));}
 924           | '(' qconop atomic ')'       {$$ = gc4(ap2(varFlip,$2,$3));}
 925           | '(' tupCommas ')'           {$$ = gc3($2);}
 926           ;
 927 exps2     : exps2 ',' exp               {$$ = gc3(cons($3,$1));}
 928           | exp ',' exp                 {$$ = gc3(cons($3,cons($1,NIL)));}
 929           ;
 930 /*#if TREX*/
 931 vfields   : vfields ',' vfield          {$$ = gc3(cons($3,$1));}
 932           | vfield                      {$$ = gc1(singleton($1));}
 933           ;
 934 vfield    : qvarid '=' exp              {
 935 #if TREX
 936                                          $$ = gc3(ap(mkExt(textOf($1)),$3));
 937 #else
 938                                          noTREX("an expression");
 939 #endif
 940                                         }
 941           ;
 942 /*#endif*/
 943 alts      : alts1                       {$$ = gc1($1);}
 944           | alts1 ';'                   {$$ = gc2($1);}
 945           ;
 946 alts1     : alts1 ';' alt               {$$ = gc3(cons($3,$1));}
 947           | alt                         {$$ = gc1(cons($1,NIL));}
 948           ;
 949 alt       : opExp altRhs wherePart      {$$ = gc3(pair($1,letrec($3,$2)));}
 950           ;
 951 altRhs    : guardAlts                   {$$ = gc1(grded(rev($1)));}
 952           | ARROW exp                   {$$ = gc2(pair($1,$2));}
 953           | error                       {syntaxError("case expression");}
 954           ;
 955 guardAlts : guardAlts guardAlt          {$$ = gc2(cons($2,$1));}
 956           | guardAlt                    {$$ = gc1(cons($1,NIL));}
 957           ;
 958 guardAlt  : '|' opExp ARROW exp         {$$ = gc4(pair($3,pair($2,$4)));}
 959           ;
 960 stmts     : stmts1 ';'                  {$$ = gc2($1);}
 961           | stmts1                      {$$ = gc1($1);}
 962           ;
 963 stmts1    : stmts1 ';' stmt             {$$ = gc3(cons($3,$1));}
 964           | stmt                        {$$ = gc1(cons($1,NIL));}
 965           ;
 966 stmt      : exp1 FROM exp               {$$ = gc3(ap(FROMQUAL,pair($1,$3)));}
 967           | LET decllist                {$$ = gc2(ap(QWHERE,$2));}
 968           | IF exp                      {$$ = gc2(ap(BOOLQUAL,$2));}
 969           | exp1                        {$$ = gc1(ap(DOQUAL,$1));}
 970           ;
 971 fbinds    : /* empty */                 {$$ = gc0(NIL);}
 972           | fbinds1                     {$$ = gc1(rev($1));}
 973           ;
 974 fbinds1   : fbinds1 ',' fbind           {$$ = gc3(cons($3,$1));}
 975           | fbind                       {$$ = gc1(singleton($1));}
 976           ;
 977 fbind     : var                         {$$ = gc1($1);}
 978           | qvar '=' exp                {$$ = gc3(pair($1,$3));}
 979           ;
 980
 981 /*- List Expressions: -------------------------------------------------------*/
 982
 983 list      : /* empty */                 {$$ = gc0(conPreludeNil);}
 984           | exp                         {$$ = gc1(ap(FINLIST,cons($1,NIL)));}
 985           | exps2                       {$$ = gc1(ap(FINLIST,rev($1)));}
 986           | exp '|' quals               {$$ = gc3(ap(COMP,pair($1,rev($3))));}
 987           | exp         UPTO exp        {$$ = gc3(ap2(varEnumFromTo,$1,$3));}
 988           | exp ',' exp UPTO            {$$ = gc4(ap2(varEnumFromThen,$1,$3));}
 989           | exp         UPTO            {$$ = gc2(ap1(varEnumFrom,$1));}
 990           | exp ',' exp UPTO exp        {$$ = gc5(ap3(varEnumFromThenTo,
 991                                                       $1,$3,$5));}
 992           ;
 993 quals     : quals ',' qual              {$$ = gc3(cons($3,$1));}
 994           | qual                        {$$ = gc1(cons($1,NIL));}
 995           ;
 996 qual      : exp FROM exp                {$$ = gc3(ap(FROMQUAL,pair($1,$3)));}
 997           | exp                         {$$ = gc1(ap(BOOLQUAL,$1));}
 998           | LET decllist                {$$ = gc2(ap(QWHERE,$2));}
 999           ;
1000
1001 /*- Tricks to force insertion of leading and closing braces ---------------*/
1002
1003 begin     : error                       {yyerrok; goOffside(startColumn);}
1004           ;
1005                                         /* deal with trailing semicolon    */
1006 end       : '}'                         {$$ = gc1($1);}
1007           | error                       {yyerrok;
1008                                          if (canUnOffside()) {
1009                                              unOffside();
1010                                              /* insert extra token on stack*/
1011                                              push(NIL);
1012                                              pushed(0) = pushed(1);
1013                                              pushed(1) = mkInt(column);
1014                                          }
1015                                          else
1016                                              syntaxError("definition");
1017                                         }
1018           ;
1019
1020 /*-------------------------------------------------------------------------*/
1021
1022 %%
1023
1024 static Cell local gcShadow(n,e)         /* keep parsed fragments on stack  */
1025 Int  n;
1026 Cell e; {
1027     /* If a look ahead token is held then the required stack transformation
1028      * is:
1029      *   pushed: n               1     0          1     0
1030      *           x1  |  ...  |  xn  |  la   ===>  e  |  la
1031      *                                top()            top()
1032      *
1033      * Othwerwise, the transformation is:
1034      *   pushed: n-1             0        0
1035      *           x1  |  ...  |  xn  ===>  e
1036      *                         top()     top()
1037      */
1038     if (yychar>=0) {
1039         pushed(n-1) = top();
1040         pushed(n)   = e;
1041     }
1042     else
1043         pushed(n-1) = e;
1044     sp -= (n-1);
1045     return e;
1046 }
1047
1048 static Void local syntaxError(s)       /* report on syntax error           */
1049 String s; {
1050     ERRMSG(row) "Syntax error in %s (unexpected %s)", s, unexpected()
1051     EEND;
1052 }
1053
1054 static String local unexpected() {     /* find name for unexpected token   */
1055     static char buffer[100];
1056     static char *fmt = "%s \"%s\"";
1057     static char *kwd = "keyword";
1058
1059     switch (yychar) {
1060         case 0         : return "end of input";
1061
1062 #define keyword(kw) sprintf(buffer,fmt,kwd,kw); return buffer;
1063         case INFIXL    : keyword("infixl");
1064         case INFIXR    : keyword("infixr");
1065         case INFIX     : keyword("infix");
1066         case FOREIGN   : keyword("foreign");
1067         case UNSAFE    : keyword("unsafe");
1068         case TINSTANCE : keyword("instance");
1069         case TCLASS    : keyword("class");
1070         case CASEXP    : keyword("case");
1071         case OF        : keyword("of");
1072         case IF        : keyword("if");
1073         case THEN      : keyword("then");
1074         case ELSE      : keyword("else");
1075         case WHERE     : keyword("where");
1076         case TYPE      : keyword("type");
1077         case DATA      : keyword("data");
1078         case TNEWTYPE  : keyword("newtype");
1079         case LET       : keyword("let");
1080         case IN        : keyword("in");
1081         case DERIVING  : keyword("deriving");
1082         case DEFAULT   : keyword("default");
1083         case IMPORT    : keyword("import");
1084         case EXPORT    : keyword("export");
1085         case MODULETOK : keyword("module");
1086         case INTERFACE : keyword("interface");
1087         case WILDCARD  : keyword("_");
1088         case ALL       : keyword("forall");
1089 #undef keyword
1090
1091         case ARROW     : return "`->'";
1092         case '='       : return "`='";
1093         case COCO      : return "`::'";
1094         case '-'       : return "`-'";
1095         case '!'       : return "`!'";
1096         case ','       : return "comma";
1097         case '@'       : return "`@'";
1098         case '('       : return "`('";
1099         case ')'       : return "`)'";
1100         case '{'       : return "`{'";
1101         case '}'       : return "`}'";
1102         case '_'       : return "`_'";
1103         case '|'       : return "`|'";
1104         case '.'       : return "`.'";
1105         case ';'       : return "`;'";
1106         case UPTO      : return "`..'";
1107         case '['       : return "`['";
1108         case ']'       : return "`]'";
1109         case FROM      : return "`<-'";
1110         case '\\'      : return "backslash (lambda)";
1111         case '~'       : return "tilde";
1112         case '`'       : return "backquote";
1113 #if TREX
1114         case RECSELID  : sprintf(buffer,"selector \"#%s\"",
1115                                  textToStr(extText(snd(yylval))));
1116                          return buffer;
1117 #endif
1118         case VAROP     :
1119         case VARID     :
1120         case CONOP     :
1121         case CONID     : sprintf(buffer,"symbol \"%s\"",
1122                                  textToStr(textOf(yylval)));
1123                          return buffer;
1124         case QVAROP    :
1125         case QVARID    :
1126         case QCONOP    :
1127         case QCONID    : sprintf(buffer,"symbol \"%s\"",
1128                                  identToStr(yylval));
1129                          return buffer;
1130         case HIDING    : return "symbol \"hiding\"";
1131         case QUALIFIED : return "symbol \"qualified\"";
1132         case ASMOD     : return "symbol \"as\"";
1133         case NUMLIT    : return "numeric literal";
1134         case CHARLIT   : return "character literal";
1135         case STRINGLIT : return "string literal";
1136         case IMPLIES   : return "`=>'";
1137         default        : return "token";
1138     }
1139 }
1140
1141 static Cell local checkPrec(p)         /* Check for valid precedence value */
1142 Cell p; {
1143     if ((!isInt(p) || intOf(p)<MIN_PREC || intOf(p)>MAX_PREC)
1144         && (!isBignum(p) || bignumOf(p)<MIN_PREC || bignumOf(p)>MAX_PREC)
1145         ) {
1146         ERRMSG(row) "Precedence value must be an integer in the range [%d..%d]",
1147                     MIN_PREC, MAX_PREC
1148         EEND;
1149     }
1150     if (isBignum(p)) {
1151         return mkInt(bignumOf(p));
1152     } else {
1153         return p;
1154     }
1155 }
1156
1157 static Void local fixDefn(a,line,p,ops)/* Declare syntax of operators      */
1158 Syntax a;
1159 Cell   line;
1160 Cell   p;
1161 List   ops; {
1162     Int l = intOf(line);
1163     a     = mkSyntax(a,intOf(p));
1164     map2Proc(setSyntax,l,a,ops);
1165 }
1166
1167 static Void local setSyntax(line,sy,op)/* set syntax of individ. operator  */
1168 Int    line;
1169 Syntax sy;
1170 Cell   op; {
1171     addSyntax(line,textOf(op),sy);
1172     opDefns = cons(op,opDefns);
1173 }
1174
1175 static Cell local buildTuple(tup)      /* build tuple (x1,...,xn) from list*/
1176 List tup; {                            /* [xn,...,x1]                      */
1177     Int  n = 0;
1178     Cell t = tup;
1179     Cell x;
1180
1181     do {                               /*     .                    .       */
1182         x      = fst(t);               /*    / \                  / \      */
1183         fst(t) = snd(t);               /*   xn  .                .   xn    */
1184         snd(t) = x;                    /*        .    ===>      .          */
1185         x      = t;                    /*         .            .           */
1186         t      = fun(x);               /*          .          .            */
1187         n++;                           /*         / \        / \           */
1188     } while (nonNull(t));              /*        x1  NIL   (n)  x1         */
1189     fst(x) = mkTuple(n);
1190     return tup;
1191 }
1192
1193 static List local checkContext(con)     /* validate context                */
1194 Type con; {
1195     mapOver(checkPred, con);
1196     return con;
1197 }
1198
1199 static Cell local checkPred(c)          /* check that type expr is a valid */
1200 Cell c; {                               /* constraint                      */
1201     Cell cn = getHead(c);
1202 #if TREX
1203     if (isExt(cn) && argCount==1)
1204         return c;
1205 #endif
1206     if (!isQCon(cn) || argCount==0)
1207         syntaxError("class expression");
1208     return c;
1209 }
1210
1211 static Pair local checkDo(dqs)          /* convert reversed list of dquals */
1212 List dqs; {                             /* to an (expr,quals) pair         */
1213     if (isNull(dqs) || whatIs(hd(dqs))!=DOQUAL) {
1214         ERRMSG(row) "Last generator in do {...} must be an expression"
1215         EEND;
1216     }
1217     fst(dqs) = snd(fst(dqs));           /* put expression in fst of pair   */
1218     snd(dqs) = rev(snd(dqs));           /* & reversed list of quals in snd */
1219     return dqs;
1220 }
1221
1222 static Cell local checkTyLhs(c)         /* check that lhs is of the form   */
1223 Cell c; {                               /* T a1 ... a                      */
1224     Cell tlhs = c;
1225     while (isAp(tlhs) && whatIs(arg(tlhs))==VARIDCELL)
1226         tlhs = fun(tlhs);
1227     switch (whatIs(tlhs)) {
1228         case CONIDCELL  : return c;
1229
1230         default :
1231             ERRMSG(row) "Illegal left hand side in datatype definition"
1232             EEND;
1233     }
1234 }
1235
1236 #if !TREX
1237 static Void local noTREX(where)
1238 String where; {
1239     ERRMSG(row) "Attempt to use Typed Records with Extensions\nwhile parsing %s. This feature is disabled in this build of Hugs.",
1240                  where
1241     EEND;
1242 }
1243 #endif
1244
1245 /* Expressions involving infix operators or unary minus are parsed as elements
1246  * of the following type:
1247  *
1248  *     data OpExp = Only Exp | Neg OpExp | Infix OpExp Op Exp
1249  *
1250  * (The algorithms here do not assume that negation can be applied only once,
1251  * i.e., that - - x is a syntax error, as required by the Haskell report.
1252  * Instead, that restriction is captured by the grammar itself, given above.)
1253  *
1254  * There are rules of precedence and grouping, expressed by two functions:
1255  *
1256  *     prec :: Op -> Int;   assoc :: Op -> Assoc    (Assoc = {L, N, R})
1257  *
1258  * OpExp values are rearranged accordingly when a complete expression has
1259  * been read using a simple shift-reduce parser whose result may be taken
1260  * to be a value of the following type:
1261  *
1262  *     data Exp = Atom Int | Negate Exp | Apply Op Exp Exp | Error String
1263  *
1264  * The machine on which this parser is based can be defined as follows:
1265  *
1266  *     tidy                         :: OpExp -> [(Op,Exp)] -> Exp
1267  *     tidy (Only a)      []         = a
1268  *     tidy (Only a)      ((o,b):ss) = tidy (Only (Apply o a b)) ss
1269  *     tidy (Infix a o b) []         = tidy a [(o,b)]
1270  *     tidy (Infix a o b) ((p,c):ss)
1271  *                      | shift  o p = tidy a ((o,b):(p,c):ss)
1272  *                      | red    o p = tidy (Infix a o (Apply p b c)) ss
1273  *                      | ambig  o p = Error "ambiguous use of operators"
1274  *     tidy (Neg e)       []         = tidy (tidyNeg e) []
1275  *     tidy (Neg e)       ((o,b):ss)
1276  *                      | nshift o   = tidy (Neg (underNeg o b e)) ss
1277  *                      | nred   o   = tidy (tidyNeg e) ((o,b):ss)
1278  *                      | nambig o   = Error "illegal use of negation"
1279  *
1280  * At each stage, the parser can either shift, reduce, accept, or error.
1281  * The transitions when dealing with juxtaposed operators o and p are
1282  * determined by the following rules:
1283  *
1284  *     shift o p  = (prec o > prec p)
1285  *               || (prec o == prec p && assoc o == L && assoc p == L)
1286  *
1287  *     red o p    = (prec o < prec p)
1288  *               || (prec o == prec p && assoc o == R && assoc p == R)
1289  *
1290  *     ambig o p  = (prec o == prec p)
1291  *               && (assoc o == N || assoc p == N || assoc o /= assoc p)
1292  *
1293  * The transitions when dealing with juxtaposed unary minus and infix operators
1294  * are as follows.  The precedence of unary minus (infixl 6) is hardwired in
1295  * to these definitions, as it is to the definitions of the Haskell grammar
1296  * in the official report.
1297  *
1298  *     nshift o   = (prec o > 6)
1299  *     nred   o   = (prec o < 6) || (prec o == 6 && assoc o == L)
1300  *     nambig o   = prec o == 6 && (assoc o == R || assoc o == N)
1301  *
1302  * An OpExp of the form (Neg e) means negate the last thing in the OpExp e;
1303  * we can force this negation using:
1304  *
1305  *     tidyNeg              :: OpExp -> OpExp
1306  *     tidyNeg (Only e)      = Only (Negate e)
1307  *     tidyNeg (Infix a o b) = Infix a o (Negate b)
1308  *     tidyNeg (Neg e)       = tidyNeg (tidyNeg e)
1309  *
1310  * On the other hand, if we want to sneak application of an infix operator
1311  * under a negation, then we use:
1312  *
1313  *     underNeg                  :: Op -> Exp -> OpExp -> OpExp
1314  *     underNeg o b (Only e)      = Only (Apply o e b)
1315  *     underNeg o b (Neg e)       = Neg (underNeg o b e)
1316  *     underNeg o b (Infix e p f) = Infix e p (Apply o f b)
1317  *
1318  * As a concession to efficiency, we lower the number of calls to syntaxOf
1319  * by keeping track of the values of sye, sys throughout the process.  The
1320  * value APPLIC is used to indicate that the syntax value is unknown.
1321  */
1322
1323 #define UMINUS_PREC  6                  /* Change these settings at your   */
1324 #define UMINUS_ASSOC LEFT_ASS           /* own risk; they may not work!    */
1325
1326 static Cell local tidyInfix(e)          /* convert OpExp to Expr           */
1327 Cell e; {                               /* :: OpExp                        */
1328     Cell s     = NIL;                   /* :: [(Op,Exp)]                   */
1329     Syntax sye = APPLIC;                /* Syntax of op in e (init unknown)*/
1330     Syntax sys = APPLIC;                /* Syntax of op in s (init unknown)*/
1331
1332     for (;;)
1333         switch (whatIs(e)) {
1334             case ONLY : e = snd(e);
1335                         while (nonNull(s)) {
1336                             Cell next   = arg(fun(s));
1337                             arg(fun(s)) = e;
1338                             e           = s;
1339                             s           = next;
1340                         }
1341                         return e;
1342
1343             case NEG  : if (nonNull(s)) {
1344
1345                             if (sys==APPLIC) {  /* calculate sys           */
1346                                 sys = identSyntax(fun(fun(s)));
1347                                 if (sys==APPLIC) sys=DEF_OPSYNTAX;
1348                             }
1349
1350                             if (precOf(sys)==UMINUS_PREC &&     /* nambig  */
1351                                 assocOf(sys)!=UMINUS_ASSOC) {
1352                                 ERRMSG(row)
1353                                  "Ambiguous use of unary minus with \"%s\"",
1354                                    textToStr(textOf(fun(fun(s))))
1355                                 EEND;
1356                             }
1357
1358                             if (precOf(sys)>UMINUS_PREC) {      /* nshift  */
1359                                 Cell e1    = snd(e);
1360                                 Cell t     = s;
1361                                 s          = arg(fun(s));
1362                                 while (whatIs(e1)==NEG)
1363                                     e1 = snd(e1);
1364                                 arg(fun(t)) = arg(e1);
1365                                 arg(e1)     = t;
1366                                 sys         = APPLIC;
1367                                 continue;
1368                             }
1369
1370                         }
1371
1372                         /* Intentional fall-thru for nreduce and isNull(s) */
1373                         {   Cell prev = e;              /* e := tidyNeg e  */
1374                             Cell temp = arg(prev);
1375                             Int  nneg = 1;
1376                             for (; whatIs(temp)==NEG; nneg++) {
1377                                 fun(prev) = varNegate;
1378                                 prev      = temp;
1379                                 temp      = arg(prev);
1380                             }
1381                             /* These special cases are required for
1382                              * pattern matching.
1383                              */
1384                             if (isInt(arg(temp))) {     /* special cases   */
1385                                 if (nneg&1)             /* for literals    */
1386                                     arg(temp) = intNegate(arg(temp));
1387                             }
1388                             else if (isBignum(arg(temp))) {
1389                                 if (nneg&1)
1390                                     arg(temp) = bignumNegate(arg(temp));
1391                             }
1392                             else if (isFloat(arg(temp))) {
1393                                 if (nneg&1)
1394                                     arg(temp) = floatNegate(arg(temp));
1395                             }
1396                             else {
1397                                 fun(prev) = varNegate;
1398                                 arg(prev) = arg(temp);
1399                                 arg(temp) = e;
1400                             }
1401                             e = temp;
1402                         }
1403                         continue;
1404
1405             default   : if (isNull(s)) {/* Move operation onto empty stack */
1406                             Cell next   = arg(fun(e));
1407                             s           = e;
1408                             arg(fun(s)) = NIL;
1409                             e           = next;
1410                             sys         = sye;
1411                             sye         = APPLIC;
1412                         }
1413                         else {          /* deal with pair of operators     */
1414
1415                             if (sye==APPLIC) {  /* calculate sys and sye   */
1416                                 sye = identSyntax(fun(fun(e)));
1417                                 if (sye==APPLIC) sye=DEF_OPSYNTAX;
1418                             }
1419                             if (sys==APPLIC) {
1420                                 sys = identSyntax(fun(fun(s)));
1421                                 if (sys==APPLIC) sys=DEF_OPSYNTAX;
1422                             }
1423
1424                             if (precOf(sye)==precOf(sys) &&     /* ambig   */
1425                                 (assocOf(sye)!=assocOf(sys) ||
1426                                  assocOf(sye)==NON_ASS)) {
1427                                 ERRMSG(row)
1428                                 "Ambiguous use of operator \"%s\" with \"%s\"",
1429                                   textToStr(textOf(fun(fun(e)))),
1430                                   textToStr(textOf(fun(fun(s))))
1431                                 EEND;
1432                             }
1433
1434                             if (precOf(sye)>precOf(sys) ||      /* shift   */
1435                                 (precOf(sye)==precOf(sys) &&
1436                                  assocOf(sye)==LEFT_ASS &&
1437                                  assocOf(sys)==LEFT_ASS)) {
1438                                 Cell next   = arg(fun(e));
1439                                 arg(fun(e)) = s;
1440                                 s           = e;
1441                                 e           = next;
1442                                 sys         = sye;
1443                                 sye         = APPLIC;
1444                             }
1445                             else {                              /* reduce  */
1446                                 Cell next   = arg(fun(s));
1447                                 arg(fun(s)) = arg(e);
1448                                 arg(e)      = s;
1449                                 s           = next;
1450                                 sys         = APPLIC;
1451                                 /* sye unchanged */
1452                             }
1453                         }
1454                         continue;
1455         }
1456 }
1457
1458 /*-------------------------------------------------------------------------*/