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