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