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