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