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