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
 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
 552 callconv: STDCALL       { $$ = CALLCONV_STDCALL;  }
 553         | C_CALL        { $$ = CALLCONV_CCALL;    }
 554         | PASCAL        { $$ = CALLCONV_PASCAL;   }
 555         | FASTCALL      { $$ = CALLCONV_FASTCALL; }
 556         ;
 557
 558 ext_name: STRING        { $$ = mkjust(lsing($1)); }
 559         | STRING STRING { $$ = mkjust(mklcons ($1,lsing($2))); }
 560         | DYNAMIC       { $$ = mknothing();   }
 561
 562 unsafe_flag: UNSAFE     { $$ = 1; }
 563            | /*empty*/  { $$ = 0; }
 564            ;
 565
 566
 567
 568 decls   : decl
 569         | decls SEMI decl
 570                 {
 571                   if(SAMEFN)
 572                     {
 573                       extendfn($1,$3);
 574                       $$ = $1;
 575                     }
 576                   else
 577                     $$ = mkabind($1,$3);
 578                 }
 579         ;
 580
 581 /*
 582     Note: if there is an iclasop_pragma here, then we must be
 583     doing a class-op in an interface -- unless the user is up
 584     to real mischief (ugly, but likely to work).
 585 */
 586
 587 decl    : qvarsk DCOLON sigtype
 588                 { $$ = mksbind($1,$3,startlineno);
 589                   PREVPATT = NULL; FN = NULL; SAMEFN = 0;
 590                 }
 591
 592         /* User-specified pragmas come in as "signatures"...
 593            They are similar in that they can appear anywhere in the module,
 594            and have to be "joined up" with their related entity.
 595
 596            Have left out the case specialising to an overloaded type.
 597            Let's get real, OK?  (WDP)
 598         */
 599         |  SPECIALISE_UPRAGMA qvark DCOLON types_and_maybe_ids END_UPRAGMA
 600                 {
 601                   $$ = mkvspec_uprag($2, $4, startlineno);
 602                   PREVPATT = NULL; FN = NULL; SAMEFN = 0;
 603                 }
 604
 605         |  SPECIALISE_UPRAGMA INSTANCE gtycon atype END_UPRAGMA
 606                 {
 607                   $$ = mkispec_uprag($3, $4, startlineno);
 608                   PREVPATT = NULL; FN = NULL; SAMEFN = 0;
 609                 }
 610
 611         |  SPECIALISE_UPRAGMA DATA gtycon atypes END_UPRAGMA
 612                 {
 613                   $$ = mkdspec_uprag($3, $4, startlineno);
 614                   PREVPATT = NULL; FN = NULL; SAMEFN = 0;
 615                 }
 616
 617         |  INLINE_UPRAGMA qvark END_UPRAGMA
 618                 {
 619                   $$ = mkinline_uprag($2, startlineno);
 620                   PREVPATT = NULL; FN = NULL; SAMEFN = 0;
 621                 }
 622
 623         |  NOINLINE_UPRAGMA qvark END_UPRAGMA
 624                 {
 625                   $$ = mknoinline_uprag($2, startlineno);
 626                   PREVPATT = NULL; FN = NULL; SAMEFN = 0;
 627                 }
 628
 629         |  MAGIC_UNFOLDING_UPRAGMA qvark vark END_UPRAGMA
 630                 {
 631                   $$ = mkmagicuf_uprag($2, $3, startlineno);
 632                   PREVPATT = NULL; FN = NULL; SAMEFN = 0;
 633                 }
 634
 635         /* end of user-specified pragmas */
 636
 637         |  valdef
 638         |  /* empty */ { $$ = mknullbind(); PREVPATT = NULL; FN = NULL; SAMEFN = 0; }
 639         ;
 640
 641 qvarsk  :  qvark COMMA qvars_list               { $$ = mklcons($1,$3); }
 642         |  qvark                                { $$ = lsing($1); }
 643         ;
 644
 645 qvars_list: qvar                                { $$ = lsing($1); }
 646         |   qvars_list COMMA qvar               { $$ = lapp($1,$3); }
 647         ;
 648
 649 types_and_maybe_ids :
 650            type_and_maybe_id                            { $$ = lsing($1); }
 651         |  types_and_maybe_ids COMMA type_and_maybe_id  { $$ = lapp($1,$3); }
 652         ;
 653
 654 type_and_maybe_id :
 655            type                                 { $$ = mkvspec_ty_and_id($1,mknothing()); }
 656         |  type EQUAL qvark                     { $$ = mkvspec_ty_and_id($1,mkjust($3)); }
 657
 658
 659 /**********************************************************************
 660 *                                                                     *
 661 *                                                                     *
 662 *     Types etc                                                       *
 663 *                                                                     *
 664 *                                                                     *
 665 **********************************************************************/
 666
 667 /*  "DCOLON context => type" vs "DCOLON type" is a problem,
 668     because you can't distinguish between
 669
 670         foo :: (Baz a, Baz a)
 671         bar :: (Baz a, Baz a) => [a] -> [a] -> [a]
 672
 673     with one token of lookahead.  The HACK is to have "DCOLON ttype"
 674     [tuple type] in the first case, then check that it has the right
 675     form C a, or (C1 a, C2 b, ... Cn z) and convert it into a
 676     context.  Blaach!
 677 */
 678
 679 /* A sigtype is a rank 2 type; it can have for-alls as function args:
 680         f :: All a => (All b => ...) -> Int
 681 */
 682 sigtype : btype DARROW sigarrowtype             { $$ = mkcontext(type2context($1),$3); }
 683         | sigarrowtype
 684         ;
 685
 686 sigarrowtype : bigatype RARROW sigarrowtype     { $$ = mktfun($1,$3); }
 687              | btype RARROW sigarrowtype        { $$ = mktfun($1,$3); }
 688              | btype
 689              ;
 690
 691 /* A "big" atype can be a forall-type in brackets.  */
 692 bigatype: OPAREN btype DARROW type CPAREN       { $$ = mkcontext(type2context($2),$4); }
 693         ;
 694
 695         /* 1 S/R conflict at DARROW -> shift */
 696 ctype   : btype DARROW type                     { $$ = mkcontext(type2context($1),$3); }
 697         | type
 698         ;
 699
 700         /* 1 S/R conflict at RARROW -> shift */
 701 type    :  btype RARROW type                    { $$ = mktfun($1,$3); }
 702         |  btype                                { $$ = $1; }
 703         ;
 704
 705 btype   :  btype atype                          { $$ = mktapp($1,$2); }
 706         |  atype                                { $$ = $1; }
 707         ;
 708
 709 atype   :  gtycon                               { $$ = mktname($1); }
 710         |  tyvar                                { $$ = $1; }
 711         |  OPAREN type COMMA types CPAREN       { $$ = mkttuple(mklcons($2,$4)); }
 712         |  OBRACK type CBRACK                   { $$ = mktllist($2); }
 713         |  OPAREN type CPAREN                   { $$ = $2; }
 714         ;
 715
 716 gtycon  :  qtycon
 717         |  OPAREN RARROW CPAREN                 { $$ = creategid(ARROWGID); }
 718         |  OBRACK CBRACK                        { $$ = creategid(NILGID); }
 719         |  OPAREN CPAREN                        { $$ = creategid(UNITGID); }
 720         |  OPAREN commas CPAREN                 { $$ = creategid($2); }
 721         ;
 722
 723 atypes  :  atype                                { $$ = lsing($1); }
 724         |  atypes atype                         { $$ = lapp($1,$2); }
 725         ;
 726
 727 types   :  type                                 { $$ = lsing($1); }
 728         |  types COMMA type                     { $$ = lapp($1,$3); }
 729         ;
 730
 731 commas  : COMMA                                 { $$ = 1; }
 732         | commas COMMA                          { $$ = $1 + 1; }
 733         ;
 734
 735 /**********************************************************************
 736 *                                                                     *
 737 *                                                                     *
 738 *     Declaration stuff                                               *
 739 *                                                                     *
 740 *                                                                     *
 741 **********************************************************************/
 742
 743 /* C a b c, where a,b,c are type variables */
 744 /* C can be a class or tycon */
 745 simple_con_app: gtycon                          { $$ = mktname($1); }
 746         |  simple_con_app1                      { $$ = $1; }
 747         ;
 748
 749 simple_con_app1:  gtycon tyvar                  { $$ = mktapp(mktname($1),$2); }
 750         |  simple_con_app tyvar                 { $$ = mktapp($1, $2); }
 751         ;
 752
 753 simple_context  :  OPAREN simple_context_list CPAREN            { $$ = $2; }
 754         |  simple_con_app1                                      { $$ = lsing($1); }
 755         ;
 756
 757 simple_context_list:  simple_con_app1                           { $$ = lsing($1); }
 758         |  simple_context_list COMMA simple_con_app1            { $$ = lapp($1,$3); }
 759         ;
 760
 761 constrs :  constr                               { $$ = lsing($1); }
 762         |  constrs VBAR constr                  { $$ = lapp($1,$3); }
 763         ;
 764
 765 constr  :  constr_after_context
 766         |  btype DARROW constr_after_context    { $$ = mkconstrcxt ( type2context($1), $3 ); }
 767         ;
 768
 769 constr_after_context :
 770
 771         /* We have to parse the constructor application as a *type*, else we get
 772            into terrible ambiguity problems.  Consider the difference between
 773
 774                 data T = S Int Int Int `R` Int
 775            and
 776                 data T = S Int Int Int
 777
 778            It isn't till we get to the operator that we discover that the "S" is
 779            part of a type in the first, but part of a constructor application in the
 780            second.
 781         */
 782
 783 /* Con !Int (Tree a) */
 784            contype                              { qid tyc; list tys;
 785                                                   splittyconapp($1, &tyc, &tys);
 786                                                   $$ = mkconstrpre(tyc,tys,hsplineno); }
 787
 788 /* !Int `Con` Tree a */
 789         |  bbtype qconop bbtype                 { $$ = mkconstrinf($1,$2,$3,hsplineno); }
 790
 791 /* (::) (Tree a) Int */
 792         |  OPAREN qconsym CPAREN batypes        { $$ = mkconstrpre($2,$4,hsplineno); }
 793
 794 /* Con { op1 :: Int } */
 795         | qtycon OCURLY fields CCURLY           { $$ = mkconstrrec($1,$3,hsplineno); }
 796         | OPAREN qconsym CPAREN OCURLY fields CCURLY { $$ = mkconstrrec($2,$5,hsplineno); }
 797         ;
 798                 /* 1 S/R conflict on OCURLY -> shift */
 799
 800
 801 /* contype has to reduce to a btype unless there are !'s, so that
 802    we don't get reduce/reduce conflicts with the second production of constr.
 803    But as soon as we see a ! we must switch to using bxtype. */
 804
 805 contype : btype                                 { $$ = $1; }
 806         | bxtype                                { $$ = $1; }
 807         ;
 808
 809 /* S !Int Bool; at least one ! */
 810 bxtype  : btype wierd_atype                     { $$ = mktapp($1, $2); }
 811         | bxtype batype                         { $$ = mktapp($1, $2); }
 812         ;
 813
 814 bbtype  :  btype                                { $$ = $1; }
 815         |  wierd_atype                          { $$ = $1; }
 816         ;
 817
 818 batype  :  atype                                { $$ = $1; }
 819         |  wierd_atype                          { $$ = $1; }
 820         ;
 821
 822 /* A wierd atype is one that isn't a regular atype;
 823    it starts with a "!", or with a forall. */
 824 wierd_atype : BANG bigatype                     { $$ = mktbang( $2 ); }
 825             | BANG atype                        { $$ = mktbang( $2 ); }
 826             | bigatype
 827             ;
 828
 829 batypes :                                       { $$ = Lnil; }
 830         |  batypes batype                       { $$ = lapp($1,$2); }
 831         ;
 832
 833
 834 fields  : field                                 { $$ = lsing($1); }
 835         | fields COMMA field                    { $$ = lapp($1,$3); }
 836         ;
 837
 838 field   :  qvars_list DCOLON ctype              { $$ = mkfield($1,$3); }
 839         |  qvars_list DCOLON BANG atype         { $$ = mkfield($1,mktbang($4)); }
 840         |  qvars_list DCOLON BANG bigatype      { $$ = mkfield($1,mktbang($4)); }
 841         ;
 842
 843 constr1 :  gtycon atype                         { $$ = lsing(mkconstrnew($1,$2,hsplineno)); }
 844         ;
 845
 846
 847 dtyclses:  OPAREN dtycls_list CPAREN            { $$ = $2; }
 848         |  OPAREN CPAREN                        { $$ = Lnil; }
 849         |  qtycls                               { $$ = lsing($1); }
 850         ;
 851
 852 dtycls_list:  qtycls                            { $$ = lsing($1); }
 853         |  dtycls_list COMMA qtycls             { $$ = lapp($1,$3); }
 854         ;
 855
 856 instdefs : /* empty */                          { $$ = mknullbind(); }
 857          | instdef                              { $$ = $1; }
 858          | instdefs SEMI instdef
 859                 {
 860                   if(SAMEFN)
 861                     {
 862                       extendfn($1,$3);
 863                       $$ = $1;
 864                     }
 865                   else
 866                     $$ = mkabind($1,$3);
 867                 }
 868         ;
 869
 870 /* instdef: same as valdef, except certain user-pragmas may appear */
 871 instdef :
 872            SPECIALISE_UPRAGMA qvark DCOLON types_and_maybe_ids END_UPRAGMA
 873                 {
 874                   $$ = mkvspec_uprag($2, $4, startlineno);
 875                   PREVPATT = NULL; FN = NULL; SAMEFN = 0;
 876                 }
 877
 878         |  INLINE_UPRAGMA qvark END_UPRAGMA
 879                 {
 880                   $$ = mkinline_uprag($2, startlineno);
 881                   PREVPATT = NULL; FN = NULL; SAMEFN = 0;
 882                 }
 883
 884         |  NOINLINE_UPRAGMA qvark END_UPRAGMA
 885                 {
 886                   $$ = mknoinline_uprag($2, startlineno);
 887                   PREVPATT = NULL; FN = NULL; SAMEFN = 0;
 888                 }
 889
 890         |  MAGIC_UNFOLDING_UPRAGMA qvark vark END_UPRAGMA
 891                 {
 892                   $$ = mkmagicuf_uprag($2, $3, startlineno);
 893                   PREVPATT = NULL; FN = NULL; SAMEFN = 0;
 894                 }
 895
 896         |  valdef
 897         ;
 898
 899
 900 valdef  :  vallhs
 901
 902                 {
 903                   tree fn = function($1);
 904                   PREVPATT = $1;
 905
 906                   if(ttree(fn) == ident)
 907                     {
 908                       qid fun_id = gident((struct Sident *) fn);
 909                       checksamefn(fun_id);
 910                       FN = fun_id;
 911                     }
 912
 913                   else if (ttree(fn) == infixap)
 914                     {
 915                       qid fun_id = ginffun((struct Sinfixap *) fn);
 916                       checksamefn(fun_id);
 917                       FN = fun_id;
 918                     }
 919
 920                   else if(etags)
 921 #if 1/*etags*/
 922                     printf("%u\n",startlineno);
 923 #else
 924                     fprintf(stderr,"%u\tvaldef\n",startlineno);
 925 #endif
 926                 }
 927
 928            get_line_no
 929            valrhs
 930                 {
 931                   if ( lhs_is_patt($1) )
 932                     {
 933                       $$ = mkpbind($4, $3);
 934                       FN = NULL;
 935                       SAMEFN = 0;
 936                     }
 937                   else
 938                     $$ = mkfbind($4, $3);
 939
 940                   PREVPATT = NULL;
 941                 }
 942         ;
 943
 944 get_line_no :                                   { $$ = startlineno; }
 945             ;
 946
 947 vallhs  : patk                                  { $$ = $1; }
 948         | patk qvarop pat                       { $$ = mkinfixap($2,$1,$3); }
 949         | funlhs                                { $$ = $1; }
 950         ;
 951
 952 funlhs  :  qvark apat                           { $$ = mkap(mkident($1),$2); }
 953         |  funlhs apat                          { $$ = mkap($1,$2); }
 954         ;
 955
 956
 957 valrhs  :  valrhs1 maybe_where                  { $$ = lsing(createpat($1, $2)); }
 958         ;
 959
 960 valrhs1 :  gdrhs                                { $$ = mkpguards($1); }
 961         |  EQUAL exp                            { $$ = mkpnoguards($2); }
 962         ;
 963
 964 gdrhs   :  gd EQUAL exp                         { $$ = lsing(mkpgdexp($1,$3)); }
 965         |  gd EQUAL exp gdrhs                   { $$ = mklcons(mkpgdexp($1,$3),$4); }
 966         ;
 967
 968 maybe_where:
 969            WHERE ocurly decls ccurly            { $$ = $3; }
 970         |  WHERE vocurly decls vccurly          { $$ = $3; }
 971            /* A where containing no decls is OK */
 972         |  WHERE SEMI                           { $$ = mknullbind(); }
 973         |  /* empty */                          { $$ = mknullbind(); }
 974         ;
 975
 976 gd      :  VBAR quals                           { $$ = $2; }
 977         ;
 978
 979
 980 /**********************************************************************
 981 *                                                                     *
 982 *                                                                     *
 983 *     Expressions                                                     *
 984 *                                                                     *
 985 *                                                                     *
 986 **********************************************************************/
 987
 988 exp     :  oexp DCOLON ctype                    { $$ = mkrestr($1,$3); }
 989         |  oexp
 990         ;
 991
 992 /*
 993   Operators must be left-associative at the same precedence for
 994   precedence parsing to work.
 995 */
 996         /* 8 S/R conflicts on qop -> shift */
 997 oexp    :  oexp qop oexp %prec MINUS            { $$ = mkinfixap($2,$1,$3); }
 998         |  dexp
 999         ;
