ghc/compiler/parser/hsparser.y

   1 /**************************************************************************
   2 *   File:               hsparser.y                                        *
   3 *                                                                         *
   4 *                       Author:                 Maria M. Gutierrez        *
   5 *                       Modified by:            Kevin Hammond             *
   6 *                       Last date revised:      December 13 1991. KH.     *
   7 *                       Modification:           Haskell 1.1 Syntax.       *
   8 *                                                                         *
   9 *                                                                         *
  10 *   Description:  This file contains the LALR(1) grammar for Haskell.     *
  11 *                                                                         *
  12 *   Entry Point:  module                                                  *
  13 *                                                                         *
  14 *   Problems:     None known.                                             *
  15 *                                                                         *
  16 *                                                                         *
  17 *                 LALR(1) Syntax for Haskell 1.2                          *
  18 *                                                                         *
  19 **************************************************************************/
  20
  21
  22 %{
  23 #ifdef HSP_DEBUG
  24 # define YYDEBUG 1
  25 #endif
  26
  27 #include <stdio.h>
  28 #include <ctype.h>
  29 #include <string.h>
  30 #include "hspincl.h"
  31 #include "constants.h"
  32 #include "utils.h"
  33
  34 /**********************************************************************
  35 *                                                                     *
  36 *                                                                     *
  37 *     Imported Variables and Functions                                *
  38 *                                                                     *
  39 *                                                                     *
  40 **********************************************************************/
  41
  42 static BOOLEAN expect_ccurly = FALSE; /* Used to signal that a CCURLY could be inserted here */
  43 extern BOOLEAN etags;
  44
  45 extern char *input_filename;
  46 static char *the_module_name;
  47 static maybe module_exports;
  48
  49 extern list Lnil;
  50 extern tree root;
  51
  52 /* For FN, PREVPATT and SAMEFN macros */
  53 extern qid      fns[];
  54 extern BOOLEAN  samefn[];
  55 extern tree     prevpatt[];
  56 extern short    icontexts;
  57
  58 /* Line Numbers */
  59 extern int hsplineno, hspcolno;
  60 extern int modulelineno;
  61 extern int startlineno;
  62 extern int endlineno;
  63
  64 /**********************************************************************
  65 *                                                                     *
  66 *                                                                     *
  67 *      Fixity and Precedence Declarations                             *
  68 *                                                                     *
  69 *                                                                     *
  70 **********************************************************************/
  71
  72 static int Fixity = 0, Precedence = 0;
  73
  74 char *ineg PROTO((char *));
  75
  76 long    source_version = 0;
  77
  78 BOOLEAN inpat;
  79 %}
  80
  81 %union {
  82         tree utree;
  83         list ulist;
  84         ttype uttype;
  85         constr uconstr;
  86         binding ubinding;
  87         pbinding upbinding;
  88         entidt uentid;
  89         id uid;
  90         qid uqid;
  91         literal uliteral;
  92         maybe umaybe;
  93         either ueither;
  94         long ulong;
  95         float ufloat;
  96         char *ustring;
  97         hstring uhstring;
  98 }
  99
 100
 101 /**********************************************************************
 102 *                                                                     *
 103 *                                                                     *
 104 *     These are lexemes.                                              *
 105 *                                                                     *
 106 *                                                                     *
 107 **********************************************************************/
 108
 109
 110 %token  VARID           CONID           QVARID          QCONID
 111         VARSYM          CONSYM          QVARSYM         QCONSYM
 112
 113 %token  INTEGER         FLOAT           CHAR            STRING
 114         CHARPRIM        STRINGPRIM      INTPRIM         FLOATPRIM
 115         DOUBLEPRIM      CLITLIT
 116
 117
 118
 119 /**********************************************************************
 120 *                                                                     *
 121 *                                                                     *
 122 *      Special Symbols                                                *
 123 *                                                                     *
 124 *                                                                     *
 125 **********************************************************************/
 126
 127 %token  OCURLY          CCURLY          VCCURLY
 128 %token  COMMA           SEMI            OBRACK          CBRACK
 129 %token  WILDCARD        BQUOTE          OPAREN          CPAREN
 130
 131
 132 /**********************************************************************
 133 *                                                                     *
 134 *                                                                     *
 135 *     Reserved Operators                                              *
 136 *                                                                     *
 137 *                                                                     *
 138 **********************************************************************/
 139
 140 %token  DOTDOT          DCOLON          EQUAL           LAMBDA
 141 %token  VBAR            RARROW          LARROW
 142 %token  AT              LAZY            DARROW
 143
 144
 145 /**********************************************************************
 146 *                                                                     *
 147 *                                                                     *
 148 *     Reserved Identifiers                                            *
 149 *                                                                     *
 150 *                                                                     *
 151 **********************************************************************/
 152
 153 %token  CASE            CLASS           DATA
 154 %token  DEFAULT         DERIVING        DO
 155 %token  ELSE            IF              IMPORT
 156 %token  IN              INFIX           INFIXL
 157 %token  INFIXR          INSTANCE        LET
 158 %token  MODULE          NEWTYPE         OF
 159 %token  THEN            TYPE            WHERE
 160
 161 %token  SCC
 162 %token  CCALL           CCALL_GC        CASM            CASM_GC
 163
 164
 165 /**********************************************************************
 166 *                                                                     *
 167 *                                                                     *
 168 *     Special symbols/identifiers which need to be recognised         *
 169 *                                                                     *
 170 *                                                                     *
 171 **********************************************************************/
 172
 173 %token  MINUS           BANG
 174 %token  AS              HIDING          QUALIFIED
 175
 176
 177 /**********************************************************************
 178 *                                                                     *
 179 *                                                                     *
 180 *     Special Symbols for the Lexer                                   *
 181 *                                                                     *
 182 *                                                                     *
 183 **********************************************************************/
 184
 185 %token  INTERFACE_UPRAGMA SPECIALISE_UPRAGMA
 186 %token  INLINE_UPRAGMA MAGIC_UNFOLDING_UPRAGMA
 187 %token  DEFOREST_UPRAGMA END_UPRAGMA
 188
 189 /**********************************************************************
 190 *                                                                     *
 191 *                                                                     *
 192 *     Precedences of the various tokens                               *
 193 *                                                                     *
 194 *                                                                     *
 195 **********************************************************************/
 196
 197
 198 %left   CASE    LET     IN
 199         IF      ELSE    LAMBDA
 200         SCC     CASM    CCALL   CASM_GC CCALL_GC
 201
 202 %left   VARSYM  CONSYM  QVARSYM QCONSYM
 203         MINUS   BQUOTE  BANG    DARROW
 204
 205 %left   DCOLON
 206
 207 %left   SEMI    COMMA
 208
 209 %left   OCURLY  OBRACK  OPAREN
 210
 211 %left   EQUAL
 212
 213 %right  RARROW
 214
 215 /**********************************************************************
 216 *                                                                     *
 217 *                                                                     *
 218 *      Type Declarations                                              *
 219 *                                                                     *
 220 *                                                                     *
 221 **********************************************************************/
 222
 223
 224 %type <ulist>   caserest alts alt quals
 225                 dorest stmts stmt
 226                 rbinds rpats list_exps
 227                 qvarsk qvars_list
 228                 constrs constr1 fields
 229                 types atypes batypes
 230                 types_and_maybe_ids
 231                 pats context context_list tyvar_list
 232                 export_list enames
 233                 import_list inames
 234                 impdecls maybeimpdecls impdecl
 235                 maybefixes fixes fix ops
 236                 dtyclses dtycls_list
 237                 gdrhs gdpat valrhs
 238                 lampats cexps
 239
 240 %type <umaybe>  maybeexports impspec deriving
 241
 242 %type <uliteral> lit_constant
 243
 244 %type <utree>   exp oexp dexp kexp fexp aexp rbind texps
 245                 expL oexpL kexpL expLno oexpLno dexpLno kexpLno
 246                 vallhs funlhs qual gd leftexp
 247                 pat bpat apat apatc conpat rpat
 248                 patk bpatk apatck conpatk
 249
 250
 251 %type <uid>     MINUS DARROW AS LAZY
 252                 VARID CONID VARSYM CONSYM
 253                 var con varop conop op
 254                 vark varid varsym varsym_nominus
 255                 tycon modid ccallid
 256
 257 %type <uqid>    QVARID QCONID QVARSYM QCONSYM
 258                 qvarid qconid qvarsym qconsym
 259                 qvar qcon qvarop qconop qop
 260                 qvark qconk qtycon qtycls
 261                 gcon gconk gtycon itycon qop1 qvarop1
 262                 ename iname
 263
 264 %type <ubinding>  topdecl topdecls letdecls
 265                   typed datad newtd classd instd defaultd
 266                   decl decls valdef instdef instdefs
 267                   maybe_where cbody rinst type_and_maybe_id
 268
 269 %type <upbinding> valrhs1 altrest
 270
 271 %type <uttype>    simple ctype type atype btype
 272                   gtyconapp ntyconapp ntycon gtyconvars
 273                   bbtype batype btyconapp
 274                   class restrict_inst general_inst tyvar
 275
 276 %type <uconstr>   constr field
 277
 278 %type <ustring>   FLOAT INTEGER INTPRIM
 279                   FLOATPRIM DOUBLEPRIM CLITLIT
 280
 281 %type <uhstring>  STRING STRINGPRIM CHAR CHARPRIM
 282
 283 %type <uentid>    export import
 284
 285 %type <ulong>     commas
 286
 287 /**********************************************************************
 288 *                                                                     *
 289 *                                                                     *
 290 *      Start Symbol for the Parser                                    *
 291 *                                                                     *
 292 *                                                                     *
 293 **********************************************************************/
 294
 295 %start module
 296
 297 %%
 298 module  :  modulekey modid maybeexports
 299                 {
 300                   modulelineno = startlineno;
 301                   the_module_name = $2;
 302                   module_exports = $3;
 303                 }
 304            WHERE body
 305         |       {
 306                   modulelineno = 0;
 307                   the_module_name = install_literal("Main");
 308                   module_exports = mknothing();
 309                 }
 310            body
 311         ;
 312
 313 body    :  ocurly { setstartlineno(); } interface_pragma orestm
 314         |  vocurly interface_pragma vrestm
 315         ;
 316
 317 interface_pragma : /* empty */
 318         | INTERFACE_UPRAGMA INTEGER END_UPRAGMA SEMI
 319                {
 320                  source_version = atoi($2);
 321                }
 322         ;
 323
 324 orestm  :  maybeimpdecls maybefixes topdecls ccurly
 325                {
 326                  root = mkhmodule(the_module_name,$1,module_exports,
 327                                   $2,$3,source_version,modulelineno);
 328                }
 329         |  impdecls ccurly
 330                {
 331                  root = mkhmodule(the_module_name,$1,module_exports,
 332                                   Lnil,mknullbind(),source_version,modulelineno);
 333                }
 334
 335 vrestm  :  maybeimpdecls maybefixes topdecls vccurly
 336                {
 337                  root = mkhmodule(the_module_name,$1,module_exports,
 338                                   $2,$3,source_version,modulelineno);
 339                }
 340         |  impdecls vccurly
 341                {
 342                  root = mkhmodule(the_module_name,$1,module_exports,
 343                                   Lnil,mknullbind(),source_version,modulelineno);
 344                }
 345
 346 maybeexports :  /* empty */                     { $$ = mknothing(); }
 347         |  OPAREN export_list CPAREN            { $$ = mkjust($2); }
 348         |  OPAREN export_list COMMA CPAREN      { $$ = mkjust($2); }
 349         ;
 350
 351 export_list:
 352            export                               { $$ = lsing($1); }
 353         |  export_list COMMA export             { $$ = lapp($1, $3); }
 354         ;
 355
 356 export  :  qvar                                 { $$ = mkentid($1); }
 357         |  gtycon                               { $$ = mkenttype($1); }
 358         |  gtycon OPAREN DOTDOT CPAREN          { $$ = mkenttypeall($1); }
 359         |  gtycon OPAREN CPAREN                 { $$ = mkenttypenamed($1,Lnil); }
 360         |  gtycon OPAREN enames CPAREN          { $$ = mkenttypenamed($1,$3); }
 361         |  MODULE modid                         { $$ = mkentmod($2); }
 362         ;
 363
 364 enames  :  ename                                { $$ = lsing($1); }
 365         |  enames COMMA ename                   { $$ = lapp($1,$3); }
 366         ;
 367 ename   :  qvar
 368         |  qcon
 369         ;
 370
 371
 372 maybeimpdecls : /* empty */                     { $$ = Lnil; }
 373         |  impdecls SEMI                        { $$ = $1; }
 374         ;
 375
 376 impdecls:  impdecl                              { $$ = $1; }
 377         |  impdecls SEMI impdecl                { $$ = lconc($1,$3); }
 378         ;
 379
 380
 381 impdecl :  importkey modid impspec
 382                 { $$ = lsing(mkimport($2,0,mknothing(),$3,startlineno)); }
 383         |  importkey QUALIFIED modid impspec
 384                 { $$ = lsing(mkimport($3,1,mknothing(),$4,startlineno)); }
 385         |  importkey QUALIFIED modid AS modid impspec
 386                 { $$ = lsing(mkimport($3,1,mkjust($5),$6,startlineno)); }
 387         ;
 388
 389 impspec :  /* empty */                            { $$ = mknothing(); }
 390         |  OPAREN CPAREN                          { $$ = mkjust(mkleft(Lnil)); }
 391         |  OPAREN import_list CPAREN              { $$ = mkjust(mkleft($2));   }
 392         |  OPAREN import_list COMMA CPAREN        { $$ = mkjust(mkleft($2));   }
 393         |  HIDING OPAREN import_list CPAREN       { $$ = mkjust(mkright($3));  }
 394         |  HIDING OPAREN import_list COMMA CPAREN { $$ = mkjust(mkright($3));  }
 395         ;
 396
 397 import_list:
 398            import                               { $$ = lsing($1); }
 399         |  import_list COMMA import             { $$ = lapp($1, $3); }
 400         ;
 401
 402 import  :  var                                  { $$ = mkentid(mknoqual($1)); }
 403         |  itycon                               { $$ = mkenttype($1); }
 404         |  itycon OPAREN DOTDOT CPAREN          { $$ = mkenttypeall($1); }
 405         |  itycon OPAREN CPAREN                 { $$ = mkenttypenamed($1,Lnil);}
 406         |  itycon OPAREN inames CPAREN          { $$ = mkenttypenamed($1,$3); }
 407         ;
 408
 409 itycon  :  tycon                                { $$ = mknoqual($1); }
 410         |  OBRACK CBRACK                        { $$ = creategid(-1); }
 411         |  OPAREN CPAREN                        { $$ = creategid(0); }
 412         |  OPAREN commas CPAREN                 { $$ = creategid($2); }
 413         ;
 414
 415 inames  :  iname                                { $$ = lsing($1); }
 416         |  inames COMMA iname                   { $$ = lapp($1,$3); }
 417         ;
 418 iname   :  var                                  { $$ = mknoqual($1); }
 419         |  con                                  { $$ = mknoqual($1); }
 420         ;
 421
 422 /**********************************************************************
 423 *                                                                     *
 424 *                                                                     *
 425 *     Fixes and Decls etc                                             *
 426 *                                                                     *
 427 *                                                                     *
 428 **********************************************************************/
 429
 430 maybefixes:  /* empty */                { $$ = Lnil; }
 431         |  fixes SEMI                   { $$ = $1; }
 432         ;
 433
 434 fixes   :  fix                          { $$ = $1; }
 435         |  fixes SEMI fix               { $$ = lconc($1,$3); }
 436         ;
 437
 438 fix     :  INFIXL INTEGER       { Precedence = checkfixity($2); Fixity = INFIXL; }
 439            ops                  { $$ = $4; }
 440         |  INFIXR INTEGER       { Precedence = checkfixity($2); Fixity = INFIXR; }
 441            ops                  { $$ = $4; }
 442         |  INFIX  INTEGER       { Precedence = checkfixity($2); Fixity = INFIX; }
 443            ops                  { $$ = $4; }
 444         |  INFIXL               { Fixity = INFIXL; Precedence = 9; }
 445            ops                  { $$ = $3; }
 446         |  INFIXR               { Fixity = INFIXR; Precedence = 9; }
 447            ops                  { $$ = $3; }
 448         |  INFIX                { Fixity = INFIX; Precedence = 9; }
 449            ops                  { $$ = $3; }
 450         ;
 451
 452 ops     :  op            { $$ = lsing(mkfixop(mknoqual($1),infixint(Fixity),Precedence)); }
 453         |  ops COMMA op  { $$ = lapp($1,mkfixop(mknoqual($3),infixint(Fixity),Precedence)); }
 454         ;
 455
 456 topdecls:  topdecl
 457         |  topdecls SEMI topdecl
 458                 {
 459                   if($1 != NULL)
 460                     if($3 != NULL)
 461                       if(SAMEFN)
 462                         {
 463                           extendfn($1,$3);
 464                           $$ = $1;
 465                         }
 466                       else
 467                         $$ = mkabind($1,$3);
 468                     else
 469                       $$ = $1;
 470                   else
 471                     $$ = $3;
 472                   SAMEFN = 0;
 473                 }
 474         ;
 475
 476 topdecl :  typed                                { $$ = $1; }
 477         |  datad                                { $$ = $1; }
 478         |  newtd                                { $$ = $1; }
 479         |  classd                               { $$ = $1; }
 480         |  instd                                { $$ = $1; }
 481         |  defaultd                             { $$ = $1; }
 482         |  decl                                 { $$ = $1; }
 483         ;
 484
 485 typed   :  typekey simple EQUAL type            { $$ = mknbind($2,$4,startlineno); }
 486         ;
 487
 488
 489 datad   :  datakey simple EQUAL constrs deriving
 490                 { $$ = mktbind(Lnil,$2,$4,$5,startlineno); }
 491         |  datakey context DARROW simple EQUAL constrs deriving
 492                 { $$ = mktbind($2,$4,$6,$7,startlineno); }
 493         ;
 494
 495 newtd   :  newtypekey simple EQUAL constr1 deriving
 496                 { $$ = mkntbind(Lnil,$2,$4,$5,startlineno); }
 497         |  newtypekey context DARROW simple EQUAL constr1 deriving
 498                 { $$ = mkntbind($2,$4,$6,$7,startlineno); }
 499         ;
 500
 501 deriving: /* empty */                           { $$ = mknothing(); }
 502         | DERIVING dtyclses                     { $$ = mkjust($2); }
 503         ;
 504
 505 classd  :  classkey context DARROW class cbody
 506                 { $$ = mkcbind($2,$4,$5,startlineno); }
 507         |  classkey class cbody
 508                 { $$ = mkcbind(Lnil,$2,$3,startlineno); }
 509         ;
 510
 511 cbody   :  /* empty */                          { $$ = mknullbind(); }
 512         |  WHERE ocurly decls ccurly            { checkorder($3); $$ = $3; }
 513         |  WHERE vocurly decls vccurly          { checkorder($3); $$ = $3; }
 514         ;
 515
 516 instd   :  instkey context DARROW gtycon restrict_inst rinst
 517                 { $$ = mkibind($2,$4,$5,$6,startlineno); }
 518         |  instkey gtycon general_inst rinst
 519                 { $$ = mkibind(Lnil,$2,$3,$4,startlineno); }
 520         ;
 521
 522 rinst   :  /* empty */                                          { $$ = mknullbind(); }
 523         |  WHERE ocurly  instdefs ccurly                        { $$ = $3; }
 524         |  WHERE vocurly instdefs vccurly                       { $$ = $3; }
 525         ;
 526
 527 restrict_inst : gtycon                          { $$ = mktname($1); }
 528         |  OPAREN gtyconvars CPAREN             { $$ = $2; }
 529         |  OPAREN tyvar COMMA tyvar_list CPAREN { $$ = mkttuple(mklcons($2,$4)); }
 530         |  OBRACK tyvar CBRACK                  { $$ = mktllist($2); }
 531         |  OPAREN tyvar RARROW tyvar CPAREN     { $$ = mktfun($2,$4); }
 532         ;
 533
 534 general_inst : gtycon                           { $$ = mktname($1); }
 535         |  OPAREN gtyconapp CPAREN              { $$ = $2; }
 536         |  OPAREN type COMMA types CPAREN       { $$ = mkttuple(mklcons($2,$4)); }
 537         |  OBRACK type CBRACK                   { $$ = mktllist($2); }
 538         |  OPAREN btype RARROW type CPAREN      { $$ = mktfun($2,$4); }
 539         ;
 540
 541 defaultd:  defaultkey OPAREN types CPAREN       { $$ = mkdbind($3,startlineno); }
 542         |  defaultkey OPAREN CPAREN             { $$ = mkdbind(Lnil,startlineno); }
 543         ;
 544
 545 decls   : decl
 546         | decls SEMI decl
 547                 {
 548                   if(SAMEFN)
 549                     {
 550                       extendfn($1,$3);
 551                       $$ = $1;
 552                     }
 553                   else
 554                     $$ = mkabind($1,$3);
 555                 }
 556         ;
 557
 558 /*
 559     Note: if there is an iclasop_pragma here, then we must be
 560     doing a class-op in an interface -- unless the user is up
 561     to real mischief (ugly, but likely to work).
 562 */
 563
 564 decl    : qvarsk DCOLON ctype
 565                 { $$ = mksbind($1,$3,startlineno);
 566                   PREVPATT = NULL; FN = NULL; SAMEFN = 0;
 567                 }
 568
 569         /* User-specified pragmas come in as "signatures"...
 570            They are similar in that they can appear anywhere in the module,
 571            and have to be "joined up" with their related entity.
 572
 573            Have left out the case specialising to an overloaded type.
 574            Let's get real, OK?  (WDP)
 575         */
 576         |  SPECIALISE_UPRAGMA qvark DCOLON types_and_maybe_ids END_UPRAGMA
 577                 {
 578                   $$ = mkvspec_uprag($2, $4, startlineno);
 579                   PREVPATT = NULL; FN = NULL; SAMEFN = 0;
 580                 }
 581
 582         |  SPECIALISE_UPRAGMA INSTANCE gtycon general_inst END_UPRAGMA
 583                 {
 584                   $$ = mkispec_uprag($3, $4, startlineno);
 585                   PREVPATT = NULL; FN = NULL; SAMEFN = 0;
 586                 }
 587
 588         |  SPECIALISE_UPRAGMA DATA gtycon atypes END_UPRAGMA
 589                 {
 590                   $$ = mkdspec_uprag($3, $4, startlineno);
 591                   PREVPATT = NULL; FN = NULL; SAMEFN = 0;
 592                 }
 593
 594         |  INLINE_UPRAGMA qvark END_UPRAGMA
 595                 {
 596                   $$ = mkinline_uprag($2, startlineno);
 597                   PREVPATT = NULL; FN = NULL; SAMEFN = 0;
 598                 }
 599
 600         |  MAGIC_UNFOLDING_UPRAGMA qvark vark END_UPRAGMA
 601                 {
 602                   $$ = mkmagicuf_uprag($2, $3, startlineno);
 603                   PREVPATT = NULL; FN = NULL; SAMEFN = 0;
 604                 }
 605
 606         |  DEFOREST_UPRAGMA qvark END_UPRAGMA
 607                 {
 608                   $$ = mkdeforest_uprag($2, startlineno);
 609                   PREVPATT = NULL; FN = NULL; SAMEFN = 0;
 610                 }
 611
 612         /* end of user-specified pragmas */
 613
 614         |  valdef
 615         |  /* empty */ { $$ = mknullbind(); PREVPATT = NULL; FN = NULL; SAMEFN = 0; }
 616         ;
 617
 618 qvarsk  :  qvark COMMA qvars_list               { $$ = mklcons($1,$3); }
 619         |  qvark                                { $$ = lsing($1); }
 620         ;
 621
 622 qvars_list: qvar                                { $$ = lsing($1); }
 623         |   qvars_list COMMA qvar               { $$ = lapp($1,$3); }
 624         ;
 625
 626 types_and_maybe_ids :
 627            type_and_maybe_id                            { $$ = lsing($1); }
 628         |  types_and_maybe_ids COMMA type_and_maybe_id  { $$ = lapp($1,$3); }
 629         ;
 630
 631 type_and_maybe_id :
 632            type                                 { $$ = mkvspec_ty_and_id($1,mknothing()); }
 633         |  type EQUAL qvark                     { $$ = mkvspec_ty_and_id($1,mkjust($3)); }
 634
 635
 636 /**********************************************************************
 637 *                                                                     *
 638 *                                                                     *
 639 *     Types etc                                                       *
 640 *                                                                     *
 641 *                                                                     *
 642 **********************************************************************/
 643
 644 /*  "DCOLON context => type" vs "DCOLON type" is a problem,
 645     because you can't distinguish between
 646
 647         foo :: (Baz a, Baz a)
 648         bar :: (Baz a, Baz a) => [a] -> [a] -> [a]
 649
 650     with one token of lookahead.  The HACK is to have "DCOLON ttype"
 651     [tuple type] in the first case, then check that it has the right
 652     form C a, or (C1 a, C2 b, ... Cn z) and convert it into a
 653     context.  Blaach!
 654 */
 655
 656         /* 1 S/R conflict at DARROW -> shift */
 657 ctype   : type DARROW type                      { $$ = mkcontext(type2context($1),$3); }
 658         | type
 659         ;
 660
 661         /* 1 S/R conflict at RARROW -> shift */
 662 type    :  btype                                { $$ = $1; }
 663         |  btype RARROW type                    { $$ = mktfun($1,$3); }
 664         ;
 665
 666 /* btype is split so we can parse gtyconapp without S/R conflicts */
 667 btype   :  gtyconapp                            { $$ = $1; }
 668         |  ntyconapp                            { $$ = $1; }
 669         ;
 670
 671 ntyconapp: ntycon                               { $$ = $1; }
 672         |  ntyconapp atype                      { $$ = mktapp($1,$2); }
 673         ;
 674
 675 gtyconapp: gtycon                               { $$ = mktname($1); }
 676         |  gtyconapp atype                      { $$ = mktapp($1,$2); }
 677         ;
 678
 679
 680 atype   :  gtycon                               { $$ = mktname($1); }
 681         |  ntycon                               { $$ = $1; }
 682         ;
 683
 684 ntycon  :  tyvar                                { $$ = $1; }
 685         |  OPAREN type COMMA types CPAREN       { $$ = mkttuple(mklcons($2,$4)); }
 686         |  OBRACK type CBRACK                   { $$ = mktllist($2); }
 687         |  OPAREN type CPAREN                   { $$ = $2; }
 688         ;
 689
 690 gtycon  :  qtycon
 691         |  OPAREN RARROW CPAREN                 { $$ = creategid(-2); }
 692         |  OBRACK CBRACK                        { $$ = creategid(-1); }
 693         |  OPAREN CPAREN                        { $$ = creategid(0); }
 694         |  OPAREN commas CPAREN                 { $$ = creategid($2); }
 695         ;
 696
 697 atypes  :  atype                                { $$ = lsing($1); }
 698         |  atypes atype                         { $$ = lapp($1,$2); }
 699         ;
 700
 701 types   :  type                                 { $$ = lsing($1); }
 702         |  types COMMA type                     { $$ = lapp($1,$3); }
 703         ;
 704
 705 commas  : COMMA                                 { $$ = 1; }
 706         | commas COMMA                          { $$ = $1 + 1; }
 707         ;
 708
 709 /**********************************************************************
 710 *                                                                     *
 711 *                                                                     *
 712 *     Declaration stuff                                               *
 713 *                                                                     *
 714 *                                                                     *
 715 **********************************************************************/
 716
 717 simple  :  gtycon                               { $$ = mktname($1); }
 718         |  gtyconvars                           { $$ = $1; }
 719         ;
 720
 721 gtyconvars: gtycon tyvar                        { $$ = mktapp(mktname($1),$2); }
 722         |  gtyconvars tyvar                     { $$ = mktapp($1,$2); }
 723         ;
 724
 725 context :  OPAREN context_list CPAREN           { $$ = $2; }
 726         |  class                                { $$ = lsing($1); }
 727         ;
 728
 729 context_list:  class                            { $$ = lsing($1); }
 730         |  context_list COMMA class             { $$ = lapp($1,$3); }
 731         ;
 732
 733 class   :  gtycon tyvar                         { $$ = mktapp(mktname($1),$2); }
 734         ;
 735
 736 constrs :  constr                               { $$ = lsing($1); }
 737         |  constrs VBAR constr                  { $$ = lapp($1,$3); }
 738         ;
 739
 740 constr  :  btyconapp                            { qid tyc; list tys;
 741                                                   splittyconapp($1, &tyc, &tys);
 742                                                   $$ = mkconstrpre(tyc,tys,hsplineno); }
 743         |  OPAREN qconsym CPAREN                { $$ = mkconstrpre($2,Lnil,hsplineno); }
 744         |  OPAREN qconsym CPAREN batypes        { $$ = mkconstrpre($2,$4,hsplineno); }
 745         |  btyconapp qconop bbtype              { checknobangs($1);
 746                                                   $$ = mkconstrinf($1,$2,$3,hsplineno); }
 747         |  ntyconapp qconop bbtype              { $$ = mkconstrinf($1,$2,$3,hsplineno); }
 748         |  BANG atype qconop bbtype             { $$ = mkconstrinf(mktbang($2),$3,$4,hsplineno); }
 749
 750         /* 1 S/R conflict on OCURLY -> shift */
 751         |  gtycon OCURLY fields CCURLY          { $$ = mkconstrrec($1,$3,hsplineno); }
 752         ;
 753
 754 btyconapp: gtycon                               { $$ = mktname($1); }
 755         |  btyconapp batype                     { $$ = mktapp($1,$2); }
 756         ;
 757
 758 bbtype  :  btype                                { $$ = $1; }
 759         |  BANG atype                           { $$ = mktbang($2); }
 760         ;
 761
 762 batype  :  atype                                { $$ = $1; }
 763         |  BANG atype                           { $$ = mktbang($2); }
 764         ;
 765
 766 batypes :  batype                               { $$ = lsing($1); }
 767         |  batypes batype                       { $$ = lapp($1,$2); }
 768         ;
 769
 770
 771 fields  : field                                 { $$ = lsing($1); }
 772         | fields COMMA field                    { $$ = lapp($1,$3); }
 773         ;
 774
 775 field   :  qvars_list DCOLON type               { $$ = mkfield($1,$3); }
 776         |  qvars_list DCOLON BANG atype         { $$ = mkfield($1,mktbang($4)); }
 777         ;
 778
 779 constr1 :  gtycon atype                         { $$ = lsing(mkconstrnew($1,$2,hsplineno)); }
 780         ;
 781
 782
 783 dtyclses:  OPAREN dtycls_list CPAREN            { $$ = $2; }
 784         |  OPAREN CPAREN                        { $$ = Lnil; }
 785         |  qtycls                               { $$ = lsing($1); }
 786         ;
 787
 788 dtycls_list:  qtycls                            { $$ = lsing($1); }
 789         |  dtycls_list COMMA qtycls             { $$ = lapp($1,$3); }
 790         ;
 791
 792 instdefs : /* empty */                          { $$ = mknullbind(); }
 793          | instdef                              { $$ = $1; }
 794          | instdefs SEMI instdef
 795                 {
 796                   if(SAMEFN)
 797                     {
 798                       extendfn($1,$3);
 799                       $$ = $1;
 800                     }
 801                   else
 802                     $$ = mkabind($1,$3);
 803                 }
 804         ;
 805
 806 /* instdef: same as valdef, except certain user-pragmas may appear */
 807 instdef :
 808            SPECIALISE_UPRAGMA qvark DCOLON types_and_maybe_ids END_UPRAGMA
 809                 {
 810                   $$ = mkvspec_uprag($2, $4, startlineno);
 811                   PREVPATT = NULL; FN = NULL; SAMEFN = 0;
 812                 }
 813
 814         |  INLINE_UPRAGMA qvark END_UPRAGMA
 815                 {
 816                   $$ = mkinline_uprag($2, startlineno);
 817                   PREVPATT = NULL; FN = NULL; SAMEFN = 0;
 818                 }
 819
 820         |  MAGIC_UNFOLDING_UPRAGMA qvark vark END_UPRAGMA
 821                 {
 822                   $$ = mkmagicuf_uprag($2, $3, startlineno);
 823                   PREVPATT = NULL; FN = NULL; SAMEFN = 0;
 824                 }
 825
 826         |  valdef
 827         ;
 828
 829
 830 valdef  :  vallhs
 831                 {
 832                   tree fn = function($1);
 833                   PREVPATT = $1;
 834
 835                   if(ttree(fn) == ident)
 836                     {
 837                       qid fun_id = gident((struct Sident *) fn);
 838                       checksamefn(fun_id);
 839                       FN = fun_id;
 840                     }
 841
 842                   else if (ttree(fn) == infixap)
 843                     {
 844                       qid fun_id = ginffun((struct Sinfixap *) fn);
 845                       checksamefn(fun_id);
 846                       FN = fun_id;
 847                     }
 848
 849                   else if(etags)
 850 #if 1/*etags*/
 851                     printf("%u\n",startlineno);
 852 #else
 853                     fprintf(stderr,"%u\tvaldef\n",startlineno);
 854 #endif
 855                 }
 856            valrhs
 857                 {
 858                   if ( lhs_is_patt($1) )
 859                     {
 860                       $$ = mkpbind($3, startlineno);
 861                       FN = NULL;
 862                       SAMEFN = 0;
 863                     }
 864                   else
 865                     $$ = mkfbind($3,startlineno);
 866
 867                   PREVPATT = NULL;
 868                 }
 869         ;
 870
 871 vallhs  : patk                                  { $$ = $1; }
 872         | patk qvarop pat                       { $$ = mkinfixap($2,$1,$3); }
 873         | funlhs                                { $$ = $1; }
 874         ;
 875
 876 funlhs  :  qvark apat                           { $$ = mkap(mkident($1),$2); }
 877         |  funlhs apat                          { $$ = mkap($1,$2); }
 878         ;
 879
 880
 881 valrhs  :  valrhs1 maybe_where                  { $$ = lsing(createpat($1, $2)); }
 882         ;
 883
 884 valrhs1 :  gdrhs                                { $$ = mkpguards($1); }
 885         |  EQUAL exp                            { $$ = mkpnoguards($2); }
 886         ;
 887
 888 gdrhs   :  gd EQUAL exp                         { $$ = lsing(mkpgdexp($1,$3)); }
 889         |  gd EQUAL exp gdrhs                   { $$ = mklcons(mkpgdexp($1,$3),$4); }
 890         ;
 891
 892 maybe_where:
 893            WHERE ocurly decls ccurly            { $$ = $3; }
 894         |  WHERE vocurly decls vccurly          { $$ = $3; }
 895         |  /* empty */                          { $$ = mknullbind(); }
 896         ;
 897
 898 gd      :  VBAR oexp                            { $$ = $2; }
 899         ;
 900
 901
 902 /**********************************************************************
 903 *                                                                     *
 904 *                                                                     *
 905 *     Expressions                                                     *
 906 *                                                                     *
 907 *                                                                     *
 908 **********************************************************************/
 909
 910 exp     :  oexp DCOLON ctype                    { $$ = mkrestr($1,$3); }
 911         |  oexp
 912         ;
 913
 914 /*
 915   Operators must be left-associative at the same precedence for
 916   precedence parsing to work.
 917 */
 918         /* 8 S/R conflicts on qop -> shift */
 919 oexp    :  oexp qop oexp %prec MINUS            { $$ = mkinfixap($2,$1,$3); }
 920         |  dexp
 921         ;
 922
 923 /*
 924   This comes here because of the funny precedence rules concerning
 925   prefix minus.
 926 */
 927 dexp    :  MINUS kexp                           { $$ = mknegate($2); }
 928         |  kexp
 929         ;
 930
 931 /*
 932   We need to factor out a leading let expression so we can set
 933   inpat=TRUE when parsing (non let) expressions inside stmts and quals
 934 */
 935 expLno  :  oexpLno DCOLON ctype                 { $$ = mkrestr($1,$3); }
 936         |  oexpLno
 937         ;
 938 oexpLno :  oexpLno qop oexp %prec MINUS         { $$ = mkinfixap($2,$1,$3); }
 939         |  dexpLno
 940         ;
 941 dexpLno :  MINUS kexp                           { $$ = mknegate($2); }
 942         |  kexpLno
 943         ;
 944
 945 expL    :  oexpL DCOLON ctype                   { $$ = mkrestr($1,$3); }
 946         |  oexpL
 947         ;
 948 oexpL   :  oexpL qop oexp %prec MINUS           { $$ = mkinfixap($2,$1,$3); }
 949         |  kexpL
 950         ;
 951
 952 /*
 953   let/if/lambda/case have higher precedence than infix operators.
 954 */
 955
 956 kexp    :  kexpL
 957         |  kexpLno
 958         ;
 959
 960 kexpL   :  letdecls IN exp                      { $$ = mklet($1,$3); }
 961         ;
 962
 963 kexpLno :  LAMBDA
 964                 { hsincindent();        /* push new context for FN = NULL;        */
 965                   FN = NULL;            /* not actually concerned about indenting */
 966                   $<ulong>$ = hsplineno; /* remember current line number           */
 967                 }
 968            lampats
 969                 { hsendindent();
 970                 }
 971            RARROW exp                   /* lambda abstraction */
 972                 {
 973                   $$ = mklambda($3, $6, $<ulong>2);
 974                 }
 975
 976         /* If Expression */
 977         |  IF {$<ulong>$ = hsplineno;}
 978            exp THEN exp ELSE exp                { $$ = mkife($3,$5,$7,$<ulong>2); }
 979
 980         /* Case Expression */
 981         |  CASE {$<ulong>$ = hsplineno;}
 982            exp OF caserest                      { $$ = mkcasee($3,$5,$<ulong>2); }
 983
 984         /* Do Expression */
 985         |  DO {$<ulong>$ = hsplineno;}
 986            dorest                               { $$ = mkdoe($3,$<ulong>2); }
 987
 988         /* CCALL/CASM Expression */
 989         |  CCALL ccallid cexps                  { $$ = mkccall($2,install_literal("n"),$3); }
 990         |  CCALL ccallid                        { $$ = mkccall($2,install_literal("n"),Lnil); }
 991         |  CCALL_GC ccallid cexps               { $$ = mkccall($2,install_literal("p"),$3); }
 992         |  CCALL_GC ccallid                     { $$ = mkccall($2,install_literal("p"),Lnil); }
 993         |  CASM CLITLIT cexps                   { $$ = mkccall($2,install_literal("N"),$3); }
 994         |  CASM CLITLIT                         { $$ = mkccall($2,install_literal("N"),Lnil); }
 995         |  CASM_GC CLITLIT cexps                { $$ = mkccall($2,install_literal("P"),$3); }
 996         |  CASM_GC CLITLIT                      { $$ = mkccall($2,install_literal("P"),Lnil); }
 997
 998         /* SCC Expression */
 999         |  SCC STRING exp
