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