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
  79 BOOLEAN inpat;
  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
 165
 166 /**********************************************************************
 167 *                                                                     *
 168 *                                                                     *
 169 *     Special symbols/identifiers which need to be recognised         *
 170 *                                                                     *
 171 *                                                                     *
 172 **********************************************************************/
 173
 174 %token  MINUS           BANG            PLUS
 175 %token  AS              HIDING          QUALIFIED
 176
 177
 178 /**********************************************************************
 179 *                                                                     *
 180 *                                                                     *
 181 *     Special Symbols for the Lexer                                   *
 182 *                                                                     *
 183 *                                                                     *
 184 **********************************************************************/
 185
 186 %token  INTERFACE_UPRAGMA SPECIALISE_UPRAGMA
 187 %token  INLINE_UPRAGMA MAGIC_UNFOLDING_UPRAGMA
 188 %token  DEFOREST_UPRAGMA END_UPRAGMA
 189 %token  SOURCE_UPRAGMA
 190
 191 /**********************************************************************
 192 *                                                                     *
 193 *                                                                     *
 194 *     Precedences of the various tokens                               *
 195 *                                                                     *
 196 *                                                                     *
 197 **********************************************************************/
 198
 199
 200 %left   CASE    LET     IN
 201         IF      ELSE    LAMBDA
 202         SCC     CASM    CCALL   CASM_GC CCALL_GC
 203
 204 %left   VARSYM  CONSYM  QVARSYM QCONSYM
 205         MINUS   BQUOTE  BANG    DARROW  PLUS
 206
 207 %left   DCOLON
 208
 209 %left   SEMI    COMMA
 210
 211 %left   OCURLY  OBRACK  OPAREN
 212
 213 %left   EQUAL
 214
 215 %right  RARROW
 216
 217 /**********************************************************************
 218 *                                                                     *
 219 *                                                                     *
 220 *      Type Declarations                                              *
 221 *                                                                     *
 222 *                                                                     *
 223 **********************************************************************/
 224
 225
 226 %type <ulist>   caserest alts alt quals
 227                 dorest stmts stmt
 228                 rbinds rbinds1 rpats rpats1 list_exps list_rest
 229                 qvarsk qvars_list
 230                 constrs constr1 fields
 231                 types atypes batypes
 232                 types_and_maybe_ids
 233                 pats context context_list /* tyvar_list */
 234                 export_list enames
 235                 import_list inames
 236                 impdecls maybeimpdecls impdecl
 237                 maybefixes fixes fix ops
 238                 dtyclses dtycls_list
 239                 gdrhs gdpat valrhs
 240                 lampats cexps gd
 241
 242 %type <umaybe>  maybeexports impspec deriving
 243
 244 %type <uliteral> lit_constant
 245
 246 %type <utree>   exp oexp dexp kexp fexp aexp rbind texps
 247                 expL oexpL kexpL expLno oexpLno dexpLno kexpLno
 248                 vallhs funlhs qual leftexp
 249                 pat cpat bpat apat apatc conpat rpat
 250                         patk bpatk apatck conpatk
 251
 252
 253 %type <uid>     MINUS PLUS DARROW AS LAZY
 254                 VARID CONID VARSYM CONSYM
 255                 var con varop conop op
 256                 vark varid varsym varsym_nominus
 257                 tycon modid ccallid
 258
 259 %type <uqid>    QVARID QCONID QVARSYM QCONSYM
 260                 qvarid qconid qvarsym qconsym
 261                 qvar qcon qvarop qconop qop
 262                 qvark qconk qtycon qtycls
 263                 gcon gconk gtycon itycon qop1 qvarop1
 264                 ename iname
 265
 266 %type <ubinding>  topdecl topdecls letdecls
 267                   typed datad newtd classd instd defaultd
 268                   decl decls valdef instdef instdefs
 269                   maybe_where cbody rinst type_and_maybe_id
 270
 271 %type <upbinding> valrhs1 altrest
 272
 273 %type <uttype>    simple ctype sigtype sigarrowtype type atype bigatype btype
 274                   gtyconvars
 275                   bbtype batype bxtype wierd_atype
 276                   class tyvar contype
 277
 278 %type <uconstr>   constr constr_after_context 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 importkey
 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,$1,startlineno)); }
 385         |  importkey QUALIFIED modid impspec
 386                 { $$ = lsing(mkimport($3,1,mknothing(),$4,$1,startlineno)); }
 387         |  importkey QUALIFIED modid AS modid impspec
 388                 { $$ = lsing(mkimport($3,1,mkjust($5),$6,$1,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; FN = NULL; SAMEFN = 0; }
 479         |  datad                                { $$ = $1; FN = NULL; SAMEFN = 0; }
 480         |  newtd                                { $$ = $1; FN = NULL; SAMEFN = 0; }
 481         |  classd                               { $$ = $1; FN = NULL; SAMEFN = 0; }
 482         |  instd                                { $$ = $1; FN = NULL; SAMEFN = 0; }
 483         |  defaultd                             { $$ = $1; FN = NULL; SAMEFN = 0; }
 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 sigtype
 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 /* A sigtype is a rank 2 type; it can have for-alls as function args:
 667         f :: All a => (All b => ...) -> Int
 668 */
 669 sigtype : type DARROW sigarrowtype              { $$ = mkcontext(type2context($1),$3); }
 670         | sigarrowtype
 671         ;
 672
 673 sigarrowtype : bigatype RARROW sigarrowtype     { $$ = mktfun($1,$3); }
 674              | btype RARROW sigarrowtype        { $$ = mktfun($1,$3); }
 675              | btype
 676              ;
 677
 678 /* A "big" atype can be a forall-type in brackets.  */
 679 bigatype: OPAREN type DARROW type CPAREN        { $$ = mkcontext(type2context($2),$4); }
 680         ;
 681
 682         /* 1 S/R conflict at DARROW -> shift */
 683 ctype   : type DARROW type                      { $$ = mkcontext(type2context($1),$3); }
 684         | type
 685         ;
 686
 687         /* 1 S/R conflict at RARROW -> shift */
 688 type    :  btype RARROW type                    { $$ = mktfun($1,$3); }
 689         |  btype                                { $$ = $1; }
 690         ;
 691
 692 btype   :  btype atype                          { $$ = mktapp($1,$2); }
 693         |  atype                                { $$ = $1; }
 694         ;
 695
 696 atype   :  gtycon                               { $$ = mktname($1); }
 697         |  tyvar                                { $$ = $1; }
 698         |  OPAREN type COMMA types CPAREN       { $$ = mkttuple(mklcons($2,$4)); }
 699         |  OBRACK type CBRACK                   { $$ = mktllist($2); }
 700         |  OPAREN type CPAREN                   { $$ = $2; }
 701         ;
 702
 703 gtycon  :  qtycon
 704         |  OPAREN RARROW CPAREN                 { $$ = creategid(-2); }
 705         |  OBRACK CBRACK                        { $$ = creategid(-1); }
 706         |  OPAREN CPAREN                        { $$ = creategid(0); }
 707         |  OPAREN commas CPAREN                 { $$ = creategid($2); }
 708         ;
 709
 710 atypes  :  atype                                { $$ = lsing($1); }
 711         |  atypes atype                         { $$ = lapp($1,$2); }
 712         ;
 713
 714 types   :  type                                 { $$ = lsing($1); }
 715         |  types COMMA type                     { $$ = lapp($1,$3); }
 716         ;
 717
 718 commas  : COMMA                                 { $$ = 1; }
 719         | commas COMMA                          { $$ = $1 + 1; }
 720         ;
 721
 722 /**********************************************************************
 723 *                                                                     *
 724 *                                                                     *
 725 *     Declaration stuff                                               *
 726 *                                                                     *
 727 *                                                                     *
 728 **********************************************************************/
 729
 730 simple  :  gtycon                               { $$ = mktname($1); }
 731         |  gtyconvars                           { $$ = $1; }
 732         ;
 733
 734 gtyconvars: gtycon tyvar                        { $$ = mktapp(mktname($1),$2); }
 735         |  gtyconvars tyvar                     { $$ = mktapp($1,$2); }
 736         ;
 737
 738 context :  OPAREN context_list CPAREN           { $$ = $2; }
 739         |  class                                { $$ = lsing($1); }
 740         ;
 741
 742 context_list:  class                            { $$ = lsing($1); }
 743         |  context_list COMMA class             { $$ = lapp($1,$3); }
 744         ;
 745
 746 class   :  gtycon tyvar                         { $$ = mktapp(mktname($1),$2); }
 747         ;
 748
 749 constrs :  constr                               { $$ = lsing($1); }
 750         |  constrs VBAR constr                  { $$ = lapp($1,$3); }
 751         ;
 752
 753 constr  :  constr_after_context
 754         |  type DARROW constr_after_context     { $$ = mkconstrcxt ( type2context($1), $3 ); }
 755         ;
 756
 757 constr_after_context :
 758
 759         /* We have to parse the constructor application as a *type*, else we get
 760            into terrible ambiguity problems.  Consider the difference between
 761
 762                 data T = S Int Int Int `R` Int
 763            and
 764                 data T = S Int Int Int
 765
 766            It isn't till we get to the operator that we discover that the "S" is
 767            part of a type in the first, but part of a constructor application in the
 768            second.
 769         */
 770
 771 /* Con !Int (Tree a) */
 772            contype                              { qid tyc; list tys;
 773                                                   splittyconapp($1, &tyc, &tys);
 774                                                   $$ = mkconstrpre(tyc,tys,hsplineno); }
 775
 776 /* !Int `Con` Tree a */
 777         |  bbtype qconop bbtype                 { $$ = mkconstrinf($1,$2,$3,hsplineno); }
 778
 779 /* (::) (Tree a) Int */
 780         |  OPAREN qconsym CPAREN batypes        { $$ = mkconstrpre($2,$4,hsplineno); }
 781
 782 /* Con { op1 :: Int } */
 783         |  gtycon OCURLY fields CCURLY          { $$ = mkconstrrec($1,$3,hsplineno); }
 784                 /* 1 S/R conflict on OCURLY -> shift */
 785         ;
 786
 787
 788 /* contype has to reduce to a btype unless there are !'s, so that
 789    we don't get reduce/reduce conflicts with the second production of constr.
 790    But as soon as we see a ! we must switch to using bxtype. */
 791
 792 contype : btype                                 { $$ = $1 }
 793         | bxtype                                { $$ = $1 }
 794         ;
 795
 796 /* S !Int Bool; at least one ! */
 797 bxtype  : btype wierd_atype                     { $$ = mktapp($1, $2); }
 798         | bxtype batype                         { $$ = mktapp($1, $2); }
 799         ;
 800
 801 bbtype  :  btype                                { $$ = $1; }
 802         |  wierd_atype                          { $$ = $1; }
 803         ;
 804
 805 batype  :  atype                                { $$ = $1; }
 806         |  wierd_atype                          { $$ = $1; }
 807         ;
 808
 809 /* A wierd atype is one that isn't a regular atype;
 810    it starts with a "!", or with a forall. */
 811 wierd_atype : BANG bigatype                     { $$ = mktbang( $2 ) }
 812             | BANG atype                        { $$ = mktbang( $2 ) }
 813             | bigatype
 814             ;
 815
 816 batypes :                                       { $$ = Lnil; }
 817         |  batypes batype                       { $$ = lapp($1,$2); }
 818         ;
 819
 820
 821 fields  : field                                 { $$ = lsing($1); }
 822         | fields COMMA field                    { $$ = lapp($1,$3); }
 823         ;
 824
 825 field   :  qvars_list DCOLON ctype              { $$ = mkfield($1,$3); }
 826         |  qvars_list DCOLON BANG atype         { $$ = mkfield($1,mktbang($4)); }
 827         |  qvars_list DCOLON BANG bigatype      { $$ = mkfield($1,mktbang($4)); }
 828         ;
 829
 830 constr1 :  gtycon atype                         { $$ = lsing(mkconstrnew($1,$2,hsplineno)); }
 831         ;
 832
 833
 834 dtyclses:  OPAREN dtycls_list CPAREN            { $$ = $2; }
 835         |  OPAREN CPAREN                        { $$ = Lnil; }
 836         |  qtycls                               { $$ = lsing($1); }
 837         ;
 838
 839 dtycls_list:  qtycls                            { $$ = lsing($1); }
 840         |  dtycls_list COMMA qtycls             { $$ = lapp($1,$3); }
 841         ;
 842
 843 instdefs : /* empty */                          { $$ = mknullbind(); }
 844          | instdef                              { $$ = $1; }
 845          | instdefs SEMI instdef
 846                 {
 847                   if(SAMEFN)
 848                     {
 849                       extendfn($1,$3);
 850                       $$ = $1;
 851                     }
 852                   else
 853                     $$ = mkabind($1,$3);
 854                 }
 855         ;
 856
 857 /* instdef: same as valdef, except certain user-pragmas may appear */
 858 instdef :
 859            SPECIALISE_UPRAGMA qvark DCOLON types_and_maybe_ids END_UPRAGMA
 860                 {
 861                   $$ = mkvspec_uprag($2, $4, startlineno);
 862                   PREVPATT = NULL; FN = NULL; SAMEFN = 0;
 863                 }
 864
 865         |  INLINE_UPRAGMA qvark END_UPRAGMA
 866                 {
 867                   $$ = mkinline_uprag($2, startlineno);
 868                   PREVPATT = NULL; FN = NULL; SAMEFN = 0;
 869                 }
 870
 871         |  MAGIC_UNFOLDING_UPRAGMA qvark vark END_UPRAGMA
 872                 {
 873                   $$ = mkmagicuf_uprag($2, $3, startlineno);
 874                   PREVPATT = NULL; FN = NULL; SAMEFN = 0;
 875                 }
 876
 877         |  valdef
 878         ;
 879
 880
 881 valdef  :  vallhs
 882                 {
 883                   tree fn = function($1);
 884                   PREVPATT = $1;
 885
 886                   if(ttree(fn) == ident)
 887                     {
 888                       qid fun_id = gident((struct Sident *) fn);
 889                       checksamefn(fun_id);
 890                       FN = fun_id;
 891                     }
 892
 893                   else if (ttree(fn) == infixap)
 894                     {
 895                       qid fun_id = ginffun((struct Sinfixap *) fn);
 896                       checksamefn(fun_id);
 897                       FN = fun_id;
 898                     }
 899
 900                   else if(etags)
 901 #if 1/*etags*/
 902                     printf("%u\n",startlineno);
 903 #else
 904                     fprintf(stderr,"%u\tvaldef\n",startlineno);
 905 #endif
 906                 }
 907            valrhs
 908                 {
 909                   if ( lhs_is_patt($1) )
 910                     {
 911                       $$ = mkpbind($3, startlineno);
 912                       FN = NULL;
 913                       SAMEFN = 0;
 914                     }
 915                   else
 916                     $$ = mkfbind($3,startlineno);
 917
 918                   PREVPATT = NULL;
 919                 }
 920         ;
 921
 922 vallhs  : patk                                  { $$ = $1; }
 923         | patk qvarop pat                       { $$ = mkinfixap($2,$1,$3); }
 924         | funlhs                                { $$ = $1; }
 925         ;
 926
 927 funlhs  :  qvark apat                           { $$ = mkap(mkident($1),$2); }
 928         |  funlhs apat                          { $$ = mkap($1,$2); }
 929         ;
 930
 931
 932 valrhs  :  valrhs1 maybe_where                  { $$ = lsing(createpat($1, $2)); }
 933         ;
 934
 935 valrhs1 :  gdrhs                                { $$ = mkpguards($1); }
 936         |  EQUAL exp                            { $$ = mkpnoguards($2); }
 937         ;
 938
 939 gdrhs   :  gd EQUAL exp                         { $$ = lsing(mkpgdexp($1,$3)); }
 940         |  gd EQUAL exp gdrhs                   { $$ = mklcons(mkpgdexp($1,$3),$4); }
 941         ;
 942
 943 maybe_where:
 944            WHERE ocurly decls ccurly            { $$ = $3; }
 945         |  WHERE vocurly decls vccurly          { $$ = $3; }
 946            /* A where containing no decls is OK */
 947         |  WHERE SEMI                           { $$ = mknullbind(); }
 948         |  /* empty */                          { $$ = mknullbind(); }
 949         ;
 950
 951 gd      :  VBAR quals                           { $$ = $2; }
 952         ;
 953
 954
 955 /**********************************************************************
 956 *                                                                     *
 957 *                                                                     *
 958 *     Expressions                                                     *
 959 *                                                                     *
 960 *                                                                     *
 961 **********************************************************************/
 962
 963 exp     :  oexp DCOLON ctype                    { $$ = mkrestr($1,$3); }
 964         |  oexp
 965         ;
 966
 967 /*
 968   Operators must be left-associative at the same precedence for
 969   precedence parsing to work.
 970 */
 971         /* 8 S/R conflicts on qop -> shift */
 972 oexp    :  oexp qop oexp %prec MINUS            { $$ = mkinfixap($2,$1,$3); }
 973         |  dexp
 974         ;
 975
 976 /*
 977   This comes here because of the funny precedence rules concerning
 978   prefix minus.
 979 */
 980 dexp    :  MINUS kexp                           { $$ = mknegate($2); }
 981         |  kexp
 982         ;
 983
 984 /*
 985   We need to factor out a leading let expression so we can set
 986   inpat=TRUE when parsing (non let) expressions inside stmts and quals
 987 */
 988 expLno  :  oexpLno DCOLON ctype                 { $$ = mkrestr($1,$3); }
 989         |  oexpLno
 990         ;
 991 oexpLno :  oexpLno qop oexp %prec MINUS         { $$ = mkinfixap($2,$1,$3); }
 992         |  dexpLno
 993         ;
 994 dexpLno :  MINUS kexp                           { $$ = mknegate($2); }
 995         |  kexpLno
 996         ;
 997
 998 expL    :  oexpL DCOLON ctype                   { $$ = mkrestr($1,$3); }
 999         |  oexpL
1000         ;
1001 oexpL   :  oexpL qop oexp %prec MINUS           { $$ = mkinfixap($2,$1,$3); }
1002         |  kexpL
1003         ;
1004
1005 /*
1006   let/if/lambda/case have higher precedence than infix operators.
1007 */
1008
1009 kexp    :  kexpL
1010         |  kexpLno
1011         ;
1012
1013 /* kexpL = a let expression */
1014 kexpL   :  letdecls IN exp                      { $$ = mklet($1,$3); }
1015         ;
1016
1017 /* kexpLno = any other expression more tightly binding than operator application */
1018 kexpLno :  LAMBDA
1019                 { hsincindent();        /* push new context for FN = NULL;        */
1020                   FN = NULL;            /* not actually concerned about indenting */
1021                   $<ulong>$ = hsplineno; /* remember current line number           */
1022                 }
1023            lampats
1024                 { hsendindent();
1025                 }
1026            RARROW exp                   /* lambda abstraction */
1027                 {
1028                   $$ = mklambda($3, $6, $<ulong>2);
1029                 }
1030
1031         /* If Expression */
1032         |  IF {$<ulong>$ = hsplineno;}
1033            exp THEN exp ELSE exp                { $$ = mkife($3,$5,$7,$<ulong>2); }
1034
1035         /* Case Expression */
1036         |  CASE {$<ulong>$ = hsplineno;}
1037            exp OF caserest                      { $$ = mkcasee($3,$5,$<ulong>2); }
1038
1039         /* Do Expression */
1040         |  DO {$<ulong>$ = hsplineno;}
1041            dorest                               { $$ = mkdoe($3,$<ulong>2); }
1042
1043         /* CCALL/CASM Expression */
1044         |  CCALL ccallid cexps                  { $$ = mkccall($2,install_literal("n"),$3); }
1045         |  CCALL ccallid                        { $$ = mkccall($2,install_literal("n"),Lnil); }
1046         |  CCALL_GC ccallid cexps               { $$ = mkccall($2,install_literal("p"),$3); }
1047         |  CCALL_GC ccallid                     { $$ = mkccall($2,install_literal("p"),Lnil); }
1048         |  CASM CLITLIT cexps                   { $$ = mkccall($2,install_literal("N"),$3); }
1049         |  CASM CLITLIT                         { $$ = mkccall($2,install_literal("N"),Lnil); }
1050         |  CASM_GC CLITLIT cexps                { $$ = mkccall($2,install_literal("P"),$3); }
1051         |  CASM_GC CLITLIT                      { $$ = mkccall($2,install_literal("P"),Lnil); }
1052
1053         /* SCC Expression */
1054         |  SCC STRING exp
1055                 { if (ignoreSCC) {
1056                     $$ = $3;
1057                   } else {
1058                     $$ = mkscc($2, $3);
1059                   }
1060                 }
1061         |  fexp
1062         ;
1063
1064 fexp    :  fexp aexp                            { $$ = mkap($1,$2); }
1065         |  aexp
1066         ;
1067
1068         /* simple expressions */
1069 aexp    :  qvar                                 { $$ = mkident($1); }
1070         |  gcon                                 { $$ = mkident($1); }
1071         |  lit_constant                         { $$ = mklit($1); }
1072         |  OPAREN exp CPAREN                    { $$ = mkpar($2); }         /* mkpar: stop infix parsing at ()'s */
1073         |  qcon OCURLY rbinds CCURLY            { $$ = mkrecord($1,$3); }   /* 1 S/R conflict on OCURLY -> shift */
1074         |  OBRACK list_exps CBRACK              { $$ = mkllist($2); }
1075         |  OPAREN exp COMMA texps CPAREN        { if (ttree($4) == tuple)
1076                                                      $$ = mktuple(mklcons($2, gtuplelist((struct Stuple *) $4)));
1077                                                   else
1078                                                      $$ = mktuple(ldub($2, $4)); }
1079
1080         /* only in expressions ... */
1081         |  aexp OCURLY rbinds1 CCURLY           { $$ = mkrupdate($1,$3); }
1082         |  OBRACK exp VBAR quals CBRACK         { $$ = mkcomprh($2,$4); }
1083         |  OBRACK exp COMMA exp DOTDOT exp CBRACK {$$= mkeenum($2,mkjust($4),mkjust($6)); }
1084         |  OBRACK exp COMMA exp DOTDOT CBRACK   { $$ = mkeenum($2,mkjust($4),mknothing()); }
1085         |  OBRACK exp DOTDOT exp CBRACK         { $$ = mkeenum($2,mknothing(),mkjust($4)); }
1086         |  OBRACK exp DOTDOT CBRACK             { $$ = mkeenum($2,mknothing(),mknothing()); }
1087         |  OPAREN oexp qop CPAREN               { $$ = mklsection($2,$3); }
1088         |  OPAREN qop1 oexp CPAREN              { $$ = mkrsection($2,$3); }
1089
1090         /* only in patterns ... */
1091         /* these add 2 S/R conflict with with  aexp . OCURLY rbinds CCURLY */
1092         |  qvar AT aexp                         { checkinpat(); $$ = mkas($1,$3); }
1093         |  LAZY aexp                            { checkinpat(); $$ = mklazyp($2); }
1094         |  WILDCARD                             { checkinpat(); $$ = mkwildp();   }
1095         ;
1096
1097         /* ccall arguments */
1098 cexps   :  cexps aexp                           { $$ = lapp($1,$2); }
1099         |  aexp                                 { $$ = lsing($1); }
1100         ;
1101
1102 caserest:  ocurly alts ccurly                   { $$ = $2; }
1103         |  vocurly alts vccurly                 { $$ = $2; }
1104
1105 dorest  :  ocurly stmts ccurly                  { checkdostmts($2); $$ = $2; }
1106         |  vocurly stmts vccurly                { checkdostmts($2); $$ = $2; }
1107         ;
1108
1109 rbinds  :  /* empty */                          { $$ = Lnil; }
1110         |  rbinds1
1111         ;
1112
1113 rbinds1 :  rbind                                { $$ = lsing($1); }
1114         |  rbinds1 COMMA rbind                  { $$ = lapp($1,$3); }
1115         ;
1116
1117 rbind   :  qvar                                 { $$ = mkrbind($1,mknothing()); }
1118         |  qvar EQUAL exp                       { $$ = mkrbind($1,mkjust($3)); }
1119         ;
1120
1121 texps   :  exp  { $$ = mkpar($1); }     /* mkpar: so we don't flatten last element in tuple */
1122         |  exp COMMA texps
1123                 { if (ttree($3) == tuple)
1124                     $$ = mktuple(mklcons($1, gtuplelist((struct Stuple *) $3)));
1125                   else if (ttree($3) == par)
1126                     $$ = mktuple(ldub($1, gpare((struct Spar *) $3)));
1127                   else
1128                     hsperror("hsparser:texps: panic");
1129                 }
1130         /* right recursion? WDP */
1131         ;
1132
1133 list_exps :
1134            exp                                  { $$ = lsing($1); }
1135         |  exp COMMA exp                        { $$ = mklcons( $1, lsing($3) ); }
1136         |  exp COMMA exp COMMA list_rest        { $$ = mklcons( $1, mklcons( $3, reverse_list( $5 ))); }
1137         ;
1138
1139 /* Use left recusion for list_rest, because we sometimes get programs with
1140    very long explicit lists. */
1141 list_rest :     exp                             { $$ = lsing($1); }
1142           | list_rest COMMA exp                 { $$ = mklcons( $3, $1 ); }
1143           ;
1144
1145 /*
1146            exp                                  { $$ = lsing($1); }
1147         |  exp COMMA list_exps          { $$ = mklcons($1, $3); }
1148 */
1149         /* right recursion? (WDP)
1150
1151            It has to be this way, though, otherwise you
1152            may do the wrong thing to distinguish between...
1153
1154            [ e1 , e2 .. ]       -- an enumeration ...
1155            [ e1 , e2 , e3 ]     -- a list
1156
1157            (In fact, if you change the grammar and throw yacc/bison
1158            at it, it *will* do the wrong thing [WDP 94/06])
1159         */
1160
1161 letdecls:  LET ocurly decls ccurly              { $$ = $3 }
1162         |  LET vocurly decls vccurly            { $$ = $3 }
1163         ;
1164
1165 quals   :  qual                                 { $$ = lsing($1); }
1166         |  quals COMMA qual                     { $$ = lapp($1,$3); }
1167         ;
1168
1169 qual    :  letdecls                             { $$ = mkseqlet($1); }
1170         |  expL                                 { $$ = $1; }
1171         |  {inpat=TRUE;} expLno
1172            {inpat=FALSE;} leftexp
1173                 { if ($4 == NULL) {
1174                       expORpat(LEGIT_EXPR,$2);
1175                       $$ = mkguard($2);
1176                   } else {
1177                       expORpat(LEGIT_PATT,$2);
1178                       $$ = mkqual($2,$4);
1179                   }
1180                 }
1181         ;
1182
1183 alts    :  alt                                  { $$ = $1; }
1184         |  alts SEMI alt                        { $$ = lconc($1,$3); }
1185         ;
1186
1187 alt     :  pat { PREVPATT = $1; } altrest       { $$ = lsing($3); PREVPATT = NULL; }
1188         |  /* empty */                          { $$ = Lnil; }
1189         ;
1190
1191 altrest :  gdpat maybe_where                    { $$ = createpat(mkpguards($1), $2); }
1192         |  RARROW exp maybe_where               { $$ = createpat(mkpnoguards($2),$3); }
1193         ;
1194
1195 gdpat   :  gd RARROW exp                        { $$ = lsing(mkpgdexp($1,$3)); }
1196         |  gd RARROW exp gdpat                  { $$ = mklcons(mkpgdexp($1,$3),$4);  }
1197         ;
1198
1199 stmts   :  stmt                                 { $$ = $1; }
1200         |  stmts SEMI stmt                      { $$ = lconc($1,$3); }
1201         ;
1202
1203 stmt    :  /* empty */                          { $$ = Lnil; }
1204         |  letdecls                             { $$ = lsing(mkseqlet($1)); }
1205         |  expL                                 { $$ = lsing(mkdoexp($1,hsplineno)); }
1206         |  {inpat=TRUE;} expLno {inpat=FALSE;} leftexp
1207                 { if ($4 == NULL) {
1208                       expORpat(LEGIT_EXPR,$2);
1209                       $$ = lsing(mkdoexp($2,endlineno));
1210                   } else {
1211                       expORpat(LEGIT_PATT,$2);
1212                       $$ = lsing(mkdobind($2,$4,endlineno));
1213                   }
1214                 }
1215         ;
1216
1217 leftexp :  LARROW exp                           { $$ = $2; }
1218         |  /* empty */                          { $$ = NULL; }
1219         ;
1220
1221 /**********************************************************************
1222 *                                                                     *
1223 *                                                                     *
1224 *     Patterns                                                        *
1225 *                                                                     *
1226 *                                                                     *
1227 **********************************************************************/
1228
1229 pat     :  qvar PLUS INTEGER                    { $$ = mkplusp($1, mkinteger($3)); }
1230         |  cpat
1231         ;
1232
1233 cpat    :  cpat qconop bpat                     { $$ = mkinfixap($2,$1,$3); }
1234         |  bpat
1235         ;
1236
1237 bpat    :  apatc
1238         |  conpat
1239         |  qcon OCURLY rpats CCURLY             { $$ = mkrecord($1,$3); }
1240         |  MINUS INTEGER                        { $$ = mknegate(mklit(mkinteger($2))); }
1241         |  MINUS FLOAT                          { $$ = mknegate(mklit(mkfloatr($2))); }
1242         ;
1243
1244 conpat  :  gcon                                 { $$ = mkident($1); }
1245         |  conpat apat                          { $$ = mkap($1,$2); }
1246         ;
1247
1248 apat    :  gcon                                 { $$ = mkident($1); }
1249         |  qcon OCURLY rpats CCURLY             { $$ = mkrecord($1,$3); }
1250         |  apatc
1251         ;
1252
1253 apatc   :  qvar                                 { $$ = mkident($1); }
1254         |  qvar AT apat                         { $$ = mkas($1,$3); }
1255         |  lit_constant                         { $$ = mklit($1); }
1256         |  WILDCARD                             { $$ = mkwildp(); }
1257         |  OPAREN pat CPAREN                    { $$ = mkpar($2); }
1258         |  OPAREN pat COMMA pats CPAREN         { $$ = mktuple(mklcons($2,$4)); }
1259         |  OBRACK pats CBRACK                   { $$ = mkllist($2); }
1260         |  LAZY apat                            { $$ = mklazyp($2); }
1261         ;
1262
1263 lit_constant:
1264            INTEGER                              { $$ = mkinteger($1); }
1265         |  FLOAT                                { $$ = mkfloatr($1); }
1266         |  CHAR                                 { $$ = mkcharr($1); }
1267         |  STRING                               { $$ = mkstring($1); }
1268         |  CHARPRIM                             { $$ = mkcharprim($1); }
1269         |  STRINGPRIM                           { $$ = mkstringprim($1); }
1270         |  INTPRIM                              { $$ = mkintprim($1); }
1271         |  FLOATPRIM                            { $$ = mkfloatprim($1); }
1272         |  DOUBLEPRIM                           { $$ = mkdoubleprim($1); }
1273         |  CLITLIT /* yurble yurble */          { $$ = mkclitlit($1); }
1274         ;
1275
1276 lampats :  apat lampats                         { $$ = mklcons($1,$2); }
1277         |  apat                                 { $$ = lsing($1); }
1278         /* right recursion? (WDP) */
1279         ;
1280
1281 pats    :  pat COMMA pats                       { $$ = mklcons($1, $3); }
1282         |  pat                                  { $$ = lsing($1); }
1283         /* right recursion? (WDP) */
1284         ;
1285
1286 rpats   : /* empty */                           { $$ = Lnil; }
1287         | rpats1
1288         ;
1289
1290 rpats1  : rpat                                  { $$ = lsing($1); }
1291         | rpats1 COMMA rpat                     { $$ = lapp($1,$3); }
1292         ;
1293
1294 rpat    :  qvar                                 { $$ = mkrbind($1,mknothing()); }
1295         |  qvar EQUAL pat                       { $$ = mkrbind($1,mkjust($3)); }
1296         ;
1297
1298
1299 patk    :  patk qconop bpat                     { $$ = mkinfixap($2,$1,$3); }
1300         |  bpatk
1301         ;
1302
1303 bpatk   :  apatck
1304         |  conpatk
1305         |  qconk OCURLY rpats CCURLY            { $$ = mkrecord($1,$3); }
1306         |  minuskey INTEGER                     { $$ = mknegate(mklit(mkinteger($2))); }
1307         |  minuskey FLOAT                       { $$ = mknegate(mklit(mkfloatr($2))); }
1308         ;
1309
1310 conpatk :  gconk                                { $$ = mkident($1); }
1311         |  conpatk apat                         { $$ = mkap($1,$2); }
1312         ;
1313
1314 apatck  :  qvark                                { $$ = mkident($1); }
1315         |  qvark AT apat                        { $$ = mkas($1,$3); }
1316         |  lit_constant                         { $$ = mklit($1); setstartlineno(); }
1317         |  WILDCARD                             { $$ = mkwildp(); setstartlineno(); }
1318         |  oparenkey pat CPAREN                 { $$ = mkpar($2); }
1319         |  oparenkey pat COMMA pats CPAREN      { $$ = mktuple(mklcons($2,$4)); }
1320         |  obrackkey pats CBRACK                { $$ = mkllist($2); }
1321         |  lazykey apat                         { $$ = mklazyp($2); }
1322         ;
1323
1324
1325 gcon    :  qcon
1326         |  OBRACK CBRACK                        { $$ = creategid(-1); }
1327         |  OPAREN CPAREN                        { $$ = creategid(0); }
1328         |  OPAREN commas CPAREN                 { $$ = creategid($2); }
1329         ;
1330
1331 gconk   :  qconk
1332         |  obrackkey CBRACK                     { $$ = creategid(-1); }
1333         |  oparenkey CPAREN                     { $$ = creategid(0); }
1334         |  oparenkey commas CPAREN              { $$ = creategid($2); }
1335         ;
1336
1337 /**********************************************************************
1338 *                                                                     *
1339 *                                                                     *
1340 *     Keywords which record the line start                            *
1341 *                                                                     *
1342 *                                                                     *
1343 **********************************************************************/
1344
1345 importkey: IMPORT                { setstartlineno(); $$ = 0; }
1346         |  IMPORT SOURCE_UPRAGMA { setstartlineno(); $$ = 1; }
1347         ;
1348
1349 datakey :   DATA        { setstartlineno();
1350                           if(etags)
1351 #if 1/*etags*/
1352                             printf("%u\n",startlineno);
1353 #else
1354                             fprintf(stderr,"%u\tdata\n",startlineno);
1355 #endif
1356                         }
1357         ;
1358
1359 typekey :   TYPE        { setstartlineno();
1360                           if(etags)
1361 #if 1/*etags*/
1362                             printf("%u\n",startlineno);
1363 #else
1364                             fprintf(stderr,"%u\ttype\n",startlineno);
1365 #endif
1366                         }
1367         ;
1368
1369 newtypekey : NEWTYPE    { setstartlineno();
1370                           if(etags)
1371 #if 1/*etags*/
1372                             printf("%u\n",startlineno);
1373 #else
1374                             fprintf(stderr,"%u\tnewtype\n",startlineno);
1375 #endif
1376                         }
1377         ;
1378
1379 instkey :   INSTANCE    { setstartlineno();
1380 #if 1/*etags*/
1381 /* OUT:                   if(etags)
1382                             printf("%u\n",startlineno);
1383 */
1384 #else
1385                             fprintf(stderr,"%u\tinstance\n",startlineno);
1386 #endif
1387                         }
1388         ;
1389
1390 defaultkey: DEFAULT     { setstartlineno(); }
1391         ;
1392
1393 classkey:   CLASS       { setstartlineno();
1394                           if(etags)
1395 #if 1/*etags*/
1396                             printf("%u\n",startlineno);
1397 #else
1398                             fprintf(stderr,"%u\tclass\n",startlineno);
1399 #endif
1400                         }
1401         ;
1402
1403 modulekey:  MODULE      { setstartlineno();
1404                           if(etags)
1405 #if 1/*etags*/
1406                             printf("%u\n",startlineno);
1407 #else
1408                             fprintf(stderr,"%u\tmodule\n",startlineno);
1409 #endif
1410                         }
1411         ;
1412
1413 oparenkey:  OPAREN      { setstartlineno(); }
1414         ;
1415
1416 obrackkey:  OBRACK      { setstartlineno(); }
1417         ;
1418
1419 lazykey :   LAZY        { setstartlineno(); }
1420         ;
1421
1422 minuskey:   MINUS       { setstartlineno(); }
1423         ;
1424
1425
1426 /**********************************************************************
1427 *                                                                     *
1428 *                                                                     *
1429 *     Basic qualified/unqualified ids/ops                             *
1430 *                                                                     *
1431 *                                                                     *
1432 **********************************************************************/
1433
1434 qvar    :  qvarid
1435         |  OPAREN qvarsym CPAREN        { $$ = $2; }
1436         ;
1437 qcon    :  qconid
1438         |  OPAREN qconsym CPAREN        { $$ = $2; }
1439         ;
1440 qvarop  :  qvarsym
1441         |  BQUOTE qvarid BQUOTE         { $$ = $2; }
1442         ;
1443 qconop  :  qconsym
1444         |  BQUOTE qconid BQUOTE         { $$ = $2; }
1445         ;
1446 qop     :  qconop
1447         |  qvarop
1448         ;
1449
1450 /* Non "-" op, used in right sections */
1451 qop1    :  qconop
1452         |  qvarop1
1453         ;
1454
1455 /* Non "-" varop, used in right sections */
1456 qvarop1 :  QVARSYM
1457         |  varsym_nominus               { $$ = mknoqual($1); }
1458         |  BQUOTE qvarid BQUOTE         { $$ = $2; }
1459         ;
1460
1461
1462 var     :  varid
1463         |  OPAREN varsym CPAREN         { $$ = $2; }
1464         ;
1465 con     :  tycon                        /* using tycon removes conflicts */
1466         |  OPAREN CONSYM CPAREN         { $$ = $2; }
1467         ;
1468 varop   :  varsym
1469         |  BQUOTE varid BQUOTE          { $$ = $2; }
1470         ;
1471 conop   :  CONSYM
1472         |  BQUOTE CONID BQUOTE          { $$ = $2; }
1473         ;
1474 op      :  conop
1475         |  varop
1476         ;
1477
1478 qvark   :  qvarid                       { setstartlineno(); $$ = $1; }
1479         |  oparenkey qvarsym CPAREN     { $$ = $2; }
1480         ;
1481 qconk   :  qconid                       { setstartlineno(); $$ = $1; }
1482         |  oparenkey qconsym CPAREN     { $$ = $2; }
1483         ;
1484 vark    :  varid                        { setstartlineno(); $$ = $1; }
1485         |  oparenkey varsym CPAREN      { $$ = $2; }
1486         ;
1487
1488 qvarid  :  QVARID
1489         |  varid                        { $$ = mknoqual($1); }
1490         ;
1491 qvarsym :  QVARSYM
1492         |  varsym                       { $$ = mknoqual($1); }
1493         ;
1494 qconid  :  QCONID
1495         |  tycon                        { $$ = mknoqual($1); } /* using tycon removes conflicts */
1496         ;
1497 qconsym :  QCONSYM
1498         |  CONSYM                       { $$ = mknoqual($1); }
1499         ;
1500 qtycon  :  QCONID
1501         |  tycon                        { $$ = mknoqual($1); } /* using tycon removes conflicts */
1502         ;
1503 qtycls  :  QCONID
1504         |  tycon                        { $$ = mknoqual($1); } /* using tycon removes conflicts */
1505         ;
1506
1507 varsym  :  varsym_nominus
1508         |  MINUS                        { $$ = install_literal("-"); }
1509         ;
1510
1511 /* PLUS, BANG are valid varsyms */
1512 varsym_nominus : VARSYM
1513         |  PLUS                         { $$ = install_literal("+"); }
1514         |  BANG                         { $$ = install_literal("!"); }
1515         ;
1516
1517 /* AS HIDING QUALIFIED are valid varids */
1518 varid   :  VARID
1519         |  AS                           { $$ = install_literal("as"); }
1520         |  HIDING                       { $$ = install_literal("hiding"); }
1521         |  QUALIFIED                    { $$ = install_literal("qualified"); }
1522         ;
1523
1524
1525 ccallid :  VARID
1526         |  CONID
1527         ;
1528
1529 tyvar   :  varid                        { $$ = mknamedtvar(mknoqual($1)); }
1530         ;
1531 tycon   :  CONID
1532         ;
1533 modid   :  CONID
1534         ;
1535
1536 /*
1537 tyvar_list: tyvar                       { $$ = lsing($1); }
1538         |  tyvar_list COMMA tyvar       { $$ = lapp($1,$3); }
1539         ;
1540 */
1541
1542 /**********************************************************************
1543 *                                                                     *
1544 *                                                                     *
1545 *     Stuff to do with layout                                         *
1546 *                                                                     *
1547 *                                                                     *
1548 **********************************************************************/
1549
1550 ocurly  : layout OCURLY                         { hsincindent(); }
1551
1552 vocurly : layout                                { hssetindent(); }
1553         ;
1554
1555 layout  :                                       { hsindentoff(); }
1556         ;
1557
1558 ccurly  :
1559          CCURLY
1560                 {
1561                   FN = NULL; SAMEFN = 0; PREVPATT = NULL;
1562                   hsendindent();
1563                 }
1564         ;
1565
1566 vccurly :  { expect_ccurly = 1; }  vccurly1  { expect_ccurly = 0; }
1567         ;
1568
1569 vccurly1:
1570          VCCURLY
1571                 {
1572                   FN = NULL; SAMEFN = 0; PREVPATT = NULL;
1573                   hsendindent();
1574                 }
1575         | error
1576                 {
1577                   yyerrok;
1578                   FN = NULL; SAMEFN = 0; PREVPATT = NULL;
1579                   hsendindent();
1580                 }
1581         ;
1582
1583 %%
1584
1585 /**********************************************************************
1586 *                                                                     *
1587 *      Error Processing and Reporting                                 *
1588 *                                                                     *
1589 *  (This stuff is here in case we want to use Yacc macros and such.)  *
1590 *                                                                     *
1591 **********************************************************************/
1592
1593 void
1594 checkinpat()
1595 {
1596   if(!inpat)
1597     hsperror("pattern syntax used in expression");
1598 }
1599
1600
1601 /* The parser calls "hsperror" when it sees a
1602    `report this and die' error.  It sets the stage
1603    and calls "yyerror".
1604
1605    There should be no direct calls in the parser to
1606    "yyerror", except for the one from "hsperror".  Thus,
1607    the only other calls will be from the error productions
1608    introduced by yacc/bison/whatever.
1609
1610    We need to be able to recognise the from-error-production
1611    case, because we sometimes want to say, "Oh, never mind",
1612    because the layout rule kicks into action and may save
1613    the day.  [WDP]
1614 */
1615
1616 static BOOLEAN error_and_I_mean_it = FALSE;
1617
1618 void
1619 hsperror(s)
1620   char *s;
1621 {
1622     error_and_I_mean_it = TRUE;
1623     yyerror(s);
1624 }
1625
1626 extern char *yytext;
1627 extern int yyleng;
1628
1629 void
1630 yyerror(s)
1631   char *s;
1632 {
1633     /* We want to be able to distinguish 'error'-raised yyerrors
1634        from yyerrors explicitly coded by the parser hacker.
1635     */
1636     if (expect_ccurly && ! error_and_I_mean_it ) {
1637         /*NOTHING*/;
1638
1639     } else {
1640         fprintf(stderr, "%s:%d:%d: %s on input: ",
1641           input_filename, hsplineno, hspcolno + 1, s);
1642
1643         if (yyleng == 1 && *yytext == '\0')
1644             fprintf(stderr, "<EOF>");
1645
1646         else {
1647             fputc('"', stderr);
1648             format_string(stderr, (unsigned char *) yytext, yyleng);
1649             fputc('"', stderr);
1650         }
1651         fputc('\n', stderr);
1652
1653         /* a common problem */
1654         if (strcmp(yytext, "#") == 0)
1655             fprintf(stderr, "\t(Perhaps you forgot a `-cpp' or `-fglasgow-exts' flag?)\n");
1656
1657         exit(1);
1658     }
1659 }
1660
1661 void
1662 format_string(fp, s, len)
1663   FILE *fp;
1664   unsigned char *s;
1665   int len;
1666 {
1667     while (len-- > 0) {
1668         switch (*s) {
1669         case '\0':    fputs("\\NUL", fp);   break;
1670         case '\007':  fputs("\\a", fp);     break;
1671         case '\010':  fputs("\\b", fp);     break;
1672         case '\011':  fputs("\\t", fp);     break;
1673         case '\012':  fputs("\\n", fp);     break;
1674         case '\013':  fputs("\\v", fp);     break;
1675         case '\014':  fputs("\\f", fp);     break;
1676         case '\015':  fputs("\\r", fp);     break;
1677         case '\033':  fputs("\\ESC", fp);   break;
1678         case '\034':  fputs("\\FS", fp);    break;
1679         case '\035':  fputs("\\GS", fp);    break;
1680         case '\036':  fputs("\\RS", fp);    break;
1681         case '\037':  fputs("\\US", fp);    break;
1682         case '\177':  fputs("\\DEL", fp);   break;
1683         default:
1684             if (*s >= ' ')
1685                 fputc(*s, fp);
1686             else
1687                 fprintf(fp, "\\^%c", *s + '@');
1688             break;
1689         }
1690         s++;
1691     }
1692 }