1000                 { if (ignoreSCC) {
1001                     $$ = $3;
1002                   } else {
1003                     $$ = mkscc($2, $3);
1004                   }
1005                 }
1006         |  fexp
1007         ;
1008
1009 fexp    :  fexp aexp                            { $$ = mkap($1,$2); }
1010         |  aexp
1011         ;
1012
1013         /* simple expressions */
1014 aexp    :  qvar                                 { $$ = mkident($1); }
1015         |  gcon                                 { $$ = mkident($1); }
1016         |  lit_constant                         { $$ = mklit($1); }
1017         |  OPAREN exp CPAREN                    { $$ = mkpar($2); }         /* mkpar: stop infix parsing at ()'s */
1018         |  qcon OCURLY CCURLY                   { $$ = mkrecord($1,Lnil); }
1019         |  qcon OCURLY rbinds CCURLY            { $$ = mkrecord($1,$3); }   /* 1 S/R conflict on OCURLY -> shift */
1020         |  OBRACK list_exps CBRACK              { $$ = mkllist($2); }
1021         |  OPAREN exp COMMA texps CPAREN        { if (ttree($4) == tuple)
1022                                                      $$ = mktuple(mklcons($2, gtuplelist((struct Stuple *) $4)));
1023                                                   else
1024                                                      $$ = mktuple(ldub($2, $4)); }
1025
1026         /* only in expressions ... */
1027         |  aexp OCURLY rbinds CCURLY            { $$ = mkrupdate($1,$3); }
1028         |  OBRACK exp VBAR quals CBRACK         { $$ = mkcomprh($2,$4); }
1029         |  OBRACK exp COMMA exp DOTDOT exp CBRACK {$$= mkeenum($2,mkjust($4),mkjust($6)); }
1030         |  OBRACK exp COMMA exp DOTDOT CBRACK   { $$ = mkeenum($2,mkjust($4),mknothing()); }
1031         |  OBRACK exp DOTDOT exp CBRACK         { $$ = mkeenum($2,mknothing(),mkjust($4)); }
1032         |  OBRACK exp DOTDOT CBRACK             { $$ = mkeenum($2,mknothing(),mknothing()); }
1033         |  OPAREN oexp qop CPAREN               { $$ = mklsection($2,$3); }
1034         |  OPAREN qop1 oexp CPAREN              { $$ = mkrsection($2,$3); }
1035
1036         /* only in patterns ... */
1037         /* these add 2 S/R conflict with with  aexp . OCURLY rbinds CCURLY */
1038         |  qvar AT aexp                         { checkinpat(); $$ = mkas($1,$3); }
1039         |  LAZY aexp                            { checkinpat(); $$ = mklazyp($2); }
1040         |  WILDCARD                             { checkinpat(); $$ = mkwildp();   }
1041         ;
1042
1043         /* ccall arguments */
1044 cexps   :  cexps aexp                           { $$ = lapp($1,$2); }
1045         |  aexp                                 { $$ = lsing($1); }
1046         ;
1047
1048 caserest:  ocurly alts ccurly                   { $$ = $2; }
1049         |  vocurly alts vccurly                 { $$ = $2; }
1050
1051 dorest  :  ocurly stmts ccurly                  { checkdostmts($2); $$ = $2; }
1052         |  vocurly stmts vccurly                { checkdostmts($2); $$ = $2; }
1053         ;
1054
1055 rbinds  :  rbind                                { $$ = lsing($1); }
1056         |  rbinds COMMA rbind                   { $$ = lapp($1,$3); }
1057         ;
1058
1059 rbind   :  qvar                                 { $$ = mkrbind($1,mknothing()); }
1060         |  qvar EQUAL exp                       { $$ = mkrbind($1,mkjust($3)); }
1061         ;
1062
1063 texps   :  exp  { $$ = mkpar($1); }     /* mkpar: so we don't flatten last element in tuple */
1064         |  exp COMMA texps
1065                 { if (ttree($3) == tuple)
1066                     $$ = mktuple(mklcons($1, gtuplelist((struct Stuple *) $3)));
1067                   else if (ttree($3) == par)
1068                     $$ = mktuple(ldub($1, gpare((struct Spar *) $3)));
1069                   else
1070                     hsperror("hsparser:texps: panic");
1071                 }
1072         /* right recursion? WDP */
1073         ;
1074
1075
1076 list_exps :
1077            exp                                  { $$ = lsing($1); }
1078         |  exp COMMA list_exps          { $$ = mklcons($1, $3); }
1079         /* right recursion? (WDP)
1080
1081            It has to be this way, though, otherwise you
1082            may do the wrong thing to distinguish between...
1083
1084            [ e1 , e2 .. ]       -- an enumeration ...
1085            [ e1 , e2 , e3 ]     -- a list
1086
1087            (In fact, if you change the grammar and throw yacc/bison
1088            at it, it *will* do the wrong thing [WDP 94/06])
1089         */
1090         ;
1091
1092 letdecls:  LET ocurly decls ccurly              { $$ = $3 }
1093         |  LET vocurly decls vccurly            { $$ = $3 }
1094         ;
1095
1096 quals   :  qual                                 { $$ = lsing($1); }
1097         |  quals COMMA qual                     { $$ = lapp($1,$3); }
1098         ;
1099
1100 qual    :  letdecls                             { $$ = mkseqlet($1); }
1101         |  expL                                 { $$ = $1; }
1102         |  {inpat=TRUE;} expLno {inpat=FALSE;}leftexp
1103                 { if ($4 == NULL) {
1104                       expORpat(LEGIT_EXPR,$2);
1105                       $$ = mkguard($2);
1106                   } else {
1107                       expORpat(LEGIT_PATT,$2);
1108                       $$ = mkqual($2,$4);
1109                   }
1110                 }
1111         ;
1112
1113 alts    :  alt                                  { $$ = $1; }
1114         |  alts SEMI alt                        { $$ = lconc($1,$3); }
1115         ;
1116
1117 alt     :  pat { PREVPATT = $1; } altrest       { $$ = lsing($3); PREVPATT = NULL; }
1118         |  /* empty */                          { $$ = Lnil; }
1119         ;
1120
1121 altrest :  gdpat maybe_where                    { $$ = createpat(mkpguards($1), $2); }
1122         |  RARROW exp maybe_where               { $$ = createpat(mkpnoguards($2),$3); }
1123         ;
1124
1125 gdpat   :  gd RARROW exp                        { $$ = lsing(mkpgdexp($1,$3)); }
1126         |  gd RARROW exp gdpat                  { $$ = mklcons(mkpgdexp($1,$3),$4);  }
1127         ;
1128
1129 stmts   :  stmt                                 { $$ = $1; }
1130         |  stmts SEMI stmt                      { $$ = lconc($1,$3); }
1131         ;
1132
1133 stmt    :  /* empty */                          { $$ = Lnil; }
1134         |  letdecls                             { $$ = lsing(mkseqlet($1)); }
1135         |  expL                                 { $$ = lsing($1); }
1136         |  {inpat=TRUE;} expLno {inpat=FALSE;} leftexp
1137                 { if ($4 == NULL) {
1138                       expORpat(LEGIT_EXPR,$2);
1139                       $$ = lsing(mkdoexp($2,endlineno));
1140                   } else {
1141                       expORpat(LEGIT_PATT,$2);
1142                       $$ = lsing(mkdobind($2,$4,endlineno));
1143                   }
1144                 }
1145         ;
1146
1147 leftexp :  LARROW exp                           { $$ = $2; }
1148         |  /* empty */                          { $$ = NULL; }
1149         ;
1150
1151 /**********************************************************************
1152 *                                                                     *
1153 *                                                                     *
1154 *     Patterns                                                        *
1155 *                                                                     *
1156 *                                                                     *
1157 **********************************************************************/
1158
1159 pat     :  pat qconop bpat                      { $$ = mkinfixap($2,$1,$3); }
1160         |  bpat
1161         ;
1162
1163 bpat    :  apatc
1164         |  conpat
1165         |  qcon OCURLY rpats CCURLY             { $$ = mkrecord($1,$3); }
1166         |  MINUS INTEGER                        { $$ = mknegate(mklit(mkinteger($2))); }
1167         |  MINUS FLOAT                          { $$ = mknegate(mklit(mkfloatr($2))); }
1168         ;
1169
1170 conpat  :  gcon                                 { $$ = mkident($1); }
1171         |  conpat apat                          { $$ = mkap($1,$2); }
1172         ;
1173
1174 apat    :  gcon                                 { $$ = mkident($1); }
1175         |  qcon OCURLY rpats CCURLY             { $$ = mkrecord($1,$3); }
1176         |  apatc
1177         ;
1178
1179 apatc   :  qvar                                 { $$ = mkident($1); }
1180         |  qvar AT apat                         { $$ = mkas($1,$3); }
1181         |  lit_constant                         { $$ = mklit($1); }
1182         |  WILDCARD                             { $$ = mkwildp(); }
1183         |  OPAREN pat CPAREN                    { $$ = mkpar($2); }
1184         |  OPAREN pat COMMA pats CPAREN         { $$ = mktuple(mklcons($2,$4)); }
1185         |  OBRACK pats CBRACK                   { $$ = mkllist($2); }
1186         |  LAZY apat                            { $$ = mklazyp($2); }
1187         ;
1188
1189 lit_constant:
1190            INTEGER                              { $$ = mkinteger($1); }
1191         |  FLOAT                                { $$ = mkfloatr($1); }
1192         |  CHAR                                 { $$ = mkcharr($1); }
1193         |  STRING                               { $$ = mkstring($1); }
1194         |  CHARPRIM                             { $$ = mkcharprim($1); }
1195         |  STRINGPRIM                           { $$ = mkstringprim($1); }
1196         |  INTPRIM                              { $$ = mkintprim($1); }
1197         |  FLOATPRIM                            { $$ = mkfloatprim($1); }
1198         |  DOUBLEPRIM                           { $$ = mkdoubleprim($1); }
1199         |  CLITLIT /* yurble yurble */          { $$ = mkclitlit($1); }
1200         ;
1201
1202 lampats :  apat lampats                         { $$ = mklcons($1,$2); }
1203         |  apat                                 { $$ = lsing($1); }
1204         /* right recursion? (WDP) */
1205         ;
1206
1207 pats    :  pat COMMA pats                       { $$ = mklcons($1, $3); }
1208         |  pat                                  { $$ = lsing($1); }
1209         /* right recursion? (WDP) */
1210         ;
1211
1212 rpats   : rpat                                  { $$ = lsing($1); }
1213         | rpats COMMA rpat                      { $$ = lapp($1,$3); }
1214         ;
1215
1216 rpat    :  qvar                                 { $$ = mkrbind($1,mknothing()); }
1217         |  qvar EQUAL pat                       { $$ = mkrbind($1,mkjust($3)); }
1218         ;
1219
1220
1221 patk    :  patk qconop bpat                     { $$ = mkinfixap($2,$1,$3); }
1222         |  bpatk
1223         ;
1224
1225 bpatk   :  apatck
1226         |  conpatk
1227         |  qconk OCURLY rpats CCURLY            { $$ = mkrecord($1,$3); }
1228         |  minuskey INTEGER                     { $$ = mknegate(mklit(mkinteger($2))); }
1229         |  minuskey FLOAT                       { $$ = mknegate(mklit(mkfloatr($2))); }
1230         ;
1231
1232 conpatk :  gconk                                { $$ = mkident($1); }
1233         |  conpatk apat                         { $$ = mkap($1,$2); }
1234         ;
1235
1236 apatck  :  qvark                                { $$ = mkident($1); }
1237         |  qvark AT apat                        { $$ = mkas($1,$3); }
1238         |  lit_constant                         { $$ = mklit($1); setstartlineno(); }
1239         |  WILDCARD                             { $$ = mkwildp(); setstartlineno(); }
1240         |  oparenkey pat CPAREN                 { $$ = mkpar($2); }
1241         |  oparenkey pat COMMA pats CPAREN      { $$ = mktuple(mklcons($2,$4)); }
1242         |  obrackkey pats CBRACK                { $$ = mkllist($2); }
1243         |  lazykey apat                         { $$ = mklazyp($2); }
1244         ;
1245
1246
1247 gcon    :  qcon
1248         |  OBRACK CBRACK                        { $$ = creategid(-1); }
1249         |  OPAREN CPAREN                        { $$ = creategid(0); }
1250         |  OPAREN commas CPAREN                 { $$ = creategid($2); }
1251         ;
1252
1253 gconk   :  qconk
1254         |  obrackkey CBRACK                     { $$ = creategid(-1); }
1255         |  oparenkey CPAREN                     { $$ = creategid(0); }
1256         |  oparenkey commas CPAREN              { $$ = creategid($2); }
1257         ;
1258
1259 /**********************************************************************
1260 *                                                                     *
1261 *                                                                     *
1262 *     Keywords which record the line start                            *
1263 *                                                                     *
1264 *                                                                     *
1265 **********************************************************************/
1266
1267 importkey:  IMPORT      { setstartlineno(); }
1268         ;
1269
1270 datakey :   DATA        { setstartlineno();
1271                           if(etags)
1272 #if 1/*etags*/
1273                             printf("%u\n",startlineno);
1274 #else
1275                             fprintf(stderr,"%u\tdata\n",startlineno);
1276 #endif
1277                         }
1278         ;
1279
1280 typekey :   TYPE        { setstartlineno();
1281                           if(etags)
1282 #if 1/*etags*/
1283                             printf("%u\n",startlineno);
1284 #else
1285                             fprintf(stderr,"%u\ttype\n",startlineno);
1286 #endif
1287                         }
1288         ;
1289
1290 newtypekey : NEWTYPE    { setstartlineno();
1291                           if(etags)
1292 #if 1/*etags*/
1293                             printf("%u\n",startlineno);
1294 #else
1295                             fprintf(stderr,"%u\tnewtype\n",startlineno);
1296 #endif
1297                         }
1298         ;
1299
1300 instkey :   INSTANCE    { setstartlineno();
1301 #if 1/*etags*/
1302 /* OUT:                   if(etags)
1303                             printf("%u\n",startlineno);
1304 */
1305 #else
1306                             fprintf(stderr,"%u\tinstance\n",startlineno);
1307 #endif
1308                         }
1309         ;
1310
1311 defaultkey: DEFAULT     { setstartlineno(); }
1312         ;
1313
1314 classkey:   CLASS       { setstartlineno();
1315                           if(etags)
1316 #if 1/*etags*/
1317                             printf("%u\n",startlineno);
1318 #else
1319                             fprintf(stderr,"%u\tclass\n",startlineno);
1320 #endif
1321                         }
1322         ;
1323
1324 modulekey:  MODULE      { setstartlineno();
1325                           if(etags)
1326 #if 1/*etags*/
1327                             printf("%u\n",startlineno);
1328 #else
1329                             fprintf(stderr,"%u\tmodule\n",startlineno);
1330 #endif
1331                         }
1332         ;
1333
1334 oparenkey:  OPAREN      { setstartlineno(); }
1335         ;
1336
1337 obrackkey:  OBRACK      { setstartlineno(); }
1338         ;
1339
1340 lazykey :   LAZY        { setstartlineno(); }
1341         ;
1342
1343 minuskey:   MINUS       { setstartlineno(); }
1344         ;
1345
1346
1347 /**********************************************************************
1348 *                                                                     *
1349 *                                                                     *
1350 *     Basic qualified/unqualified ids/ops                             *
1351 *                                                                     *
1352 *                                                                     *
1353 **********************************************************************/
1354
1355 qvar    :  qvarid
1356         |  OPAREN qvarsym CPAREN        { $$ = $2; }
1357         ;
1358 qcon    :  qconid
1359         |  OPAREN qconsym CPAREN        { $$ = $2; }
1360         ;
1361 qvarop  :  qvarsym
1362         |  BQUOTE qvarid BQUOTE         { $$ = $2; }
1363         ;
1364 qconop  :  qconsym
1365         |  BQUOTE qconid BQUOTE         { $$ = $2; }
1366         ;
1367 qop     :  qconop
1368         |  qvarop
1369         ;
1370
1371 /* Non "-" op, used in right sections */
1372 qop1    :  qconop
1373         |  qvarop1
1374         ;
1375
1376 /* Non "-" varop, used in right sections */
1377 qvarop1 :  QVARSYM
1378         |  varsym_nominus               { $$ = mknoqual($1); }
1379         |  BQUOTE qvarid BQUOTE         { $$ = $2; }
1380         ;
1381
1382
1383 var     :  varid
1384         |  OPAREN varsym CPAREN         { $$ = $2; }
1385         ;
1386 con     :  tycon                        /* using tycon removes conflicts */
1387         |  OPAREN CONSYM CPAREN         { $$ = $2; }
1388         ;
1389 varop   :  varsym
1390         |  BQUOTE varid BQUOTE          { $$ = $2; }
1391         ;
1392 conop   :  CONSYM
1393         |  BQUOTE CONID BQUOTE          { $$ = $2; }
1394         ;
1395 op      :  conop
1396         |  varop
1397         ;
1398
1399 qvark   :  qvarid                       { setstartlineno(); $$ = $1; }
1400         |  oparenkey qvarsym CPAREN     { $$ = $2; }
1401         ;
1402 qconk   :  qconid                       { setstartlineno(); $$ = $1; }
1403         |  oparenkey qconsym CPAREN     { $$ = $2; }
1404         ;
1405 vark    :  varid                        { setstartlineno(); $$ = $1; }
1406         |  oparenkey varsym CPAREN      { $$ = $2; }
1407         ;
1408
1409 qvarid  :  QVARID
1410         |  varid                        { $$ = mknoqual($1); }
1411         ;
1412 qvarsym :  QVARSYM
1413         |  varsym                       { $$ = mknoqual($1); }
1414         ;
1415 qconid  :  QCONID
1416         |  tycon                        { $$ = mknoqual($1); } /* using tycon removes conflicts */
1417         ;
1418 qconsym :  QCONSYM
1419         |  CONSYM                       { $$ = mknoqual($1); }
1420         ;
1421 qtycon  :  QCONID
1422         |  tycon                        { $$ = mknoqual($1); } /* using tycon removes conflicts */
1423         ;
1424 qtycls  :  QCONID
1425         |  tycon                        { $$ = mknoqual($1); } /* using tycon removes conflicts */
1426         ;
1427
1428 varsym  :  varsym_nominus
1429         |  MINUS                        { $$ = install_literal("-"); }
1430         ;
1431
1432 /* AS HIDING QUALIFIED are valid varids */
1433 varid   :  VARID
1434         |  AS                           { $$ = install_literal("as"); }
1435         |  HIDING                       { $$ = install_literal("hiding"); }
1436         |  QUALIFIED                    { $$ = install_literal("qualified"); }
1437         ;
1438
1439 /* BANG are valid varsyms */
1440 varsym_nominus : VARSYM
1441         |  BANG                         { $$ = install_literal("!"); }
1442         ;
1443
1444 ccallid :  VARID
1445         |  CONID
1446         ;
1447
1448 tyvar   :  varid                        { $$ = mknamedtvar(mknoqual($1)); }
1449         ;
1450 tycon   :  CONID
1451         ;
1452 modid   :  CONID
1453         ;
1454
1455 tyvar_list: tyvar                       { $$ = lsing($1); }
1456         |  tyvar_list COMMA tyvar       { $$ = lapp($1,$3); }
1457         ;
1458
1459 /**********************************************************************
1460 *                                                                     *
1461 *                                                                     *
1462 *     Stuff to do with layout                                         *
1463 *                                                                     *
1464 *                                                                     *
1465 **********************************************************************/
1466
1467 ocurly  : layout OCURLY                         { hsincindent(); }
1468
1469 vocurly : layout                                { hssetindent(); }
1470         ;
1471
1472 layout  :                                       { hsindentoff(); }
1473         ;
1474
1475 ccurly  :
1476          CCURLY
1477                 {
1478                   FN = NULL; SAMEFN = 0; PREVPATT = NULL;
1479                   hsendindent();
1480                 }
1481         ;
1482
1483 vccurly :  { expect_ccurly = 1; }  vccurly1  { expect_ccurly = 0; }
1484         ;
1485
1486 vccurly1:
1487          VCCURLY
1488                 {
1489                   FN = NULL; SAMEFN = 0; PREVPATT = NULL;
1490                   hsendindent();
1491                 }
1492         | error
1493                 {
1494                   yyerrok;
1495                   FN = NULL; SAMEFN = 0; PREVPATT = NULL;
1496                   hsendindent();
1497                 }
1498         ;
1499
1500 %%
1501
1502 /**********************************************************************
1503 *                                                                     *
1504 *      Error Processing and Reporting                                 *
1505 *                                                                     *
1506 *  (This stuff is here in case we want to use Yacc macros and such.)  *
1507 *                                                                     *
1508 **********************************************************************/
1509
1510 void
1511 checkinpat()
1512 {
1513   if(!inpat)
1514     hsperror("pattern syntax used in expression");
1515 }
1516
1517
1518 /* The parser calls "hsperror" when it sees a
1519    `report this and die' error.  It sets the stage
1520    and calls "yyerror".
1521
1522    There should be no direct calls in the parser to
1523    "yyerror", except for the one from "hsperror".  Thus,
1524    the only other calls will be from the error productions
1525    introduced by yacc/bison/whatever.
1526
1527    We need to be able to recognise the from-error-production
1528    case, because we sometimes want to say, "Oh, never mind",
1529    because the layout rule kicks into action and may save
1530    the day.  [WDP]
1531 */
1532
1533 static BOOLEAN error_and_I_mean_it = FALSE;
1534
1535 void
1536 hsperror(s)
1537   char *s;
1538 {
1539     error_and_I_mean_it = TRUE;
1540     yyerror(s);
1541 }
1542
1543 extern char *yytext;
1544 extern int yyleng;
1545
1546 void
1547 yyerror(s)
1548   char *s;
1549 {
1550     /* We want to be able to distinguish 'error'-raised yyerrors
1551        from yyerrors explicitly coded by the parser hacker.
1552     */
1553     if (expect_ccurly && ! error_and_I_mean_it ) {
1554         /*NOTHING*/;
1555
1556     } else {
1557         fprintf(stderr, "\"%s\", line %d, column %d: %s on input: ",
1558           input_filename, hsplineno, hspcolno + 1, s);
1559
1560         if (yyleng == 1 && *yytext == '\0')
1561             fprintf(stderr, "<EOF>");
1562
1563         else {
1564             fputc('"', stderr);
1565             format_string(stderr, (unsigned char *) yytext, yyleng);
1566             fputc('"', stderr);
1567         }
1568         fputc('\n', stderr);
1569
1570         /* a common problem */
1571         if (strcmp(yytext, "#") == 0)
1572             fprintf(stderr, "\t(Perhaps you forgot a `-cpp' or `-fglasgow-exts' flag?)\n");
1573
1574         exit(1);
1575     }
1576 }
1577
1578 void
1579 format_string(fp, s, len)
1580   FILE *fp;
1581   unsigned char *s;
1582   int len;
1583 {
1584     while (len-- > 0) {
1585         switch (*s) {
1586         case '\0':    fputs("\\NUL", fp);   break;
1587         case '\007':  fputs("\\a", fp);     break;
1588         case '\010':  fputs("\\b", fp);     break;
1589         case '\011':  fputs("\\t", fp);     break;
1590         case '\012':  fputs("\\n", fp);     break;
1591         case '\013':  fputs("\\v", fp);     break;
1592         case '\014':  fputs("\\f", fp);     break;
1593         case '\015':  fputs("\\r", fp);     break;
1594         case '\033':  fputs("\\ESC", fp);   break;
1595         case '\034':  fputs("\\FS", fp);    break;
1596         case '\035':  fputs("\\GS", fp);    break;
1597         case '\036':  fputs("\\RS", fp);    break;
1598         case '\037':  fputs("\\US", fp);    break;
1599         case '\177':  fputs("\\DEL", fp);   break;
1600         default:
1601             if (*s >= ' ')
1602                 fputc(*s, fp);
1603             else
1604                 fprintf(fp, "\\^%c", *s + '@');
1605             break;
1606         }
1607         s++;
1608     }
1609 }