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