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