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