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