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