ghc/compiler/parser/hsparser.y

   1 /**************************************************************************
   2 *   File:               hsparser.y                                        *
   3 *                                                                         *
   4 *                       Author:                 Maria M. Gutierrez        *
   5 *                       Modified by:            Kevin Hammond             *
   6 *                       Last date revised:      December 13 1991. KH.     *
   7 *                       Modification:           Haskell 1.1 Syntax.       *
   8 *                                                                         *
   9 *                                                                         *
  10 *   Description:  This file contains the LALR(1) grammar for Haskell.     *
  11 *                                                                         *
  12 *   Entry Point:  module                                                  *
  13 *                                                                         *
  14 *   Problems:     None known.                                             *
  15 *                                                                         *
  16 *                                                                         *
  17 *                 LALR(1) Syntax for Haskell 1.2                          *
  18 *                                                                         *
  19 **************************************************************************/
  20
  21
  22 %{
  23 #ifdef HSP_DEBUG
  24 # define YYDEBUG 1
  25 #endif
  26
  27 #include <stdio.h>
  28 #include <ctype.h>
  29 #include <string.h>
  30 #include "hspincl.h"
  31 #include "constants.h"
  32 #include "utils.h"
  33
  34 /**********************************************************************
  35 *                                                                     *
  36 *                                                                     *
  37 *     Imported Variables and Functions                                *
  38 *                                                                     *
  39 *                                                                     *
  40 **********************************************************************/
  41
  42 static BOOLEAN expect_ccurly = FALSE; /* Used to signal that a CCURLY could be inserted here */
  43 extern BOOLEAN etags;
  44
  45 extern char *input_filename;
  46 static char *the_module_name;
  47 static maybe module_exports;
  48
  49 extern list Lnil;
  50 extern list reverse_list();
  51 extern tree root;
  52
  53 /* For FN, PREVPATT and SAMEFN macros */
  54 extern qid      fns[];
  55 extern BOOLEAN  samefn[];
  56 extern tree     prevpatt[];
  57 extern short    icontexts;
  58
  59 /* Line Numbers */
  60 extern int hsplineno, hspcolno;
  61 extern int modulelineno;
  62 extern int startlineno;
  63 extern int endlineno;
  64
  65 /**********************************************************************
  66 *                                                                     *
  67 *                                                                     *
  68 *      Fixity and Precedence Declarations                             *
  69 *                                                                     *
  70 *                                                                     *
  71 **********************************************************************/
  72
  73 static int Fixity = 0, Precedence = 0;
  74
  75 char *ineg PROTO((char *));
  76
  77 long    source_version = 0;
  78
  79 BOOLEAN inpat;
  80 %}
  81
  82 %union {
  83         tree utree;
  84         list ulist;
  85         ttype uttype;
  86         constr uconstr;
  87         binding ubinding;
  88         pbinding upbinding;
  89         entidt uentid;
  90         id uid;
  91         qid uqid;
  92         literal uliteral;
  93         maybe umaybe;
  94         either ueither;
  95         long ulong;
  96         float ufloat;
  97         char *ustring;
  98         hstring uhstring;
  99 }
 100
 101
 102 /**********************************************************************
 103 *                                                                     *
 104 *                                                                     *
 105 *     These are lexemes.                                              *
 106 *                                                                     *
 107 *                                                                     *
 108 **********************************************************************/
 109
 110
 111 %token  VARID           CONID           QVARID          QCONID
 112         VARSYM          CONSYM          QVARSYM         QCONSYM
 113
 114 %token  INTEGER         FLOAT           CHAR            STRING
 115         CHARPRIM        STRINGPRIM      INTPRIM         FLOATPRIM
 116         DOUBLEPRIM      CLITLIT
 117
 118
 119
 120 /**********************************************************************
 121 *                                                                     *
 122 *                                                                     *
 123 *      Special Symbols                                                *
 124 *                                                                     *
 125 *                                                                     *
 126 **********************************************************************/
 127
 128 %token  OCURLY          CCURLY          VCCURLY
 129 %token  COMMA           SEMI            OBRACK          CBRACK
 130 %token  WILDCARD        BQUOTE          OPAREN          CPAREN
 131
 132
 133 /**********************************************************************
 134 *                                                                     *
 135 *                                                                     *
 136 *     Reserved Operators                                              *
 137 *                                                                     *
 138 *                                                                     *
 139 **********************************************************************/
 140
 141 %token  DOTDOT          DCOLON          EQUAL           LAMBDA
 142 %token  VBAR            RARROW          LARROW
 143 %token  AT              LAZY            DARROW
 144
 145
 146 /**********************************************************************
 147 *                                                                     *
 148 *                                                                     *
 149 *     Reserved Identifiers                                            *
 150 *                                                                     *
 151 *                                                                     *
 152 **********************************************************************/
 153
 154 %token  CASE            CLASS           DATA
 155 %token  DEFAULT         DERIVING        DO
 156 %token  ELSE            IF              IMPORT
 157 %token  IN              INFIX           INFIXL
 158 %token  INFIXR          INSTANCE        LET
 159 %token  MODULE          NEWTYPE         OF
 160 %token  THEN            TYPE            WHERE
 161
 162 %token  SCC
 163 %token  CCALL           CCALL_GC        CASM            CASM_GC
 164
 165
 166 /**********************************************************************
 167 *                                                                     *
 168 *                                                                     *
 169 *     Special symbols/identifiers which need to be recognised         *
 170 *                                                                     *
 171 *                                                                     *
 172 **********************************************************************/
 173
 174 %token  MINUS           BANG            PLUS
 175 %token  AS              HIDING          QUALIFIED
 176
 177
 178 /**********************************************************************
 179 *                                                                     *
 180 *                                                                     *
 181 *     Special Symbols for the Lexer                                   *
 182 *                                                                     *
 183 *                                                                     *
 184 **********************************************************************/
 185
 186 %token  INTERFACE_UPRAGMA SPECIALISE_UPRAGMA
 187 %token  INLINE_UPRAGMA MAGIC_UNFOLDING_UPRAGMA
 188 %token  DEFOREST_UPRAGMA END_UPRAGMA
 189
 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 context context_list /* tyvar_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>    simple ctype sigtype sigarrowtype type atype bigatype btype
 273                   gtyconvars
 274                   bbtype batype bxtype wierd_atype
 275                   class tyvar contype
 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
 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,startlineno)); }
 384         |  importkey QUALIFIED modid impspec
 385                 { $$ = lsing(mkimport($3,1,mknothing(),$4,startlineno)); }
 386         |  importkey QUALIFIED modid AS modid impspec
 387                 { $$ = lsing(mkimport($3,1,mkjust($5),$6,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(-1); }
 412         |  OPAREN CPAREN                        { $$ = creategid(0); }
 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)); }
 454         |  ops COMMA op  { $$ = lapp($1,mkfixop(mknoqual($3),infixint(Fixity),Precedence)); }
 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; }
 478         |  datad                                { $$ = $1; }
 479         |  newtd                                { $$ = $1; }
 480         |  classd                               { $$ = $1; }
 481         |  instd                                { $$ = $1; }
 482         |  defaultd                             { $$ = $1; }
 483         |  decl                                 { $$ = $1; }
 484         ;
 485
 486 typed   :  typekey simple EQUAL type            { $$ = mknbind($2,$4,startlineno); }
 487         ;
 488
 489
 490 datad   :  datakey simple EQUAL constrs deriving
 491                 { $$ = mktbind(Lnil,$2,$4,$5,startlineno); }
 492         |  datakey context DARROW simple EQUAL constrs deriving
 493                 { $$ = mktbind($2,$4,$6,$7,startlineno); }
 494         ;
 495
 496 newtd   :  newtypekey simple EQUAL constr1 deriving
 497                 { $$ = mkntbind(Lnil,$2,$4,$5,startlineno); }
 498         |  newtypekey context DARROW simple 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 context DARROW class cbody
 507                 { $$ = mkcbind($2,$4,$5,startlineno); }
 508         |  classkey class 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 context DARROW gtycon atype rinst
 518                 { $$ = mkibind($2,$4,$5,$6,startlineno); }
 519         |  instkey gtycon atype rinst
 520                 { $$ = mkibind(Lnil,$2,$3,$4,startlineno); }
 521         ;
 522
 523 rinst   :  /* empty */                                          { $$ = mknullbind(); }
 524         |  WHERE ocurly  instdefs ccurly                        { $$ = $3; }
 525         |  WHERE vocurly instdefs vccurly                       { $$ = $3; }
 526         ;
 527
 528 /*      I now allow a general type in instance declarations, relying
 529         on the type checker to reject instance decls which are ill-formed.
 530         Some (non-standard) extensions of Haskell may allow more general
 531         types than the Report syntax permits, and in any case not all things
 532         can be checked in the syntax (eg repeated type variables).
 533                 SLPJ Jan 97
 534
 535 restrict_inst : gtycon                          { $$ = mktname($1); }
 536         |  OPAREN gtyconvars CPAREN             { $$ = $2; }
 537         |  OPAREN tyvar COMMA tyvar_list CPAREN { $$ = mkttuple(mklcons($2,$4)); }
 538         |  OBRACK tyvar CBRACK                  { $$ = mktllist($2); }
 539         |  OPAREN tyvar RARROW tyvar CPAREN     { $$ = mktfun($2,$4); }
 540         ;
 541
 542 general_inst : gtycon                           { $$ = mktname($1); }
 543         |  OPAREN gtyconapp1 CPAREN             { $$ = $2; }
 544         |  OPAREN type COMMA types CPAREN       { $$ = mkttuple(mklcons($2,$4)); }
 545         |  OBRACK type CBRACK                   { $$ = mktllist($2); }
 546         |  OPAREN btype RARROW type CPAREN      { $$ = mktfun($2,$4); }
 547         ;
 548 */
 549
 550 defaultd:  defaultkey OPAREN types CPAREN       { $$ = mkdbind($3,startlineno); }
 551         |  defaultkey OPAREN CPAREN             { $$ = mkdbind(Lnil,startlineno); }
 552         ;
 553
 554 decls   : decl
 555         | decls SEMI decl
 556                 {
 557                   if(SAMEFN)
 558                     {
 559                       extendfn($1,$3);
 560                       $$ = $1;
 561                     }
 562                   else
 563                     $$ = mkabind($1,$3);
 564                 }
 565         ;
 566
 567 /*
 568     Note: if there is an iclasop_pragma here, then we must be
 569     doing a class-op in an interface -- unless the user is up
 570     to real mischief (ugly, but likely to work).
 571 */
 572
 573 decl    : qvarsk DCOLON sigtype
 574                 { $$ = mksbind($1,$3,startlineno);
 575                   PREVPATT = NULL; FN = NULL; SAMEFN = 0;
 576                 }
 577
 578         /* User-specified pragmas come in as "signatures"...
 579            They are similar in that they can appear anywhere in the module,
 580            and have to be "joined up" with their related entity.
 581
 582            Have left out the case specialising to an overloaded type.
 583            Let's get real, OK?  (WDP)
 584         */
 585         |  SPECIALISE_UPRAGMA qvark DCOLON types_and_maybe_ids END_UPRAGMA
 586                 {
 587                   $$ = mkvspec_uprag($2, $4, startlineno);
 588                   PREVPATT = NULL; FN = NULL; SAMEFN = 0;
 589                 }
 590
 591         |  SPECIALISE_UPRAGMA INSTANCE gtycon atype END_UPRAGMA
 592                 {
 593                   $$ = mkispec_uprag($3, $4, startlineno);
 594                   PREVPATT = NULL; FN = NULL; SAMEFN = 0;
 595                 }
 596
 597         |  SPECIALISE_UPRAGMA DATA gtycon atypes END_UPRAGMA
 598                 {
 599                   $$ = mkdspec_uprag($3, $4, startlineno);
 600                   PREVPATT = NULL; FN = NULL; SAMEFN = 0;
 601                 }
 602
 603         |  INLINE_UPRAGMA qvark END_UPRAGMA
 604                 {
 605                   $$ = mkinline_uprag($2, startlineno);
 606                   PREVPATT = NULL; FN = NULL; SAMEFN = 0;
 607                 }
 608
 609         |  MAGIC_UNFOLDING_UPRAGMA qvark vark END_UPRAGMA
 610                 {
 611                   $$ = mkmagicuf_uprag($2, $3, startlineno);
 612                   PREVPATT = NULL; FN = NULL; SAMEFN = 0;
 613                 }
 614
 615         |  DEFOREST_UPRAGMA qvark END_UPRAGMA
 616                 {
 617                   $$ = mkdeforest_uprag($2, startlineno);
 618                   PREVPATT = NULL; FN = NULL; SAMEFN = 0;
 619                 }
 620
 621         /* end of user-specified pragmas */
 622
 623         |  valdef
 624         |  /* empty */ { $$ = mknullbind(); PREVPATT = NULL; FN = NULL; SAMEFN = 0; }
 625         ;
 626
 627 qvarsk  :  qvark COMMA qvars_list               { $$ = mklcons($1,$3); }
 628         |  qvark                                { $$ = lsing($1); }
 629         ;
 630
 631 qvars_list: qvar                                { $$ = lsing($1); }
 632         |   qvars_list COMMA qvar               { $$ = lapp($1,$3); }
 633         ;
 634
 635 types_and_maybe_ids :
 636            type_and_maybe_id                            { $$ = lsing($1); }
 637         |  types_and_maybe_ids COMMA type_and_maybe_id  { $$ = lapp($1,$3); }
 638         ;
 639
 640 type_and_maybe_id :
 641            type                                 { $$ = mkvspec_ty_and_id($1,mknothing()); }
 642         |  type EQUAL qvark                     { $$ = mkvspec_ty_and_id($1,mkjust($3)); }
 643
 644
 645 /**********************************************************************
 646 *                                                                     *
 647 *                                                                     *
 648 *     Types etc                                                       *
 649 *                                                                     *
 650 *                                                                     *
 651 **********************************************************************/
 652
 653 /*  "DCOLON context => type" vs "DCOLON type" is a problem,
 654     because you can't distinguish between
 655
 656         foo :: (Baz a, Baz a)
 657         bar :: (Baz a, Baz a) => [a] -> [a] -> [a]
 658
 659     with one token of lookahead.  The HACK is to have "DCOLON ttype"
 660     [tuple type] in the first case, then check that it has the right
 661     form C a, or (C1 a, C2 b, ... Cn z) and convert it into a
 662     context.  Blaach!
 663 */
 664
 665 /* A sigtype is a rank 2 type; it can have for-alls as function args:
 666         f :: All a => (All b => ...) -> Int
 667 */
 668 sigtype : type DARROW sigarrowtype              { $$ = mkcontext(type2context($1),$3); }
 669         | sigarrowtype
 670         ;
 671
 672 sigarrowtype : bigatype RARROW sigarrowtype     { $$ = mktfun($1,$3); }
 673              | btype RARROW sigarrowtype        { $$ = mktfun($1,$3); }
 674              | btype
 675              ;
 676
 677 /* A "big" atype can be a forall-type in brackets.  */
 678 bigatype: OPAREN type DARROW type CPAREN        { $$ = mkcontext(type2context($2),$4); }
 679         ;
 680
 681         /* 1 S/R conflict at DARROW -> shift */
 682 ctype   : type DARROW type                      { $$ = mkcontext(type2context($1),$3); }
 683         | type
 684         ;
 685
 686         /* 1 S/R conflict at RARROW -> shift */
 687 type    :  btype RARROW type                    { $$ = mktfun($1,$3); }
 688         |  btype                                { $$ = $1; }
 689         ;
 690
 691 btype   :  btype atype                          { $$ = mktapp($1,$2); }
 692         |  atype                                { $$ = $1; }
 693         ;
 694
 695 atype   :  gtycon                               { $$ = mktname($1); }
 696         |  tyvar                                { $$ = $1; }
 697         |  OPAREN type COMMA types CPAREN       { $$ = mkttuple(mklcons($2,$4)); }
 698         |  OBRACK type CBRACK                   { $$ = mktllist($2); }
 699         |  OPAREN type CPAREN                   { $$ = $2; }
 700         ;
 701
 702 gtycon  :  qtycon
 703         |  OPAREN RARROW CPAREN                 { $$ = creategid(-2); }
 704         |  OBRACK CBRACK                        { $$ = creategid(-1); }
 705         |  OPAREN CPAREN                        { $$ = creategid(0); }
 706         |  OPAREN commas CPAREN                 { $$ = creategid($2); }
 707         ;
 708
 709 atypes  :  atype                                { $$ = lsing($1); }
 710         |  atypes atype                         { $$ = lapp($1,$2); }
 711         ;
 712
 713 types   :  type                                 { $$ = lsing($1); }
 714         |  types COMMA type                     { $$ = lapp($1,$3); }
 715         ;
 716
 717 commas  : COMMA                                 { $$ = 1; }
 718         | commas COMMA                          { $$ = $1 + 1; }
 719         ;
 720
 721 /**********************************************************************
 722 *                                                                     *
 723 *                                                                     *
 724 *     Declaration stuff                                               *
 725 *                                                                     *
 726 *                                                                     *
 727 **********************************************************************/
 728
 729 simple  :  gtycon                               { $$ = mktname($1); }
 730         |  gtyconvars                           { $$ = $1; }
 731         ;
 732
 733 gtyconvars: gtycon tyvar                        { $$ = mktapp(mktname($1),$2); }
 734         |  gtyconvars tyvar                     { $$ = mktapp($1,$2); }
 735         ;
 736
 737 context :  OPAREN context_list CPAREN           { $$ = $2; }
 738         |  class                                { $$ = lsing($1); }
 739         ;
 740
 741 context_list:  class                            { $$ = lsing($1); }
 742         |  context_list COMMA class             { $$ = lapp($1,$3); }
 743         ;
 744
 745 class   :  gtycon tyvar                         { $$ = mktapp(mktname($1),$2); }
 746         ;
 747
 748 constrs :  constr                               { $$ = lsing($1); }
 749         |  constrs VBAR constr                  { $$ = lapp($1,$3); }
 750         ;
 751
 752 constr  :  constr_after_context
 753         |  type DARROW constr_after_context     { $$ = mkconstrcxt ( type2context($1), $3 ); }
 754         ;
 755
 756 constr_after_context :
 757
 758         /* We have to parse the constructor application as a *type*, else we get
 759            into terrible ambiguity problems.  Consider the difference between
 760
 761                 data T = S Int Int Int `R` Int
 762            and
 763                 data T = S Int Int Int
 764
 765            It isn't till we get to the operator that we discover that the "S" is
 766            part of a type in the first, but part of a constructor application in the
 767            second.
 768         */
 769
 770 /* Con !Int (Tree a) */
 771            contype                              { qid tyc; list tys;
 772                                                   splittyconapp($1, &tyc, &tys);
 773                                                   $$ = mkconstrpre(tyc,tys,hsplineno); }
 774
 775 /* !Int `Con` Tree a */
 776         |  bbtype qconop bbtype                 { $$ = mkconstrinf($1,$2,$3,hsplineno); }
 777
 778 /* (::) (Tree a) Int */
 779         |  OPAREN qconsym CPAREN batypes        { $$ = mkconstrpre($2,$4,hsplineno); }
 780
 781 /* Con { op1 :: Int } */
 782         |  gtycon OCURLY fields CCURLY          { $$ = mkconstrrec($1,$3,hsplineno); }
 783                 /* 1 S/R conflict on OCURLY -> shift */
 784         ;
 785
 786
 787 /* contype has to reduce to a btype unless there are !'s, so that
 788    we don't get reduce/reduce conflicts with the second production of constr.
 789    But as soon as we see a ! we must switch to using bxtype. */
 790
 791 contype : btype                                 { $$ = $1 }
 792         | bxtype                                { $$ = $1 }
 793         ;
 794
 795 /* S !Int Bool; at least one ! */
 796 bxtype  : btype wierd_atype                     { $$ = mktapp($1, $2); }
 797         | bxtype batype                         { $$ = mktapp($1, $2); }
 798         ;
 799
 800 bbtype  :  btype                                { $$ = $1; }
 801         |  wierd_atype                          { $$ = $1; }
 802         ;
 803
 804 batype  :  atype                                { $$ = $1; }
 805         |  wierd_atype                          { $$ = $1; }
 806         ;
 807
 808 /* A wierd atype is one that isn't a regular atype;
 809    it starts with a "!", or with a forall. */
 810 wierd_atype : BANG bigatype                     { $$ = mktbang( $2 ) }
 811             | BANG atype                        { $$ = mktbang( $2 ) }
 812             | bigatype
 813             ;
 814
 815 batypes :                                       { $$ = Lnil; }
 816         |  batypes batype                       { $$ = lapp($1,$2); }
 817         ;
 818
 819
 820 fields  : field                                 { $$ = lsing($1); }
 821         | fields COMMA field                    { $$ = lapp($1,$3); }
 822         ;
 823
 824 field   :  qvars_list DCOLON ctype              { $$ = mkfield($1,$3); }
 825         |  qvars_list DCOLON BANG atype         { $$ = mkfield($1,mktbang($4)); }
 826         |  qvars_list DCOLON BANG bigatype      { $$ = mkfield($1,mktbang($4)); }
 827         ;
 828
 829 constr1 :  gtycon atype                         { $$ = lsing(mkconstrnew($1,$2,hsplineno)); }
 830         ;
 831
 832
 833 dtyclses:  OPAREN dtycls_list CPAREN            { $$ = $2; }
 834         |  OPAREN CPAREN                        { $$ = Lnil; }
 835         |  qtycls                               { $$ = lsing($1); }
 836         ;
 837
 838 dtycls_list:  qtycls                            { $$ = lsing($1); }
 839         |  dtycls_list COMMA qtycls             { $$ = lapp($1,$3); }
 840         ;
 841
 842 instdefs : /* empty */                          { $$ = mknullbind(); }
 843          | instdef                              { $$ = $1; }
 844          | instdefs SEMI instdef
 845                 {
 846                   if(SAMEFN)
 847                     {
 848                       extendfn($1,$3);
 849                       $$ = $1;
 850                     }
 851                   else
 852                     $$ = mkabind($1,$3);
 853                 }
 854         ;
 855
 856 /* instdef: same as valdef, except certain user-pragmas may appear */
 857 instdef :
 858            SPECIALISE_UPRAGMA qvark DCOLON types_and_maybe_ids END_UPRAGMA
 859                 {
 860                   $$ = mkvspec_uprag($2, $4, startlineno);
 861                   PREVPATT = NULL; FN = NULL; SAMEFN = 0;
 862                 }
 863
 864         |  INLINE_UPRAGMA qvark END_UPRAGMA
 865                 {
 866                   $$ = mkinline_uprag($2, startlineno);
 867                   PREVPATT = NULL; FN = NULL; SAMEFN = 0;
 868                 }
 869
 870         |  MAGIC_UNFOLDING_UPRAGMA qvark vark END_UPRAGMA
 871                 {
 872                   $$ = mkmagicuf_uprag($2, $3, startlineno);
 873                   PREVPATT = NULL; FN = NULL; SAMEFN = 0;
 874                 }
 875
 876         |  valdef
 877         ;
 878
 879
 880 valdef  :  vallhs
 881                 {
 882                   tree fn = function($1);
 883                   PREVPATT = $1;
 884
 885                   if(ttree(fn) == ident)
 886                     {
 887                       qid fun_id = gident((struct Sident *) fn);
 888                       checksamefn(fun_id);
 889                       FN = fun_id;
 890                     }
 891
 892                   else if (ttree(fn) == infixap)
 893                     {
 894                       qid fun_id = ginffun((struct Sinfixap *) fn);
 895                       checksamefn(fun_id);
 896                       FN = fun_id;
 897                     }
 898
 899                   else if(etags)
 900 #if 1/*etags*/
 901                     printf("%u\n",startlineno);
 902 #else
 903                     fprintf(stderr,"%u\tvaldef\n",startlineno);
 904 #endif
 905                 }
 906            valrhs
 907                 {
 908                   if ( lhs_is_patt($1) )
 909                     {
 910                       $$ = mkpbind($3, startlineno);
 911                       FN = NULL;
 912                       SAMEFN = 0;
 913                     }
 914                   else
 915                     $$ = mkfbind($3,startlineno);
 916
 917                   PREVPATT = NULL;
 918                 }
 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                     $$ = $3;
