ghc/compiler/parser/hsparser.y

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