1000
1001 /*
1002   This comes here because of the funny precedence rules concerning
1003   prefix minus.
1004 */
1005 dexp    :  MINUS kexp                           { $$ = mknegate($2); }
1006         |  kexp
1007         ;
1008
1009 /*
1010   We need to factor out a leading let expression so we can set
1011   pat_check=FALSE when parsing (non let) expressions inside stmts and quals
1012 */
1013 expLno  : oexpLno DCOLON ctype                  { $$ = mkrestr($1,$3); }
1014         | oexpLno
1015         ;
1016 oexpLno :  oexpLno qop oexp %prec MINUS         { $$ = mkinfixap($2,$1,$3); }
1017         |  dexpLno
1018         ;
1019 dexpLno :  MINUS kexp                           { $$ = mknegate($2); }
1020         |  kexpLno
1021         ;
1022
1023 expL    :  oexpL DCOLON ctype                   { $$ = mkrestr($1,$3); }
1024         |  oexpL
1025         ;
1026 oexpL   :  oexpL qop oexp %prec MINUS           { $$ = mkinfixap($2,$1,$3); }
1027         |  kexpL
1028         ;
1029
1030 /*
1031   let/if/lambda/case have higher precedence than infix operators.
1032 */
1033
1034 kexp    :  kexpL
1035         |  kexpLno
1036         ;
1037
1038 /* kexpL = a let expression */
1039 kexpL   :  letdecls IN exp                      { $$ = mklet($1,$3); }
1040         ;
1041
1042 /* kexpLno = any other expression more tightly binding than operator application */
1043 kexpLno :  LAMBDA
1044                 { hsincindent();        /* push new context for FN = NULL;        */
1045                   FN = NULL;            /* not actually concerned about indenting */
1046                   $<ulong>$ = hsplineno; /* remember current line number           */
1047                 }
1048            lampats
1049                 { hsendindent();
1050                 }
1051            RARROW exp                   /* lambda abstraction */
1052                 {
1053                   $$ = mklambda($3, $6, $<ulong>2);
1054                 }
1055
1056         /* If Expression */
1057         |  IF {$<ulong>$ = hsplineno;}
1058            exp THEN exp ELSE exp                { $$ = mkife($3,$5,$7,$<ulong>2); }
1059
1060         /* Case Expression */
1061         |  CASE {$<ulong>$ = hsplineno;}
1062            exp OF caserest                      { $$ = mkcasee($3,$5,$<ulong>2); }
1063
1064         /* Do Expression */
1065         |  DO {$<ulong>$ = hsplineno;}
1066            dorest                               { $$ = mkdoe($3,$<ulong>2); }
1067
1068         /* CCALL/CASM Expression */
1069         |  CCALL ccallid cexps                  { $$ = mkccall($2,install_literal("n"),$3); }
1070         |  CCALL ccallid                        { $$ = mkccall($2,install_literal("n"),Lnil); }
1071         |  CCALL_GC ccallid cexps               { $$ = mkccall($2,install_literal("p"),$3); }
1072         |  CCALL_GC ccallid                     { $$ = mkccall($2,install_literal("p"),Lnil); }
1073         |  CASM CLITLIT cexps                   { $$ = mkccall($2,install_literal("N"),$3); }
1074         |  CASM CLITLIT                         { $$ = mkccall($2,install_literal("N"),Lnil); }
1075         |  CASM_GC CLITLIT cexps                { $$ = mkccall($2,install_literal("P"),$3); }
1076         |  CASM_GC CLITLIT                      { $$ = mkccall($2,install_literal("P"),Lnil); }
1077
1078         /* SCC Expression */
1079         |  SCC STRING exp
1080                 { if (ignoreSCC) {
1081                     if (warnSCC) {
1082                         fprintf(stderr,
1083                                 "\"%s\":%d: _scc_ (`set [profiling] cost centre') ignored\n",
1084                                 input_filename, hsplineno);
1085                     }
1086                     $$ = mkpar($3);     /* Note the mkpar().  If we don't have it, then
1087                                            (x >> _scc_ y >> z) parses as (x >> (y >> z)),
1088                                            right associated.  But the precedence reorganiser expects
1089                                            the parser to *left* associate all operators unless there
1090                                            are explicit parens.  The _scc_ acts like an explicit paren,
1091                                            so if we omit it we'd better add explicit parens instead. */
1092                   } else {
1093                     $$ = mkscc($2, $3);
1094                   }
1095                 }
1096         |  fexp
1097         ;
1098
1099 fexp    :  fexp aexp                            { $$ = mkap($1,$2); }
1100         |  aexp
1101         ;
1102
1103         /* simple expressions */
1104 aexp    :  qvar                                 { $$ = mkident($1); }
1105         |  gcon                                 { $$ = mkident($1); }
1106         |  lit_constant                         { $$ = mklit($1); }
1107         |  OPAREN exp CPAREN                    { $$ = mkpar($2); }         /* mkpar: stop infix parsing at ()'s */
1108         |  qcon OCURLY rbinds CCURLY            { $$ = mkrecord($1,$3); }   /* 1 S/R conflict on OCURLY -> shift */
1109         |  OBRACK list_exps CBRACK              { $$ = mkllist($2); }
1110         |  OPAREN exp COMMA texps CPAREN        { if (ttree($4) == tuple)
1111                                                      $$ = mktuple(mklcons($2, gtuplelist((struct Stuple *) $4)));
1112                                                   else
1113                                                      $$ = mktuple(ldub($2, $4)); }
1114
1115         /* only in expressions ... */
1116         |  aexp OCURLY rbinds1 CCURLY           { $$ = mkrupdate($1,$3); }
1117         |  OBRACK exp VBAR quals CBRACK         { $$ = mkcomprh($2,$4); }
1118         |  OBRACK exp COMMA exp DOTDOT exp CBRACK {$$= mkeenum($2,mkjust($4),mkjust($6)); }
1119         |  OBRACK exp COMMA exp DOTDOT CBRACK   { $$ = mkeenum($2,mkjust($4),mknothing()); }
1120         |  OBRACK exp DOTDOT exp CBRACK         { $$ = mkeenum($2,mknothing(),mkjust($4)); }
1121         |  OBRACK exp DOTDOT CBRACK             { $$ = mkeenum($2,mknothing(),mknothing()); }
1122         |  OPAREN oexp qop CPAREN               { $$ = mklsection($2,$3); }
1123         |  OPAREN qop1 oexp CPAREN              { $$ = mkrsection($2,$3); }
1124
1125         /* only in patterns ... */
1126         /* these add 2 S/R conflict with with  aexp . OCURLY rbinds CCURLY */
1127         |  qvar AT aexp                         { checkinpat(); $$ = mkas($1,$3); }
1128         |  LAZY aexp                            { checkinpat(); $$ = mklazyp($2); }
1129         |  WILDCARD                             { checkinpat(); $$ = mkwildp();   }
1130         ;
1131
1132         /* ccall arguments */
1133 cexps   :  cexps aexp                           { $$ = lapp($1,$2); }
1134         |  aexp                                 { $$ = lsing($1); }
1135         ;
1136
1137 caserest:  ocurly alts ccurly                   { $$ = $2; }
1138         |  vocurly alts vccurly                 { $$ = $2; }
1139
1140 dorest  :  ocurly stmts ccurly                  { checkdostmts($2); $$ = $2; }
1141         |  vocurly stmts vccurly                { checkdostmts($2); $$ = $2; }
1142         ;
1143
1144 rbinds  :  /* empty */                          { $$ = Lnil; }
1145         |  rbinds1
1146         ;
1147
1148 rbinds1 :  rbind                                { $$ = lsing($1); }
1149         |  rbinds1 COMMA rbind                  { $$ = lapp($1,$3); }
1150         ;
1151
1152 rbind   :  qvar                                 { $$ = mkrbind($1,mknothing()); }
1153         |  qvar EQUAL exp                       { $$ = mkrbind($1,mkjust($3)); }
1154         ;
1155
1156 texps   :  exp  { $$ = mkpar($1); }     /* mkpar: so we don't flatten last element in tuple */
1157         |  exp COMMA texps
1158                 { if (ttree($3) == tuple)
1159                     $$ = mktuple(mklcons($1, gtuplelist((struct Stuple *) $3)));
1160                   else if (ttree($3) == par)
1161                     $$ = mktuple(ldub($1, gpare((struct Spar *) $3)));
1162                   else
1163                     hsperror("hsparser:texps: panic");
1164                 }
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         |  OBRACK pats CBRACK                   { $$ = mkllist($2); }
1326         |  LAZY apat                            { $$ = mklazyp($2); }
1327         ;
1328
1329 lit_constant:
1330            INTEGER                              { $$ = mkinteger($1); }
1331         |  FLOAT                                { $$ = mkfloatr($1); }
1332         |  CHAR                                 { $$ = mkcharr($1); }
1333         |  STRING                               { $$ = mkstring($1); }
1334         |  CHARPRIM                             { $$ = mkcharprim($1); }
1335         |  STRINGPRIM                           { $$ = mkstringprim($1); }
1336         |  INTPRIM                              { $$ = mkintprim($1); }
1337         |  FLOATPRIM                            { $$ = mkfloatprim($1); }
1338         |  DOUBLEPRIM                           { $$ = mkdoubleprim($1); }
1339         |  CLITLIT /* yurble yurble */          { $$ = mkclitlit($1); }
1340         ;
1341
1342 lampats :  apat lampats                         { $$ = mklcons($1,$2); }
1343         |  apat                                 { $$ = lsing($1); }
1344         /* right recursion? (WDP) */
1345         ;
1346
1347 pats    :  pat COMMA pats                       { $$ = mklcons($1, $3); }
1348         |  pat                                  { $$ = lsing($1); }
1349         /* right recursion? (WDP) */
1350         ;
1351
1352 rpats   : /* empty */                           { $$ = Lnil; }
1353         | rpats1
1354         ;
1355
1356 rpats1  : rpat                                  { $$ = lsing($1); }
1357         | rpats1 COMMA rpat                     { $$ = lapp($1,$3); }
1358         ;
1359
1360 rpat    :  qvar                                 { $$ = mkrbind($1,mknothing()); }
1361         |  qvar EQUAL pat                       { $$ = mkrbind($1,mkjust($3)); }
1362         ;
1363
1364
1365 patk    :  patk qconop bpat                     { $$ = mkinfixap($2,$1,$3); }
1366         |  bpatk
1367         ;
1368
1369 bpatk   :  apatck
1370         |  conpatk
1371         |  qconk OCURLY rpats CCURLY            { $$ = mkrecord($1,$3); }
1372         |  minuskey INTEGER                     { $$ = mknegate(mklit(mkinteger($2))); }
1373         |  minuskey FLOAT                       { $$ = mknegate(mklit(mkfloatr($2))); }
1374         ;
1375
1376 conpatk :  gconk                                { $$ = mkident($1); }
1377         |  conpatk apat                         { $$ = mkap($1,$2); }
1378         ;
1379
1380 apatck  :  qvark                                { $$ = mkident($1); }
1381         |  qvark AT apat                        { $$ = mkas($1,$3); }
1382         |  lit_constant                         { $$ = mklit($1); setstartlineno(); }
1383         |  WILDCARD                             { $$ = mkwildp(); setstartlineno(); }
1384         |  oparenkey pat CPAREN                 { $$ = mkpar($2); }
1385         |  oparenkey pat COMMA pats CPAREN      { $$ = mktuple(mklcons($2,$4)); }
1386         |  obrackkey pats CBRACK                { $$ = mkllist($2); }
1387         |  lazykey apat                         { $$ = mklazyp($2); }
1388         ;
1389
1390
1391 gcon    :  qcon
1392         |  OBRACK CBRACK                        { $$ = creategid(NILGID); }
1393         |  OPAREN CPAREN                        { $$ = creategid(UNITGID); }
1394         |  OPAREN commas CPAREN                 { $$ = creategid($2); }
1395         ;
1396
1397 gconk   :  qconk
1398         |  obrackkey CBRACK                     { $$ = creategid(NILGID); }
1399         |  oparenkey CPAREN                     { $$ = creategid(UNITGID); }
1400         |  oparenkey commas CPAREN              { $$ = creategid($2); }
1401         ;
1402
1403 /**********************************************************************
1404 *                                                                     *
1405 *                                                                     *
1406 *     Keywords which record the line start                            *
1407 *                                                                     *
1408 *                                                                     *
1409 **********************************************************************/
1410
1411 importkey: IMPORT                { setstartlineno(); $$ = 0; }
1412         |  IMPORT SOURCE_UPRAGMA { setstartlineno(); $$ = 1; }
1413         ;
1414
1415 datakey :   DATA        { setstartlineno();
1416                           if(etags)
1417 #if 1/*etags*/
1418                             printf("%u\n",startlineno);
1419 #else
1420                             fprintf(stderr,"%u\tdata\n",startlineno);
1421 #endif
1422                         }
1423         ;
1424
1425 typekey :   TYPE        { setstartlineno();
1426                           if(etags)
1427 #if 1/*etags*/
1428                             printf("%u\n",startlineno);
1429 #else
1430                             fprintf(stderr,"%u\ttype\n",startlineno);
1431 #endif
1432                         }
1433         ;
1434
1435 newtypekey : NEWTYPE    { setstartlineno();
1436                           if(etags)
1437 #if 1/*etags*/
1438                             printf("%u\n",startlineno);
1439 #else
1440                             fprintf(stderr,"%u\tnewtype\n",startlineno);
1441 #endif
1442                         }
1443         ;
1444
1445 instkey :   INSTANCE    { setstartlineno();
1446 #if 1/*etags*/
1447 /* OUT:                   if(etags)
1448                             printf("%u\n",startlineno);
1449 */
1450 #else
1451                             fprintf(stderr,"%u\tinstance\n",startlineno);
1452 #endif
1453                         }
1454         ;
1455
1456 defaultkey: DEFAULT     { setstartlineno(); }
1457         ;
1458
1459 foreignkey: FOREIGN              { setstartlineno();  }
1460           ;
1461
1462 classkey:   CLASS       { setstartlineno();
1463                           if(etags)
1464 #if 1/*etags*/
1465                             printf("%u\n",startlineno);
1466 #else
1467                             fprintf(stderr,"%u\tclass\n",startlineno);
1468 #endif
1469                         }
1470         ;
1471
1472 modulekey:  MODULE      { setstartlineno();
1473                           if(etags)
1474 #if 1/*etags*/
1475                             printf("%u\n",startlineno);
1476 #else
1477                             fprintf(stderr,"%u\tmodule\n",startlineno);
1478 #endif
1479                         }
1480         ;
1481
1482 oparenkey:  OPAREN      { setstartlineno(); }
1483         ;
1484
1485 obrackkey:  OBRACK      { setstartlineno(); }
1486         ;
1487
1488 lazykey :   LAZY        { setstartlineno(); }
1489         ;
1490
1491 minuskey:   MINUS       { setstartlineno(); }
1492         ;
1493
1494
1495 /**********************************************************************
1496 *                                                                     *
1497 *                                                                     *
1498 *     Basic qualified/unqualified ids/ops                             *
1499 *                                                                     *
1500 *                                                                     *
1501 **********************************************************************/
1502
1503 qvar    :  qvarid
1504         |  OPAREN qvarsym CPAREN        { $$ = $2; }
1505         ;
1506 qcon    :  qconid
1507         |  OPAREN qconsym CPAREN        { $$ = $2; }
1508         ;
1509 qvarop  :  qvarsym
1510         |  BQUOTE qvarid BQUOTE         { $$ = $2; }
1511         ;
1512 qconop  :  qconsym
1513         |  BQUOTE qconid BQUOTE         { $$ = $2; }
1514         ;
1515 qop     :  qconop
1516         |  qvarop
1517         ;
1518
1519 /* Non "-" op, used in right sections */
1520 qop1    :  qconop
1521         |  qvarop1
1522         ;
1523
1524 /* Non "-" varop, used in right sections */
1525 qvarop1 :  QVARSYM
1526         |  varsym_nominus               { $$ = mknoqual($1); }
1527         |  BQUOTE qvarid BQUOTE         { $$ = $2; }
1528         ;
1529
1530
1531 var     :  varid
1532         |  OPAREN varsym CPAREN         { $$ = $2; }
1533         ;
1534 con     :  tycon                        /* using tycon removes conflicts */
1535         |  OPAREN CONSYM CPAREN         { $$ = $2; }
1536         ;
1537 varop   :  varsym
1538         |  BQUOTE varid BQUOTE          { $$ = $2; }
1539         ;
1540 conop   :  CONSYM
1541         |  BQUOTE CONID BQUOTE          { $$ = $2; }
1542         ;
1543 op      :  conop
1544         |  varop
1545         ;
1546
1547 qvark   :  qvarid                       { setstartlineno(); $$ = $1; }
1548         |  oparenkey qvarsym CPAREN     { $$ = $2; }
1549         ;
1550 qconk   :  qconid                       { setstartlineno(); $$ = $1; }
1551         |  oparenkey qconsym CPAREN     { $$ = $2; }
1552         ;
1553 vark    :  varid                        { setstartlineno(); $$ = $1; }
1554         |  oparenkey varsym CPAREN      { $$ = $2; }
1555         ;
1556
1557 qvarid  :  QVARID
1558         |  varid                        { $$ = mknoqual($1); }
1559         ;
1560 qvarsym :  QVARSYM
1561         |  varsym                       { $$ = mknoqual($1); }
1562         ;
1563 qconid  :  QCONID
1564         |  tycon                        { $$ = mknoqual($1); } /* using tycon removes conflicts */
1565         ;
1566 qconsym :  QCONSYM
1567         |  CONSYM                       { $$ = mknoqual($1); }
1568         ;
1569 qtycon  :  QCONID
1570         |  tycon                        { $$ = mknoqual($1); } /* using tycon removes conflicts */
1571         ;
1572 qtycls  :  QCONID
1573         |  tycon                        { $$ = mknoqual($1); } /* using tycon removes conflicts */
1574         ;
1575
1576 varsym  :  varsym_nominus
1577         |  MINUS                        { $$ = install_literal("-"); }
1578         ;
1579
1580 /* PLUS, BANG are valid varsyms */
1581 varsym_nominus : VARSYM
1582         |  PLUS                         { $$ = install_literal("+"); }
1583         |  BANG                         { $$ = install_literal("!"); }
1584         ;
1585
1586 /* AS HIDING QUALIFIED are valid varids */
1587 varid   :  VARID
1588         |  AS                           { $$ = install_literal("as"); }
1589         |  HIDING                       { $$ = install_literal("hiding"); }
1590         |  QUALIFIED                    { $$ = install_literal("qualified"); }
1591         ;
1592
1593
1594 ccallid :  VARID
1595         |  CONID
1596         ;
1597
1598 tyvar   :  varid                        { $$ = mknamedtvar(mknoqual($1)); }
1599         ;
1600 tycon   :  CONID
1601         ;
1602 modid   :  CONID
1603         ;
1604
1605 /*
1606 tyvar_list: tyvar                       { $$ = lsing($1); }
1607         |  tyvar_list COMMA tyvar       { $$ = lapp($1,$3); }
1608         ;
1609 */
1610
1611 /**********************************************************************
1612 *                                                                     *
1613 *                                                                     *
1614 *     Stuff to do with layout                                         *
1615 *                                                                     *
1616 *                                                                     *
1617 **********************************************************************/
1618
1619 ocurly  : layout OCURLY                         { hsincindent(); }
1620
1621 vocurly : layout                                { hssetindent(); }
1622         ;
1623
1624 layout  :                                       { hsindentoff(); }
1625         ;
1626
1627 ccurly  :
1628          CCURLY
1629                 {
1630                   FN = NULL; SAMEFN = 0; PREVPATT = NULL;
1631                   hsendindent();
1632                 }
1633         ;
1634
1635 vccurly :  { expect_ccurly = 1; }  vccurly1  { expect_ccurly = 0; }
1636         ;
1637
1638 vccurly1:
1639          VCCURLY
1640                 {
1641                   FN = NULL; SAMEFN = 0; PREVPATT = NULL;
1642                   hsendindent();
1643                 }
1644         | error
1645                 {
1646                   yyerrok;
1647                   FN = NULL; SAMEFN = 0; PREVPATT = NULL;
1648                   hsendindent();
1649                 }
1650         ;
1651
1652 %%
1653
1654 /**********************************************************************
1655 *                                                                     *
1656 *      Error Processing and Reporting                                 *
1657 *                                                                     *
1658 *  (This stuff is here in case we want to use Yacc macros and such.)  *
1659 *                                                                     *
1660 **********************************************************************/
1661
1662
1663 void
1664 checkinpat()
1665 {
1666   if(pat_check)
1667     hsperror("pattern syntax used in expression");
1668 }
1669
1670 /* The parser calls "hsperror" when it sees a
1671    `report this and die' error.  It sets the stage
1672    and calls "yyerror".
1673
1674    There should be no direct calls in the parser to
1675    "yyerror", except for the one from "hsperror".  Thus,
1676    the only other calls will be from the error productions
1677    introduced by yacc/bison/whatever.
1678
1679    We need to be able to recognise the from-error-production
1680    case, because we sometimes want to say, "Oh, never mind",
1681    because the layout rule kicks into action and may save
1682    the day.  [WDP]
1683 */
1684
1685 static BOOLEAN error_and_I_mean_it = FALSE;
1686
1687 void
1688 hsperror(s)
1689   char *s;
1690 {
1691     error_and_I_mean_it = TRUE;
1692     yyerror(s);
1693 }
1694
1695 extern char *yytext;
1696 extern int yyleng;
1697
1698 void
1699 yyerror(s)
1700   char *s;
1701 {
1702     /* We want to be able to distinguish 'error'-raised yyerrors
1703        from yyerrors explicitly coded by the parser hacker.
1704     */
1705     if ( expect_ccurly && ! error_and_I_mean_it ) {
1706         /*NOTHING*/;
1707
1708     } else {
1709         fprintf(stderr, "%s:%d:%d: %s on input: ",
1710           input_filename, hsplineno, hspcolno + 1, s);
1711
1712         if (yyleng == 1 && *yytext == '\0')
1713             fprintf(stderr, "<EOF>");
1714
1715         else {
1716             fputc('"', stderr);
1717             format_string(stderr, (unsigned char *) yytext, yyleng);
1718             fputc('"', stderr);
1719         }
1720         fputc('\n', stderr);
1721
1722         /* a common problem */
1723         if (strcmp(yytext, "#") == 0)
1724             fprintf(stderr, "\t(Perhaps you forgot a `-cpp' or `-fglasgow-exts' flag?)\n");
1725
1726         exit(1);
1727     }
1728 }
1729
1730 void
1731 format_string(fp, s, len)
1732   FILE *fp;
1733   unsigned char *s;
1734   int len;
1735 {
1736     while (len-- > 0) {
1737         switch (*s) {
1738         case '\0':    fputs("\\NUL", fp);   break;
1739         case '\007':  fputs("\\a", fp);     break;
1740         case '\010':  fputs("\\b", fp);     break;
1741         case '\011':  fputs("\\t", fp);     break;
1742         case '\012':  fputs("\\n", fp);     break;
1743         case '\013':  fputs("\\v", fp);     break;
1744         case '\014':  fputs("\\f", fp);     break;
1745         case '\015':  fputs("\\r", fp);     break;
1746         case '\033':  fputs("\\ESC", fp);   break;
1747         case '\034':  fputs("\\FS", fp);    break;
1748         case '\035':  fputs("\\GS", fp);    break;
1749         case '\036':  fputs("\\RS", fp);    break;
1750         case '\037':  fputs("\\US", fp);    break;
1751         case '\177':  fputs("\\DEL", fp);   break;
1752         default:
1753             if (*s >= ' ')
1754                 fputc(*s, fp);
1755             else
1756                 fprintf(fp, "\\^%c", *s + '@');
1757             break;
1758         }
1759         s++;
1760     }
1761 }