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