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