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   :  letdecls IN exp                      { $$ = mklet($1,$3); }
1013         ;
1014
1015 kexpLno :  LAMBDA
1016                 { hsincindent();        /* push new context for FN = NULL;        */
1017                   FN = NULL;            /* not actually concerned about indenting */
1018                   $<ulong>$ = hsplineno; /* remember current line number           */
1019                 }
1020            lampats
1021                 { hsendindent();
1022                 }
1023            RARROW exp                   /* lambda abstraction */
1024                 {
1025                   $$ = mklambda($3, $6, $<ulong>2);
1026                 }
1027
1028         /* If Expression */
1029         |  IF {$<ulong>$ = hsplineno;}
1030            exp THEN exp ELSE exp                { $$ = mkife($3,$5,$7,$<ulong>2); }
1031
1032         /* Case Expression */
1033         |  CASE {$<ulong>$ = hsplineno;}
1034            exp OF caserest                      { $$ = mkcasee($3,$5,$<ulong>2); }
1035
1036         /* Do Expression */
1037         |  DO {$<ulong>$ = hsplineno;}
1038            dorest                               { $$ = mkdoe($3,$<ulong>2); }
1039
1040         /* CCALL/CASM Expression */
1041         |  CCALL ccallid cexps                  { $$ = mkccall($2,install_literal("n"),$3); }
1042         |  CCALL ccallid                        { $$ = mkccall($2,install_literal("n"),Lnil); }
1043         |  CCALL_GC ccallid cexps               { $$ = mkccall($2,install_literal("p"),$3); }
1044         |  CCALL_GC ccallid                     { $$ = mkccall($2,install_literal("p"),Lnil); }
1045         |  CASM CLITLIT cexps                   { $$ = mkccall($2,install_literal("N"),$3); }
1046         |  CASM CLITLIT                         { $$ = mkccall($2,install_literal("N"),Lnil); }
1047         |  CASM_GC CLITLIT cexps                { $$ = mkccall($2,install_literal("P"),$3); }
1048         |  CASM_GC CLITLIT                      { $$ = mkccall($2,install_literal("P"),Lnil); }
1049
1050         /* SCC Expression */
1051         |  SCC STRING exp
1052                 { if (ignoreSCC) {
1053                     $$ = $3;
1054                   } else {
1055                     $$ = mkscc($2, $3);
1056                   }
1057                 }
1058         |  fexp
1059         ;
1060
1061 fexp    :  fexp aexp                            { $$ = mkap($1,$2); }
1062         |  aexp
1063         ;
1064
1065         /* simple expressions */
1066 aexp    :  qvar                                 { $$ = mkident($1); }
1067         |  gcon                                 { $$ = mkident($1); }
1068         |  lit_constant                         { $$ = mklit($1); }
1069         |  OPAREN exp CPAREN                    { $$ = mkpar($2); }         /* mkpar: stop infix parsing at ()'s */
1070         |  qcon OCURLY rbinds CCURLY            { $$ = mkrecord($1,$3); }   /* 1 S/R conflict on OCURLY -> shift */
1071         |  OBRACK list_exps CBRACK              { $$ = mkllist($2); }
1072         |  OPAREN exp COMMA texps CPAREN        { if (ttree($4) == tuple)
1073                                                      $$ = mktuple(mklcons($2, gtuplelist((struct Stuple *) $4)));
1074                                                   else
1075                                                      $$ = mktuple(ldub($2, $4)); }
1076
1077         /* only in expressions ... */
1078         |  aexp OCURLY rbinds1 CCURLY           { $$ = mkrupdate($1,$3); }
1079         |  OBRACK exp VBAR quals CBRACK         { $$ = mkcomprh($2,$4); }
1080         |  OBRACK exp COMMA exp DOTDOT exp CBRACK {$$= mkeenum($2,mkjust($4),mkjust($6)); }
1081         |  OBRACK exp COMMA exp DOTDOT CBRACK   { $$ = mkeenum($2,mkjust($4),mknothing()); }
1082         |  OBRACK exp DOTDOT exp CBRACK         { $$ = mkeenum($2,mknothing(),mkjust($4)); }
1083         |  OBRACK exp DOTDOT CBRACK             { $$ = mkeenum($2,mknothing(),mknothing()); }
1084         |  OPAREN oexp qop CPAREN               { $$ = mklsection($2,$3); }
1085         |  OPAREN qop1 oexp CPAREN              { $$ = mkrsection($2,$3); }
1086
1087         /* only in patterns ... */
1088         /* these add 2 S/R conflict with with  aexp . OCURLY rbinds CCURLY */
1089         |  qvar AT aexp                         { checkinpat(); $$ = mkas($1,$3); }
1090         |  LAZY aexp                            { checkinpat(); $$ = mklazyp($2); }
1091         |  WILDCARD                             { checkinpat(); $$ = mkwildp();   }
1092         ;
1093
1094         /* ccall arguments */
1095 cexps   :  cexps aexp                           { $$ = lapp($1,$2); }
1096         |  aexp                                 { $$ = lsing($1); }
1097         ;
1098
1099 caserest:  ocurly alts ccurly                   { $$ = $2; }
1100         |  vocurly alts vccurly                 { $$ = $2; }
1101
1102 dorest  :  ocurly stmts ccurly                  { checkdostmts($2); $$ = $2; }
1103         |  vocurly stmts vccurly                { checkdostmts($2); $$ = $2; }
1104         ;
1105
1106 rbinds  :  /* empty */                          { $$ = Lnil; }
1107         |  rbinds1
1108         ;
1109
1110 rbinds1 :  rbind                                { $$ = lsing($1); }
1111         |  rbinds1 COMMA rbind                  { $$ = lapp($1,$3); }
1112         ;
1113
1114 rbind   :  qvar                                 { $$ = mkrbind($1,mknothing()); }
1115         |  qvar EQUAL exp                       { $$ = mkrbind($1,mkjust($3)); }
1116         ;
1117
1118 texps   :  exp  { $$ = mkpar($1); }     /* mkpar: so we don't flatten last element in tuple */
1119         |  exp COMMA texps
1120                 { if (ttree($3) == tuple)
1121                     $$ = mktuple(mklcons($1, gtuplelist((struct Stuple *) $3)));
1122                   else if (ttree($3) == par)
1123                     $$ = mktuple(ldub($1, gpare((struct Spar *) $3)));
1124                   else
1125                     hsperror("hsparser:texps: panic");
1126                 }
1127         /* right recursion? WDP */
1128         ;
1129
1130 list_exps :
1131            exp                                  { $$ = lsing($1); }
1132         |  exp COMMA exp                        { $$ = mklcons( $1, lsing($3) ); }
1133         |  exp COMMA exp COMMA list_rest        { $$ = mklcons( $1, mklcons( $3, reverse_list( $5 ))); }
1134         ;
1135
1136 /* Use left recusion for list_rest, because we sometimes get programs with
1137    very long explicit lists. */
1138 list_rest :     exp                             { $$ = lsing($1); }
1139           | list_rest COMMA exp                 { $$ = mklcons( $3, $1 ); }
1140           ;
1141
1142 /*
1143            exp                                  { $$ = lsing($1); }
1144         |  exp COMMA list_exps          { $$ = mklcons($1, $3); }
1145 */
1146         /* right recursion? (WDP)
1147
1148            It has to be this way, though, otherwise you
1149            may do the wrong thing to distinguish between...
1150
1151            [ e1 , e2 .. ]       -- an enumeration ...
1152            [ e1 , e2 , e3 ]     -- a list
1153
1154            (In fact, if you change the grammar and throw yacc/bison
1155            at it, it *will* do the wrong thing [WDP 94/06])
1156         */
1157
1158 letdecls:  LET ocurly decls ccurly              { $$ = $3 }
1159         |  LET vocurly decls vccurly            { $$ = $3 }
1160         ;
1161
1162 quals   :  qual                                 { $$ = lsing($1); }
1163         |  quals COMMA qual                     { $$ = lapp($1,$3); }
1164         ;
1165
1166 qual    :  letdecls                             { $$ = mkseqlet($1); }
1167         |  expL                                 { $$ = $1; }
1168         |  {inpat=TRUE;} expLno
1169            {inpat=FALSE;} leftexp
1170                 { if ($4 == NULL) {
1171                       expORpat(LEGIT_EXPR,$2);
1172                       $$ = mkguard($2);
1173                   } else {
1174                       expORpat(LEGIT_PATT,$2);
1175                       $$ = mkqual($2,$4);
1176                   }
1177                 }
1178         ;
1179
1180 alts    :  alt                                  { $$ = $1; }
1181         |  alts SEMI alt                        { $$ = lconc($1,$3); }
1182         ;
1183
1184 alt     :  pat { PREVPATT = $1; } altrest       { $$ = lsing($3); PREVPATT = NULL; }
1185         |  /* empty */                          { $$ = Lnil; }
1186         ;
1187
1188 altrest :  gdpat maybe_where                    { $$ = createpat(mkpguards($1), $2); }
1189         |  RARROW exp maybe_where               { $$ = createpat(mkpnoguards($2),$3); }
1190         ;
1191
1192 gdpat   :  gd RARROW exp                        { $$ = lsing(mkpgdexp($1,$3)); }
1193         |  gd RARROW exp gdpat                  { $$ = mklcons(mkpgdexp($1,$3),$4);  }
1194         ;
1195
1196 stmts   :  stmt                                 { $$ = $1; }
1197         |  stmts SEMI stmt                      { $$ = lconc($1,$3); }
1198         ;
1199
1200 stmt    :  /* empty */                          { $$ = Lnil; }
1201         |  letdecls                             { $$ = lsing(mkseqlet($1)); }
1202         |  expL                                 { $$ = lsing($1); }
1203         |  {inpat=TRUE;} expLno {inpat=FALSE;} leftexp
1204                 { if ($4 == NULL) {
1205                       expORpat(LEGIT_EXPR,$2);
1206                       $$ = lsing(mkdoexp($2,endlineno));
1207                   } else {
1208                       expORpat(LEGIT_PATT,$2);
1209                       $$ = lsing(mkdobind($2,$4,endlineno));
1210                   }
1211                 }
1212         ;
1213
1214 leftexp :  LARROW exp                           { $$ = $2; }
1215         |  /* empty */                          { $$ = NULL; }
1216         ;
1217
1218 /**********************************************************************
1219 *                                                                     *
1220 *                                                                     *
1221 *     Patterns                                                        *
1222 *                                                                     *
1223 *                                                                     *
1224 **********************************************************************/
1225
1226 pat     :  qvar PLUS INTEGER                    { $$ = mkplusp($1, mkinteger($3)); }
1227         |  cpat
1228         ;
1229
1230 cpat    :  cpat qconop bpat                     { $$ = mkinfixap($2,$1,$3); }
1231         |  bpat
1232         ;
1233
1234 bpat    :  apatc
1235         |  conpat
1236         |  qcon OCURLY rpats CCURLY             { $$ = mkrecord($1,$3); }
1237         |  MINUS INTEGER                        { $$ = mknegate(mklit(mkinteger($2))); }
1238         |  MINUS FLOAT                          { $$ = mknegate(mklit(mkfloatr($2))); }
1239         ;
1240
1241 conpat  :  gcon                                 { $$ = mkident($1); }
1242         |  conpat apat                          { $$ = mkap($1,$2); }
1243         ;
1244
1245 apat    :  gcon                                 { $$ = mkident($1); }
1246         |  qcon OCURLY rpats CCURLY             { $$ = mkrecord($1,$3); }
1247         |  apatc
1248         ;
1249
1250 apatc   :  qvar                                 { $$ = mkident($1); }
1251         |  qvar AT apat                         { $$ = mkas($1,$3); }
1252         |  lit_constant                         { $$ = mklit($1); }
1253         |  WILDCARD                             { $$ = mkwildp(); }
1254         |  OPAREN pat CPAREN                    { $$ = mkpar($2); }
1255         |  OPAREN pat COMMA pats CPAREN         { $$ = mktuple(mklcons($2,$4)); }
1256         |  OBRACK pats CBRACK                   { $$ = mkllist($2); }
1257         |  LAZY apat                            { $$ = mklazyp($2); }
1258         ;
1259
1260 lit_constant:
1261            INTEGER                              { $$ = mkinteger($1); }
1262         |  FLOAT                                { $$ = mkfloatr($1); }
1263         |  CHAR                                 { $$ = mkcharr($1); }
1264         |  STRING                               { $$ = mkstring($1); }
1265         |  CHARPRIM                             { $$ = mkcharprim($1); }
1266         |  STRINGPRIM                           { $$ = mkstringprim($1); }
1267         |  INTPRIM                              { $$ = mkintprim($1); }
1268         |  FLOATPRIM                            { $$ = mkfloatprim($1); }
1269         |  DOUBLEPRIM                           { $$ = mkdoubleprim($1); }
1270         |  CLITLIT /* yurble yurble */          { $$ = mkclitlit($1); }
1271         ;
1272
1273 lampats :  apat lampats                         { $$ = mklcons($1,$2); }
1274         |  apat                                 { $$ = lsing($1); }
1275         /* right recursion? (WDP) */
1276         ;
1277
1278 pats    :  pat COMMA pats                       { $$ = mklcons($1, $3); }
1279         |  pat                                  { $$ = lsing($1); }
1280         /* right recursion? (WDP) */
1281         ;
1282
1283 rpats   : /* empty */                           { $$ = Lnil; }
1284         | rpats1
1285         ;
1286
1287 rpats1  : rpat                                  { $$ = lsing($1); }
1288         | rpats1 COMMA rpat                     { $$ = lapp($1,$3); }
1289         ;
1290
1291 rpat    :  qvar                                 { $$ = mkrbind($1,mknothing()); }
1292         |  qvar EQUAL pat                       { $$ = mkrbind($1,mkjust($3)); }
1293         ;
1294
1295
1296 patk    :  patk qconop bpat                     { $$ = mkinfixap($2,$1,$3); }
1297         |  bpatk
1298         ;
1299
1300 bpatk   :  apatck
1301         |  conpatk
1302         |  qconk OCURLY rpats CCURLY            { $$ = mkrecord($1,$3); }
1303         |  minuskey INTEGER                     { $$ = mknegate(mklit(mkinteger($2))); }
1304         |  minuskey FLOAT                       { $$ = mknegate(mklit(mkfloatr($2))); }
1305         ;
1306
1307 conpatk :  gconk                                { $$ = mkident($1); }
1308         |  conpatk apat                         { $$ = mkap($1,$2); }
1309         ;
1310
1311 apatck  :  qvark                                { $$ = mkident($1); }
1312         |  qvark AT apat                        { $$ = mkas($1,$3); }
1313         |  lit_constant                         { $$ = mklit($1); setstartlineno(); }
1314         |  WILDCARD                             { $$ = mkwildp(); setstartlineno(); }
1315         |  oparenkey pat CPAREN                 { $$ = mkpar($2); }
1316         |  oparenkey pat COMMA pats CPAREN      { $$ = mktuple(mklcons($2,$4)); }
1317         |  obrackkey pats CBRACK                { $$ = mkllist($2); }
1318         |  lazykey apat                         { $$ = mklazyp($2); }
1319         ;
1320
1321
1322 gcon    :  qcon
1323         |  OBRACK CBRACK                        { $$ = creategid(-1); }
1324         |  OPAREN CPAREN                        { $$ = creategid(0); }
1325         |  OPAREN commas CPAREN                 { $$ = creategid($2); }
1326         ;
1327
1328 gconk   :  qconk
1329         |  obrackkey CBRACK                     { $$ = creategid(-1); }
1330         |  oparenkey CPAREN                     { $$ = creategid(0); }
1331         |  oparenkey commas CPAREN              { $$ = creategid($2); }
1332         ;
1333
1334 /**********************************************************************
1335 *                                                                     *
1336 *                                                                     *
1337 *     Keywords which record the line start                            *
1338 *                                                                     *
1339 *                                                                     *
1340 **********************************************************************/
1341
1342 importkey:  IMPORT      { setstartlineno(); }
1343         ;
1344
1345 datakey :   DATA        { setstartlineno();
1346                           if(etags)
1347 #if 1/*etags*/
1348                             printf("%u\n",startlineno);
1349 #else
1350                             fprintf(stderr,"%u\tdata\n",startlineno);
1351 #endif
1352                         }
1353         ;
1354
1355 typekey :   TYPE        { setstartlineno();
1356                           if(etags)
1357 #if 1/*etags*/
1358                             printf("%u\n",startlineno);
1359 #else
1360                             fprintf(stderr,"%u\ttype\n",startlineno);
1361 #endif
1362                         }
1363         ;
1364
1365 newtypekey : NEWTYPE    { setstartlineno();
1366                           if(etags)
1367 #if 1/*etags*/
1368                             printf("%u\n",startlineno);
1369 #else
1370                             fprintf(stderr,"%u\tnewtype\n",startlineno);
1371 #endif
1372                         }
1373         ;
1374
1375 instkey :   INSTANCE    { setstartlineno();
1376 #if 1/*etags*/
1377 /* OUT:                   if(etags)
1378                             printf("%u\n",startlineno);
1379 */
1380 #else
1381                             fprintf(stderr,"%u\tinstance\n",startlineno);
1382 #endif
1383                         }
1384         ;
1385
1386 defaultkey: DEFAULT     { setstartlineno(); }
1387         ;
1388
1389 classkey:   CLASS       { setstartlineno();
1390                           if(etags)
1391 #if 1/*etags*/
1392                             printf("%u\n",startlineno);
1393 #else
1394                             fprintf(stderr,"%u\tclass\n",startlineno);
1395 #endif
1396                         }
1397         ;
1398
1399 modulekey:  MODULE      { setstartlineno();
1400                           if(etags)
1401 #if 1/*etags*/
1402                             printf("%u\n",startlineno);
1403 #else
1404                             fprintf(stderr,"%u\tmodule\n",startlineno);
1405 #endif
1406                         }
1407         ;
1408
1409 oparenkey:  OPAREN      { setstartlineno(); }
1410         ;
1411
1412 obrackkey:  OBRACK      { setstartlineno(); }
1413         ;
1414
1415 lazykey :   LAZY        { setstartlineno(); }
1416         ;
1417
1418 minuskey:   MINUS       { setstartlineno(); }
1419         ;
1420
1421
1422 /**********************************************************************
1423 *                                                                     *
1424 *                                                                     *
1425 *     Basic qualified/unqualified ids/ops                             *
1426 *                                                                     *
1427 *                                                                     *
1428 **********************************************************************/
1429
1430 qvar    :  qvarid
1431         |  OPAREN qvarsym CPAREN        { $$ = $2; }
1432         ;
1433 qcon    :  qconid
1434         |  OPAREN qconsym CPAREN        { $$ = $2; }
1435         ;
1436 qvarop  :  qvarsym
1437         |  BQUOTE qvarid BQUOTE         { $$ = $2; }
1438         ;
1439 qconop  :  qconsym
1440         |  BQUOTE qconid BQUOTE         { $$ = $2; }
1441         ;
1442 qop     :  qconop
1443         |  qvarop
1444         ;
1445
1446 /* Non "-" op, used in right sections */
1447 qop1    :  qconop
1448         |  qvarop1
1449         ;
1450
1451 /* Non "-" varop, used in right sections */
1452 qvarop1 :  QVARSYM
1453         |  varsym_nominus               { $$ = mknoqual($1); }
1454         |  BQUOTE qvarid BQUOTE         { $$ = $2; }
1455         ;
1456
1457
1458 var     :  varid
1459         |  OPAREN varsym CPAREN         { $$ = $2; }
1460         ;
1461 con     :  tycon                        /* using tycon removes conflicts */
1462         |  OPAREN CONSYM CPAREN         { $$ = $2; }
1463         ;
1464 varop   :  varsym
1465         |  BQUOTE varid BQUOTE          { $$ = $2; }
1466         ;
1467 conop   :  CONSYM
1468         |  BQUOTE CONID BQUOTE          { $$ = $2; }
1469         ;
1470 op      :  conop
1471         |  varop
1472         ;
1473
1474 qvark   :  qvarid                       { setstartlineno(); $$ = $1; }
1475         |  oparenkey qvarsym CPAREN     { $$ = $2; }
1476         ;
1477 qconk   :  qconid                       { setstartlineno(); $$ = $1; }
1478         |  oparenkey qconsym CPAREN     { $$ = $2; }
1479         ;
1480 vark    :  varid                        { setstartlineno(); $$ = $1; }
1481         |  oparenkey varsym CPAREN      { $$ = $2; }
1482         ;
1483
1484 qvarid  :  QVARID
1485         |  varid                        { $$ = mknoqual($1); }
1486         ;
1487 qvarsym :  QVARSYM
1488         |  varsym                       { $$ = mknoqual($1); }
1489         ;
1490 qconid  :  QCONID
1491         |  tycon                        { $$ = mknoqual($1); } /* using tycon removes conflicts */
1492         ;
1493 qconsym :  QCONSYM
1494         |  CONSYM                       { $$ = mknoqual($1); }
1495         ;
1496 qtycon  :  QCONID
1497         |  tycon                        { $$ = mknoqual($1); } /* using tycon removes conflicts */
1498         ;
1499 qtycls  :  QCONID
1500         |  tycon                        { $$ = mknoqual($1); } /* using tycon removes conflicts */
1501         ;
1502
1503 varsym  :  varsym_nominus
1504         |  MINUS                        { $$ = install_literal("-"); }
1505         ;
1506
1507 /* PLUS, BANG are valid varsyms */
1508 varsym_nominus : VARSYM
1509         |  PLUS                         { $$ = install_literal("+"); }
1510         |  BANG                         { $$ = install_literal("!"); }
1511         ;
1512
1513 /* AS HIDING QUALIFIED are valid varids */
1514 varid   :  VARID
1515         |  AS                           { $$ = install_literal("as"); }
1516         |  HIDING                       { $$ = install_literal("hiding"); }
1517         |  QUALIFIED                    { $$ = install_literal("qualified"); }
1518         ;
1519
1520
1521 ccallid :  VARID
1522         |  CONID
1523         ;
1524
1525 tyvar   :  varid                        { $$ = mknamedtvar(mknoqual($1)); }
1526         ;
1527 tycon   :  CONID
1528         ;
1529 modid   :  CONID
1530         ;
1531
1532 /*
1533 tyvar_list: tyvar                       { $$ = lsing($1); }
1534         |  tyvar_list COMMA tyvar       { $$ = lapp($1,$3); }
1535         ;
1536 */
1537
1538 /**********************************************************************
1539 *                                                                     *
1540 *                                                                     *
1541 *     Stuff to do with layout                                         *
1542 *                                                                     *
1543 *                                                                     *
1544 **********************************************************************/
1545
1546 ocurly  : layout OCURLY                         { hsincindent(); }
1547
1548 vocurly : layout                                { hssetindent(); }
1549         ;
1550
1551 layout  :                                       { hsindentoff(); }
1552         ;
1553
1554 ccurly  :
1555          CCURLY
1556                 {
1557                   FN = NULL; SAMEFN = 0; PREVPATT = NULL;
1558                   hsendindent();
1559                 }
1560         ;
1561
1562 vccurly :  { expect_ccurly = 1; }  vccurly1  { expect_ccurly = 0; }
1563         ;
1564
1565 vccurly1:
1566          VCCURLY
1567                 {
1568                   FN = NULL; SAMEFN = 0; PREVPATT = NULL;
1569                   hsendindent();
1570                 }
1571         | error
1572                 {
1573                   yyerrok;
1574                   FN = NULL; SAMEFN = 0; PREVPATT = NULL;
1575                   hsendindent();
1576                 }
1577         ;
1578
1579 %%
1580
1581 /**********************************************************************
1582 *                                                                     *
1583 *      Error Processing and Reporting                                 *
1584 *                                                                     *
1585 *  (This stuff is here in case we want to use Yacc macros and such.)  *
1586 *                                                                     *
1587 **********************************************************************/
1588
1589 void
1590 checkinpat()
1591 {
1592   if(!inpat)
1593     hsperror("pattern syntax used in expression");
1594 }
1595
1596
1597 /* The parser calls "hsperror" when it sees a
1598    `report this and die' error.  It sets the stage
1599    and calls "yyerror".
1600
1601    There should be no direct calls in the parser to
1602    "yyerror", except for the one from "hsperror".  Thus,
1603    the only other calls will be from the error productions
1604    introduced by yacc/bison/whatever.
1605
1606    We need to be able to recognise the from-error-production
1607    case, because we sometimes want to say, "Oh, never mind",
1608    because the layout rule kicks into action and may save
1609    the day.  [WDP]
1610 */
1611
1612 static BOOLEAN error_and_I_mean_it = FALSE;
1613
1614 void
1615 hsperror(s)
1616   char *s;
1617 {
1618     error_and_I_mean_it = TRUE;
1619     yyerror(s);
1620 }
1621
1622 extern char *yytext;
1623 extern int yyleng;
1624
1625 void
1626 yyerror(s)
1627   char *s;
1628 {
1629     /* We want to be able to distinguish 'error'-raised yyerrors
1630        from yyerrors explicitly coded by the parser hacker.
1631     */
1632     if (expect_ccurly && ! error_and_I_mean_it ) {
1633         /*NOTHING*/;
1634
1635     } else {
1636         fprintf(stderr, "%s:%d:%d: %s on input: ",
1637           input_filename, hsplineno, hspcolno + 1, s);
1638
1639         if (yyleng == 1 && *yytext == '\0')
1640             fprintf(stderr, "<EOF>");
1641
1642         else {
1643             fputc('"', stderr);
1644             format_string(stderr, (unsigned char *) yytext, yyleng);
1645             fputc('"', stderr);
1646         }
1647         fputc('\n', stderr);
1648
1649         /* a common problem */
1650         if (strcmp(yytext, "#") == 0)
1651             fprintf(stderr, "\t(Perhaps you forgot a `-cpp' or `-fglasgow-exts' flag?)\n");
1652
1653         exit(1);
1654     }
1655 }
1656
1657 void
1658 format_string(fp, s, len)
1659   FILE *fp;
1660   unsigned char *s;
1661   int len;
1662 {
1663     while (len-- > 0) {
1664         switch (*s) {
1665         case '\0':    fputs("\\NUL", fp);   break;
1666         case '\007':  fputs("\\a", fp);     break;
1667         case '\010':  fputs("\\b", fp);     break;
1668         case '\011':  fputs("\\t", fp);     break;
1669         case '\012':  fputs("\\n", fp);     break;
1670         case '\013':  fputs("\\v", fp);     break;
1671         case '\014':  fputs("\\f", fp);     break;
1672         case '\015':  fputs("\\r", fp);     break;
1673         case '\033':  fputs("\\ESC", fp);   break;
1674         case '\034':  fputs("\\FS", fp);    break;
1675         case '\035':  fputs("\\GS", fp);    break;
1676         case '\036':  fputs("\\RS", fp);    break;
1677         case '\037':  fputs("\\US", fp);    break;
1678         case '\177':  fputs("\\DEL", fp);   break;
1679         default:
1680             if (*s >= ' ')
1681                 fputc(*s, fp);
1682             else
1683                 fprintf(fp, "\\^%c", *s + '@');
1684             break;
1685         }
1686         s++;
1687     }
1688 }