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