1056                   } else {
1057                     $$ = mkscc($2, $3);
1058                   }
1059                 }
1060         |  fexp
1061         ;
1062
1063 fexp    :  fexp aexp                            { $$ = mkap($1,$2); }
1064         |  aexp
1065         ;
1066
1067         /* simple expressions */
1068 aexp    :  qvar                                 { $$ = mkident($1); }
1069         |  gcon                                 { $$ = mkident($1); }
1070         |  lit_constant                         { $$ = mklit($1); }
1071         |  OPAREN exp CPAREN                    { $$ = mkpar($2); }         /* mkpar: stop infix parsing at ()'s */
1072         |  qcon OCURLY rbinds CCURLY            { $$ = mkrecord($1,$3); }   /* 1 S/R conflict on OCURLY -> shift */
1073         |  OBRACK list_exps CBRACK              { $$ = mkllist($2); }
1074         |  OPAREN exp COMMA texps CPAREN        { if (ttree($4) == tuple)
1075                                                      $$ = mktuple(mklcons($2, gtuplelist((struct Stuple *) $4)));
1076                                                   else
1077                                                      $$ = mktuple(ldub($2, $4)); }
1078
1079         /* only in expressions ... */
1080         |  aexp OCURLY rbinds1 CCURLY           { $$ = mkrupdate($1,$3); }
1081         |  OBRACK exp VBAR quals CBRACK         { $$ = mkcomprh($2,$4); }
1082         |  OBRACK exp COMMA exp DOTDOT exp CBRACK {$$= mkeenum($2,mkjust($4),mkjust($6)); }
1083         |  OBRACK exp COMMA exp DOTDOT CBRACK   { $$ = mkeenum($2,mkjust($4),mknothing()); }
1084         |  OBRACK exp DOTDOT exp CBRACK         { $$ = mkeenum($2,mknothing(),mkjust($4)); }
1085         |  OBRACK exp DOTDOT CBRACK             { $$ = mkeenum($2,mknothing(),mknothing()); }
1086         |  OPAREN oexp qop CPAREN               { $$ = mklsection($2,$3); }
1087         |  OPAREN qop1 oexp CPAREN              { $$ = mkrsection($2,$3); }
1088
1089         /* only in patterns ... */
1090         /* these add 2 S/R conflict with with  aexp . OCURLY rbinds CCURLY */
1091         |  qvar AT aexp                         { checkinpat(); $$ = mkas($1,$3); }
1092         |  LAZY aexp                            { checkinpat(); $$ = mklazyp($2); }
1093         |  WILDCARD                             { checkinpat(); $$ = mkwildp();   }
1094         ;
1095
1096         /* ccall arguments */
1097 cexps   :  cexps aexp                           { $$ = lapp($1,$2); }
1098         |  aexp                                 { $$ = lsing($1); }
1099         ;
1100
1101 caserest:  ocurly alts ccurly                   { $$ = $2; }
1102         |  vocurly alts vccurly                 { $$ = $2; }
1103
1104 dorest  :  ocurly stmts ccurly                  { checkdostmts($2); $$ = $2; }
1105         |  vocurly stmts vccurly                { checkdostmts($2); $$ = $2; }
1106         ;
1107
1108 rbinds  :  /* empty */                          { $$ = Lnil; }
1109         |  rbinds1
1110         ;
1111
1112 rbinds1 :  rbind                                { $$ = lsing($1); }
1113         |  rbinds1 COMMA rbind                  { $$ = lapp($1,$3); }
1114         ;
1115
1116 rbind   :  qvar                                 { $$ = mkrbind($1,mknothing()); }
1117         |  qvar EQUAL exp                       { $$ = mkrbind($1,mkjust($3)); }
1118         ;
1119
1120 texps   :  exp  { $$ = mkpar($1); }     /* mkpar: so we don't flatten last element in tuple */
1121         |  exp COMMA texps
1122                 { if (ttree($3) == tuple)
1123                     $$ = mktuple(mklcons($1, gtuplelist((struct Stuple *) $3)));
1124                   else if (ttree($3) == par)
1125                     $$ = mktuple(ldub($1, gpare((struct Spar *) $3)));
1126                   else
1127                     hsperror("hsparser:texps: panic");
1128                 }
1129         /* right recursion? WDP */
1130         ;
1131
1132 list_exps :
1133            exp                                  { $$ = lsing($1); }
1134         |  exp COMMA exp                        { $$ = mklcons( $1, lsing($3) ); }
1135         |  exp COMMA exp COMMA list_rest        { $$ = mklcons( $1, mklcons( $3, reverse_list( $5 ))); }
1136         ;
1137
1138 /* Use left recusion for list_rest, because we sometimes get programs with
1139    very long explicit lists. */
1140 list_rest :     exp                             { $$ = lsing($1); }
1141           | list_rest COMMA exp                 { $$ = mklcons( $3, $1 ); }
1142           ;
1143
1144 /*
1145            exp                                  { $$ = lsing($1); }
1146         |  exp COMMA list_exps          { $$ = mklcons($1, $3); }
1147 */
1148         /* right recursion? (WDP)
1149
1150            It has to be this way, though, otherwise you
1151            may do the wrong thing to distinguish between...
1152
1153            [ e1 , e2 .. ]       -- an enumeration ...
1154            [ e1 , e2 , e3 ]     -- a list
1155
1156            (In fact, if you change the grammar and throw yacc/bison
1157            at it, it *will* do the wrong thing [WDP 94/06])
1158         */
1159
1160 letdecls:  LET ocurly decls ccurly              { $$ = $3 }
1161         |  LET vocurly decls vccurly            { $$ = $3 }
1162         ;
1163
1164 quals   :  qual                                 { $$ = lsing($1); }
1165         |  quals COMMA qual                     { $$ = lapp($1,$3); }
1166         ;
1167
1168 qual    :  letdecls                             { $$ = mkseqlet($1); }
1169         |  expL                                 { $$ = $1; }
1170         |  {inpat=TRUE;} expLno
1171            {inpat=FALSE;} leftexp
1172                 { if ($4 == NULL) {
1173                       expORpat(LEGIT_EXPR,$2);
1174                       $$ = mkguard($2);
1175                   } else {
1176                       expORpat(LEGIT_PATT,$2);
1177                       $$ = mkqual($2,$4);
1178                   }
1179                 }
1180         ;
1181
1182 alts    :  alt                                  { $$ = $1; }
1183         |  alts SEMI alt                        { $$ = lconc($1,$3); }
1184         ;
1185
1186 alt     :  pat { PREVPATT = $1; } altrest       { $$ = lsing($3); PREVPATT = NULL; }
1187         |  /* empty */                          { $$ = Lnil; }
1188         ;
1189
1190 altrest :  gdpat maybe_where                    { $$ = createpat(mkpguards($1), $2); }
1191         |  RARROW exp maybe_where               { $$ = createpat(mkpnoguards($2),$3); }
1192         ;
1193
1194 gdpat   :  gd RARROW exp                        { $$ = lsing(mkpgdexp($1,$3)); }
1195         |  gd RARROW exp gdpat                  { $$ = mklcons(mkpgdexp($1,$3),$4);  }
1196         ;
1197
1198 stmts   :  stmt                                 { $$ = $1; }
1199         |  stmts SEMI stmt                      { $$ = lconc($1,$3); }
1200         ;
1201
1202 stmt    :  /* empty */                          { $$ = Lnil; }
1203         |  letdecls                             { $$ = lsing(mkseqlet($1)); }
1204         |  expL                                 { $$ = lsing(mkdoexp($1,hsplineno)); }
1205         |  {inpat=TRUE;} expLno {inpat=FALSE;} leftexp
1206                 { if ($4 == NULL) {
1207                       expORpat(LEGIT_EXPR,$2);
1208                       $$ = lsing(mkdoexp($2,endlineno));
1209                   } else {
1210                       expORpat(LEGIT_PATT,$2);
1211                       $$ = lsing(mkdobind($2,$4,endlineno));
1212                   }
1213                 }
1214         ;
1215
1216 leftexp :  LARROW exp                           { $$ = $2; }
1217         |  /* empty */                          { $$ = NULL; }
1218         ;
1219
1220 /**********************************************************************
1221 *                                                                     *
1222 *                                                                     *
1223 *     Patterns                                                        *
1224 *                                                                     *
1225 *                                                                     *
1226 **********************************************************************/
1227
1228 pat     :  qvar PLUS INTEGER                    { $$ = mkplusp($1, mkinteger($3)); }
1229         |  cpat
1230         ;
1231
1232 cpat    :  cpat qconop bpat                     { $$ = mkinfixap($2,$1,$3); }
1233         |  bpat
1234         ;
1235
1236 bpat    :  apatc
1237         |  conpat
1238         |  qcon OCURLY rpats CCURLY             { $$ = mkrecord($1,$3); }
1239         |  MINUS INTEGER                        { $$ = mknegate(mklit(mkinteger($2))); }
1240         |  MINUS FLOAT                          { $$ = mknegate(mklit(mkfloatr($2))); }
1241         ;
1242
1243 conpat  :  gcon                                 { $$ = mkident($1); }
1244         |  conpat apat                          { $$ = mkap($1,$2); }
1245         ;
1246
1247 apat    :  gcon                                 { $$ = mkident($1); }
1248         |  qcon OCURLY rpats CCURLY             { $$ = mkrecord($1,$3); }
1249         |  apatc
1250         ;
1251
1252 apatc   :  qvar                                 { $$ = mkident($1); }
1253         |  qvar AT apat                         { $$ = mkas($1,$3); }
1254         |  lit_constant                         { $$ = mklit($1); }
1255         |  WILDCARD                             { $$ = mkwildp(); }
1256         |  OPAREN pat CPAREN                    { $$ = mkpar($2); }
1257         |  OPAREN pat COMMA pats CPAREN         { $$ = mktuple(mklcons($2,$4)); }
1258         |  OBRACK pats CBRACK                   { $$ = mkllist($2); }
1259         |  LAZY apat                            { $$ = mklazyp($2); }
1260         ;
1261
1262 lit_constant:
1263            INTEGER                              { $$ = mkinteger($1); }
1264         |  FLOAT                                { $$ = mkfloatr($1); }
1265         |  CHAR                                 { $$ = mkcharr($1); }
1266         |  STRING                               { $$ = mkstring($1); }
1267         |  CHARPRIM                             { $$ = mkcharprim($1); }
1268         |  STRINGPRIM                           { $$ = mkstringprim($1); }
1269         |  INTPRIM                              { $$ = mkintprim($1); }
1270         |  FLOATPRIM                            { $$ = mkfloatprim($1); }
1271         |  DOUBLEPRIM                           { $$ = mkdoubleprim($1); }
1272         |  CLITLIT /* yurble yurble */          { $$ = mkclitlit($1); }
1273         ;
1274
1275 lampats :  apat lampats                         { $$ = mklcons($1,$2); }
1276         |  apat                                 { $$ = lsing($1); }
1277         /* right recursion? (WDP) */
1278         ;
1279
1280 pats    :  pat COMMA pats                       { $$ = mklcons($1, $3); }
1281         |  pat                                  { $$ = lsing($1); }
1282         /* right recursion? (WDP) */
1283         ;
1284
1285 rpats   : /* empty */                           { $$ = Lnil; }
1286         | rpats1
1287         ;
1288
1289 rpats1  : rpat                                  { $$ = lsing($1); }
1290         | rpats1 COMMA rpat                     { $$ = lapp($1,$3); }
1291         ;
1292
1293 rpat    :  qvar                                 { $$ = mkrbind($1,mknothing()); }
1294         |  qvar EQUAL pat                       { $$ = mkrbind($1,mkjust($3)); }
1295         ;
1296
1297
1298 patk    :  patk qconop bpat                     { $$ = mkinfixap($2,$1,$3); }
1299         |  bpatk
1300         ;
1301
1302 bpatk   :  apatck
1303         |  conpatk
1304         |  qconk OCURLY rpats CCURLY            { $$ = mkrecord($1,$3); }
1305         |  minuskey INTEGER                     { $$ = mknegate(mklit(mkinteger($2))); }
1306         |  minuskey FLOAT                       { $$ = mknegate(mklit(mkfloatr($2))); }
1307         ;
1308
1309 conpatk :  gconk                                { $$ = mkident($1); }
1310         |  conpatk apat                         { $$ = mkap($1,$2); }
1311         ;
1312
1313 apatck  :  qvark                                { $$ = mkident($1); }
1314         |  qvark AT apat                        { $$ = mkas($1,$3); }
1315         |  lit_constant                         { $$ = mklit($1); setstartlineno(); }
1316         |  WILDCARD                             { $$ = mkwildp(); setstartlineno(); }
1317         |  oparenkey pat CPAREN                 { $$ = mkpar($2); }
1318         |  oparenkey pat COMMA pats CPAREN      { $$ = mktuple(mklcons($2,$4)); }
1319         |  obrackkey pats CBRACK                { $$ = mkllist($2); }
1320         |  lazykey apat                         { $$ = mklazyp($2); }
1321         ;
1322
1323
1324 gcon    :  qcon
1325         |  OBRACK CBRACK                        { $$ = creategid(-1); }
1326         |  OPAREN CPAREN                        { $$ = creategid(0); }
1327         |  OPAREN commas CPAREN                 { $$ = creategid($2); }
1328         ;
1329
1330 gconk   :  qconk
1331         |  obrackkey CBRACK                     { $$ = creategid(-1); }
1332         |  oparenkey CPAREN                     { $$ = creategid(0); }
1333         |  oparenkey commas CPAREN              { $$ = creategid($2); }
1334         ;
1335
1336 /**********************************************************************
1337 *                                                                     *
1338 *                                                                     *
1339 *     Keywords which record the line start                            *
1340 *                                                                     *
1341 *                                                                     *
1342 **********************************************************************/
1343
1344 importkey:  IMPORT      { setstartlineno(); }
1345         ;
1346
1347 datakey :   DATA        { setstartlineno();
1348                           if(etags)
1349 #if 1/*etags*/
1350                             printf("%u\n",startlineno);
1351 #else
1352                             fprintf(stderr,"%u\tdata\n",startlineno);
1353 #endif
1354                         }
1355         ;
1356
1357 typekey :   TYPE        { setstartlineno();
1358                           if(etags)
1359 #if 1/*etags*/
1360                             printf("%u\n",startlineno);
1361 #else
1362                             fprintf(stderr,"%u\ttype\n",startlineno);
1363 #endif
1364                         }
1365         ;
1366
1367 newtypekey : NEWTYPE    { setstartlineno();
1368                           if(etags)
1369 #if 1/*etags*/
1370                             printf("%u\n",startlineno);
1371 #else
1372                             fprintf(stderr,"%u\tnewtype\n",startlineno);
1373 #endif
1374                         }
1375         ;
1376
1377 instkey :   INSTANCE    { setstartlineno();
1378 #if 1/*etags*/
1379 /* OUT:                   if(etags)
1380                             printf("%u\n",startlineno);
1381 */
1382 #else
1383                             fprintf(stderr,"%u\tinstance\n",startlineno);
1384 #endif
1385                         }
1386         ;
1387
1388 defaultkey: DEFAULT     { setstartlineno(); }
1389         ;
1390
1391 classkey:   CLASS       { setstartlineno();
1392                           if(etags)
1393 #if 1/*etags*/
1394                             printf("%u\n",startlineno);
1395 #else
1396                             fprintf(stderr,"%u\tclass\n",startlineno);
1397 #endif
1398                         }
1399         ;
1400
1401 modulekey:  MODULE      { setstartlineno();
1402                           if(etags)
1403 #if 1/*etags*/
1404                             printf("%u\n",startlineno);
1405 #else
1406                             fprintf(stderr,"%u\tmodule\n",startlineno);
1407 #endif
1408                         }
1409         ;
1410
1411 oparenkey:  OPAREN      { setstartlineno(); }
1412         ;
1413
1414 obrackkey:  OBRACK      { setstartlineno(); }
1415         ;
1416
1417 lazykey :   LAZY        { setstartlineno(); }
1418         ;
1419
1420 minuskey:   MINUS       { setstartlineno(); }
1421         ;
1422
1423
1424 /**********************************************************************
1425 *                                                                     *
1426 *                                                                     *
1427 *     Basic qualified/unqualified ids/ops                             *
1428 *                                                                     *
1429 *                                                                     *
1430 **********************************************************************/
1431
1432 qvar    :  qvarid
1433         |  OPAREN qvarsym CPAREN        { $$ = $2; }
1434         ;
1435 qcon    :  qconid
1436         |  OPAREN qconsym CPAREN        { $$ = $2; }
1437         ;
1438 qvarop  :  qvarsym
1439         |  BQUOTE qvarid BQUOTE         { $$ = $2; }
1440         ;
1441 qconop  :  qconsym
1442         |  BQUOTE qconid BQUOTE         { $$ = $2; }
1443         ;
1444 qop     :  qconop
1445         |  qvarop
1446         ;
1447
1448 /* Non "-" op, used in right sections */
1449 qop1    :  qconop
1450         |  qvarop1
1451         ;
1452
1453 /* Non "-" varop, used in right sections */
1454 qvarop1 :  QVARSYM
1455         |  varsym_nominus               { $$ = mknoqual($1); }
1456         |  BQUOTE qvarid BQUOTE         { $$ = $2; }
1457         ;
1458
1459
1460 var     :  varid
1461         |  OPAREN varsym CPAREN         { $$ = $2; }
1462         ;
1463 con     :  tycon                        /* using tycon removes conflicts */
1464         |  OPAREN CONSYM CPAREN         { $$ = $2; }
1465         ;
1466 varop   :  varsym
1467         |  BQUOTE varid BQUOTE          { $$ = $2; }
1468         ;
1469 conop   :  CONSYM
1470         |  BQUOTE CONID BQUOTE          { $$ = $2; }
1471         ;
1472 op      :  conop
1473         |  varop
1474         ;
1475
1476 qvark   :  qvarid                       { setstartlineno(); $$ = $1; }
1477         |  oparenkey qvarsym CPAREN     { $$ = $2; }
1478         ;
1479 qconk   :  qconid                       { setstartlineno(); $$ = $1; }
1480         |  oparenkey qconsym CPAREN     { $$ = $2; }
1481         ;
1482 vark    :  varid                        { setstartlineno(); $$ = $1; }
1483         |  oparenkey varsym CPAREN      { $$ = $2; }
1484         ;
1485
1486 qvarid  :  QVARID
1487         |  varid                        { $$ = mknoqual($1); }
1488         ;
1489 qvarsym :  QVARSYM
1490         |  varsym                       { $$ = mknoqual($1); }
1491         ;
1492 qconid  :  QCONID
1493         |  tycon                        { $$ = mknoqual($1); } /* using tycon removes conflicts */
1494         ;
1495 qconsym :  QCONSYM
1496         |  CONSYM                       { $$ = mknoqual($1); }
1497         ;
1498 qtycon  :  QCONID
1499         |  tycon                        { $$ = mknoqual($1); } /* using tycon removes conflicts */
1500         ;
1501 qtycls  :  QCONID
1502         |  tycon                        { $$ = mknoqual($1); } /* using tycon removes conflicts */
1503         ;
1504
1505 varsym  :  varsym_nominus
1506         |  MINUS                        { $$ = install_literal("-"); }
1507         ;
1508
1509 /* PLUS, BANG are valid varsyms */
1510 varsym_nominus : VARSYM
1511         |  PLUS                         { $$ = install_literal("+"); }
1512         |  BANG                         { $$ = install_literal("!"); }
1513         ;
1514
1515 /* AS HIDING QUALIFIED are valid varids */
1516 varid   :  VARID
1517         |  AS                           { $$ = install_literal("as"); }
1518         |  HIDING                       { $$ = install_literal("hiding"); }
1519         |  QUALIFIED                    { $$ = install_literal("qualified"); }
1520         ;
1521
1522
1523 ccallid :  VARID
1524         |  CONID
1525         ;
1526
1527 tyvar   :  varid                        { $$ = mknamedtvar(mknoqual($1)); }
1528         ;
1529 tycon   :  CONID
1530         ;
1531 modid   :  CONID
1532         ;
1533
1534 /*
1535 tyvar_list: tyvar                       { $$ = lsing($1); }
1536         |  tyvar_list COMMA tyvar       { $$ = lapp($1,$3); }
1537         ;
1538 */
1539
1540 /**********************************************************************
1541 *                                                                     *
1542 *                                                                     *
1543 *     Stuff to do with layout                                         *
1544 *                                                                     *
1545 *                                                                     *
1546 **********************************************************************/
1547
1548 ocurly  : layout OCURLY                         { hsincindent(); }
1549
1550 vocurly : layout                                { hssetindent(); }
1551         ;
1552
1553 layout  :                                       { hsindentoff(); }
1554         ;
1555
1556 ccurly  :
1557          CCURLY
1558                 {
1559                   FN = NULL; SAMEFN = 0; PREVPATT = NULL;
1560                   hsendindent();
1561                 }
1562         ;
1563
1564 vccurly :  { expect_ccurly = 1; }  vccurly1  { expect_ccurly = 0; }
1565         ;
1566
1567 vccurly1:
1568          VCCURLY
1569                 {
1570                   FN = NULL; SAMEFN = 0; PREVPATT = NULL;
1571                   hsendindent();
1572                 }
1573         | error
1574                 {
1575                   yyerrok;
1576                   FN = NULL; SAMEFN = 0; PREVPATT = NULL;
1577                   hsendindent();
1578                 }
1579         ;
1580
1581 %%
1582
1583 /**********************************************************************
1584 *                                                                     *
1585 *      Error Processing and Reporting                                 *
1586 *                                                                     *
1587 *  (This stuff is here in case we want to use Yacc macros and such.)  *
1588 *                                                                     *
1589 **********************************************************************/
1590
1591 void
1592 checkinpat()
1593 {
1594   if(!inpat)
1595     hsperror("pattern syntax used in expression");
1596 }
1597
1598
1599 /* The parser calls "hsperror" when it sees a
1600    `report this and die' error.  It sets the stage
1601    and calls "yyerror".
1602
1603    There should be no direct calls in the parser to
1604    "yyerror", except for the one from "hsperror".  Thus,
1605    the only other calls will be from the error productions
1606    introduced by yacc/bison/whatever.
1607
1608    We need to be able to recognise the from-error-production
1609    case, because we sometimes want to say, "Oh, never mind",
1610    because the layout rule kicks into action and may save
1611    the day.  [WDP]
1612 */
1613
1614 static BOOLEAN error_and_I_mean_it = FALSE;
1615
1616 void
1617 hsperror(s)
1618   char *s;
1619 {
1620     error_and_I_mean_it = TRUE;
1621     yyerror(s);
1622 }
1623
1624 extern char *yytext;
1625 extern int yyleng;
1626
1627 void
1628 yyerror(s)
1629   char *s;
1630 {
1631     /* We want to be able to distinguish 'error'-raised yyerrors
1632        from yyerrors explicitly coded by the parser hacker.
1633     */
1634     if (expect_ccurly && ! error_and_I_mean_it ) {
1635         /*NOTHING*/;
1636
1637     } else {
1638         fprintf(stderr, "%s:%d:%d: %s on input: ",
1639           input_filename, hsplineno, hspcolno + 1, s);
1640
1641         if (yyleng == 1 && *yytext == '\0')
1642             fprintf(stderr, "<EOF>");
1643
1644         else {
1645             fputc('"', stderr);
1646             format_string(stderr, (unsigned char *) yytext, yyleng);
1647             fputc('"', stderr);
1648         }
1649         fputc('\n', stderr);
1650
1651         /* a common problem */
1652         if (strcmp(yytext, "#") == 0)
1653             fprintf(stderr, "\t(Perhaps you forgot a `-cpp' or `-fglasgow-exts' flag?)\n");
1654
1655         exit(1);
1656     }
1657 }
1658
1659 void
1660 format_string(fp, s, len)
1661   FILE *fp;
1662   unsigned char *s;
1663   int len;
1664 {
1665     while (len-- > 0) {
1666         switch (*s) {
1667         case '\0':    fputs("\\NUL", fp);   break;
1668         case '\007':  fputs("\\a", fp);     break;
1669         case '\010':  fputs("\\b", fp);     break;
1670         case '\011':  fputs("\\t", fp);     break;
1671         case '\012':  fputs("\\n", fp);     break;
1672         case '\013':  fputs("\\v", fp);     break;
1673         case '\014':  fputs("\\f", fp);     break;
1674         case '\015':  fputs("\\r", fp);     break;
1675         case '\033':  fputs("\\ESC", fp);   break;
1676         case '\034':  fputs("\\FS", fp);    break;
1677         case '\035':  fputs("\\GS", fp);    break;
1678         case '\036':  fputs("\\RS", fp);    break;
1679         case '\037':  fputs("\\US", fp);    break;
1680         case '\177':  fputs("\\DEL", fp);   break;
1681         default:
1682             if (*s >= ' ')
1683                 fputc(*s, fp);
1684             else
1685                 fprintf(fp, "\\^%c", *s + '@');
1686             break;
1687         }
1688         s++;
1689     }
1690 }