/* -------------------------------------------------------------------------- * Hugs parser (included as part of input.c) * * Expect 16 shift/reduce conflicts when passing this grammar through yacc, * but don't worry; they should all be resolved in an appropriate manner. * * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the * Yale Haskell Group, and the OGI School of Science & Engineering at OHSU, * 1994-2003, All rights reserved.  It is distributed as free software under * the license in the file "License", which is included in the distribution. * * $RCSfile: parser.y,v $ * $Revision: 1.50 $ * $Date: 2006/08/30 18:57:13 $ * ------------------------------------------------------------------------*/ %{#ifndef lint#define lint#endif#define defTycon(n,l,lhs,rhs,w)	 tyconDefn(intOf(l),lhs,rhs,w); sp-=n#define sigdecl(l,vs,t)		 ap(SIGDECL,triple(l,vs,t))#define fixdecl(l,ops,a,p)	 ap(FIXDECL,\				    triple(l,ops,mkInt(mkSyntax(a,intOf(p)))))#define grded(gs)		 ap(GUARDED,gs)#define bang(t)			 ap(BANG,t)#define only(t)			 ap(ONLY,t)#define letrec(bs,e)		 (nonNull(bs) ? ap(LETREC,pair(bs,e)) : e)#define qualify(ps,t)		 (nonNull(ps) ? ap(QUAL,pair(ps,t)) : t)#define exportSelf()		 singleton(ap(MODULEENT,mkCon(module(currentModule).text)))#define yyerror(s)		 /* errors handled elsewhere */#define YYSTYPE			 Cell #ifdef YYBISON# if !defined(__GNUC__) || __GNUC__ <= 1static void __yy_memcpy Args((char*,char*, unsigned int));# endif#endif #ifdef _MANAGEDstatic void yymemcpy (char *yyto, const char *yyfrom, size_t yycount);#endif static Cell   local gcShadow	 Args((Int,Cell));static Void   local syntaxError	 Args((String));static String local unexpected	 Args((Void));static Cell   local checkPrec	 Args((Cell));static Cell   local buildTuple	 Args((List));static List   local checkCtxt	 Args((List));static Cell   local checkPred	 Args((Cell));static Pair   local checkDo	 Args((List));static Cell   local checkTyLhs	 Args((Cell));static Cell   local checkConstr	 Args((Cell)); #if MUDOstatic Pair   local checkMDo	 Args((List));#endif #if !TREXstatic Void   local noTREX	 Args((String));#endif#if !IPARAMstatic Void   local noIP	 Args((String));#endif#if !MUDOstatic Void   local noMDo	 Args((String));#endif /* For the purposes of reasonably portable garbage collection, it is * necessary to simulate the YACC stack on the Hugs stack to keep * track of all intermediate constructs.  The lexical analyser * pushes a token onto the stack for each token that is found, with * these elements being removed as reduce actions are performed, * taking account of look-ahead tokens as described by gcShadow() * below. * * Of the non-terminals used below, only start, topDecl & begin * do not leave any values on the Hugs stack.  The same is true for the * terminals EXPR and SCRIPT.  At the end of a successful parse, there * should only be one element left on the stack, containing the result * of the parse. */ #define gc0(e)			gcShadow(0,e)#define gc1(e)			gcShadow(1,e)#define gc2(e)			gcShadow(2,e)#define gc3(e)			gcShadow(3,e)#define gc4(e)			gcShadow(4,e)#define gc5(e)			gcShadow(5,e)#define gc6(e)			gcShadow(6,e)#define gc7(e)			gcShadow(7,e) %} %token EXPR       CTXT       SCRIPT%token CASEXP     OF         DATA       TYPE       IF%token THEN       ELSE       WHERE      LET        IN%token INFIXN     INFIXL     INFIXR     PRIMITIVE  TNEWTYPE%token DEFAULT    DERIVING   DO         TCLASS     TINSTANCE/*#if MUDO*/%token MDO/*#endif*/%token REPEAT	  ALL        NUMLIT     CHARLIT	   STRINGLIT%token VAROP      VARID	     CONOP      CONID%token QVAROP     QVARID     QCONOP     QCONID/*#if TREX*/%token RECSELID	  IPVARID/*#endif*/%token COCO       '='        UPTO       '@'        '\\'%token '|'        '-'        FROM       ARROW      '~'%token '!'        IMPLIES    '('        ','        ')'%token '['        ';'        ']'        '`'	   '.'%token TMODULE    IMPORT     HIDING     QUALIFIED  ASMOD%token NEEDPRIMS%token FOREIGN %%/*- Top level script/module structure -------------------------------------*/ start	  : EXPR exp lwherePart		{inputExpr = letrec($3,$2); sp-=2;}	  | CTXT context		{inputContext = $2;	    sp-=1;}	  | SCRIPT topModule		{valDefns  = $2;	    sp-=1;}	  | error			{syntaxError("input");}	  ; /*- Haskell module header/import parsing: ----------------------------------- * Syntax for Haskell modules (module headers and imports) is parsed but * most of it is ignored.  However, module names in import declarations * are used, of course, if import chasing is turned on. *-------------------------------------------------------------------------*/ /* In Haskell 1.2, the default module header was "module Main where" * In 1.3, this changed to "module Main(main) where". * We use the 1.2 header because it breaks much less pre-module code. */topModule : startMain begin modBody end {					 setExportList(singleton(ap(MODULEENT,mkCon(module(currentModule).text))));					 $$ = gc3($3);					}          | startMain '{' modBody '}'   {					 setExportList(singleton(ap(MODULEENT,mkCon(module(currentModule).text))));					 $$ = gc4($3);					}	  | TMODULE modname expspec WHERE '{' modBody end					{setExportList($3);   $$ = gc7($6);}	  | TMODULE modname expspec WHERE error					{syntaxError("declaration");}	  | TMODULE error		{syntaxError("module definition");}	  ;/* To implement the Haskell module system, we have to keep track of the * current module.  We rely on the use of LALR parsing to ensure that this  * side effect happens before any declarations within the module. */startMain : /* empty */			{startModule(conMain); 					 $$ = gc0(NIL);}	  ;modname	  : qconid			{startModule(mkCon(mkNestedQual($1))); $$ = gc1(NIL);}	  ;modid	  : qconid			{$$ = mkCon(mkNestedQual($1));}	  | STRINGLIT			{ String modName = findPathname(textToStr(textOf($1)));					  if (modName) { /* fillin pathname if known */					      $$ = mkStr(findText(modName));					  } else {					      $$ = $1;					  }					}	  ;modBody	  : /* empty */                 {$$ = gc0(NIL); }          | ';' modBody 		{$$ = gc2($2);}          | topDecls			{$$ = gc1($1);}	  | impDecls chase		{$$ = gc2(NIL);}	  | impDecls ';' chase topDecls	{$$ = gc4($4);}	  ; /*- Exports: --------------------------------------------------------------*/ expspec	  : /* empty */			{$$ = gc0(exportSelf());}	  | '(' ')'			{$$ = gc2(NIL);}	  | '(' ',' ')'			{$$ = gc3(NIL);}	  | '(' exports ')'		{$$ = gc3($2);}	  | '(' exports ',' ')'		{$$ = gc4($2);}	  ;exports	  : exports ',' export		{$$ = gc3(cons($3,$1));}	  | export			{$$ = gc1(singleton($1));}	  ;/* The qcon should be qconid.   * Relaxing the rule lets us explicitly export (:) from the Prelude. */export	  : qvar			{$$ = $1;}	  | qcon			{$$ = $1;}	  | qconid '(' UPTO ')'		{$$ = gc4(pair($1,DOTDOT));}	  | qconid '(' qnames ')'	{$$ = gc4(pair($1,$3));}	  | TMODULE modid		{$$ = gc2(ap(MODULEENT,$2));}	  ;qnames	  : /* empty */			{$$ = gc0(NIL);}	  | ','				{$$ = gc1(NIL);}	  | qnames1			{$$ = $1;}	  | qnames1 ','			{$$ = gc2($1);}	  ;qnames1	  : qnames1 ',' qname		{$$ = gc3(cons($3,$1));}	  | qname			{$$ = gc1(singleton($1));}	  ;qname	  : qvar			{$$ = $1;}	  | qcon			{$$ = $1;}	  ; /*- Import declarations: --------------------------------------------------*/ impDecls  : impDecls ';' impDecl	{imps = cons($3,imps); $$=gc3(NIL);}	  | impDecls ';'		{$$   = gc2(NIL); }	  | impDecl			{imps = singleton($1); $$=gc1(NIL);}	  ;chase	  : /* empty */			{if (chase(imps)) {					     clearStack();					     onto(imps);					     done();					     closeAnyInput();					     return 0;					 }					 $$ = gc0(NIL);					}	  ;/* Note that qualified import ignores the import list. */impDecl	  : IMPORT modid impspec	{addUnqualImport($2,NIL,$3);					 $$ = gc3($2);}	  | IMPORT modid ASMOD modid impspec					{addUnqualImport($2,$4,$5);					 $$ = gc5($2);}	  | IMPORT QUALIFIED modid ASMOD modid impspec					{addQualImport($3,$5,$6);					 $$ = gc6($3);}	  | IMPORT QUALIFIED modid impspec					{addQualImport($3,$3,$4);					 $$ = gc4($3);}	  | IMPORT error		{syntaxError("import declaration");}	  ;impspec	  : /* empty */			{$$ = gc0(DOTDOT);}	  | HIDING '(' imports ')'	{$$ = gc4(ap(HIDDEN,$3));}	  | '(' imports ')'		{$$ = gc3($2);}	  ;imports	  : /* empty */			{$$ = gc0(NIL);}	  | ','				{$$ = gc1(NIL);}	  | imports1			{$$ = $1;}	  | imports1 ','		{$$ = gc2($1);}	  ;imports1  : imports1 ',' import		{$$ = gc3(cons($3,$1));}	  | import			{$$ = gc1(singleton($1));}	  ;import	  : var				{$$ = $1;}	  | CONID			{$$ = gc1(pair($1,NONE));}	  | CONID '(' UPTO ')'		{$$ = gc4(pair($1,DOTDOT));}	  | CONID '(' names ')'		{$$ = gc4(pair($1,$3));}	  ;names	  : /* empty */			{$$ = gc0(NIL);}	  | ','				{$$ = gc1(NIL);}	  | names1			{$$ = $1;}	  | names1 ','			{$$ = gc2($1);}	  ;names1	  : names1 ',' name		{$$ = gc3(cons($3,$1));}	  | name			{$$ = gc1(singleton($1));}	  ;name	  : var				{$$ = $1;}	  | con				{$$ = $1;}	  ; /*- Top-level declarations: -----------------------------------------------*/ topDecls  : topDecls ';'		{$$ = gc2($1);}          | topDecls ';' topDecl	{$$ = gc2($1);}	  | topDecls ';' decl		{$$ = gc3(cons($3,$1));}	  | topDecl			{$$ = gc0(NIL);}	  | decl			{$$ = gc1(cons($1,NIL));}	  ; /*- Type declarations: ----------------------------------------------------*/ topDecl	  : TYPE tyLhs '=' type		{defTycon(4,$3,$2,$4,SYNONYM);}	  | TYPE tyLhs '=' type IN invars					{defTycon(6,$3,$2,						    ap($4,$6),RESTRICTSYN);}	  | TYPE error			{syntaxError("type declaration");}	  | DATA btype2 '=' constrs deriving					{defTycon(5,$3,checkTyLhs($2),						    ap(rev($4),$5),DATATYPE);}	  | DATA context IMPLIES tyLhs '=' constrs deriving					{defTycon(7,$5,$4,						  ap(qualify($2,rev($6)),						     $7),DATATYPE);}	  | DATA btype2			{defTycon(2,$1,checkTyLhs($2),						    ap(NIL,NIL),DATATYPE);}	  | DATA context IMPLIES tyLhs  {defTycon(4,$1,$4,						  ap(qualify($2,NIL),						     NIL),DATATYPE);}	  | DATA error			{syntaxError("data declaration");}	  | TNEWTYPE btype2 '=' nconstr deriving					{defTycon(5,$3,checkTyLhs($2),						    ap($4,$5),NEWTYPE);}	  | TNEWTYPE context IMPLIES tyLhs '=' nconstr deriving					{defTycon(7,$5,$4,						  ap(qualify($2,$6),						     $7),NEWTYPE);}	  | TNEWTYPE error		{syntaxError("newtype declaration");}	  | NEEDPRIMS NUMLIT		{if (isInt($2)) {					     needPrims(intOf($2), NULL);					 } else {					     syntaxError("needprims decl");					 }					 sp-=2;}	  | NEEDPRIMS error		{syntaxError("needprims decl");}	  ;tyLhs	  : tyLhs varid			{$$ = gc2(ap($1,$2));}	  | CONID			{$$ = $1;}	  | error			{syntaxError("type defn lhs");}	  ;invars	  : invars ',' invar		{$$ = gc3(cons($3,$1));}	  | invar			{$$ = gc1(cons($1,NIL));}	  ;invar	  : var COCO topType		{$$ = gc3(sigdecl($2,singleton($1),									$3));}	  | var				{$$ = $1;}	  ;constrs	  : constrs '|' pconstr		{$$ = gc3(cons($3,$1));}	  | pconstr			{$$ = gc1(cons($1,NIL));}	  ;pconstr	  : ALL varids '.' qconstr	{$$ = gc4(ap(POLYTYPE,						     pair(rev($2),$4)));}	  | constr			{$$ = $1;}	  ;qconstr	  : context IMPLIES constr	{$$ = gc3(qualify($1,$3));}	  | constr			{$$ = $1;}	  ;constr	  : '!' btype conop bbtype	{$$ = gc4(ap(ap($3,bang($2)),$4));}	  | btype1    conop bbtype	{$$ = gc3(ap(ap($2,$1),$3));}	  | btype2    conop bbtype	{$$ = gc3(ap(ap($2,$1),$3));}	  | bpolyType conop bbtype	{$$ = gc3(ap(ap($2,$1),$3));}	  | btype2			{$$ = checkConstr($1);}	  | btype3			{$$ = checkConstr($1);}	  | con '{' fieldspecs '}'	{$$ = gc4(ap(LABC,pair($1,rev($3))));}	  | con '{' '}'			{$$ = gc3(ap(LABC,pair($1,NIL)));}	  | error			{syntaxError("data type declaration");}	  ;btype3	  : btype2 '!' atype		{$$ = gc3(ap($1,bang($3)));}	  | btype2 bpolyType		{$$ = gc2(ap($1,$2));}	  | btype3 atype		{$$ = gc2(ap($1,$2));}	  | btype3 '!' atype		{$$ = gc3(ap($1,bang($3)));}	  | btype3 bpolyType		{$$ = gc2(ap($1,$2));}	  | '(' CONOP ')'		{$$ = gc3($2);}	  ;bbtype	  : '!' btype			{$$ = gc2(bang($2));}	  | btype			{$$ = $1;}	  | bpolyType			{$$ = $1;}	  ;nconstr	  : pconstr			{$$ = gc1(singleton($1));}	  ;fieldspecs: fieldspecs ',' fieldspec	{$$ = gc3(cons($3,$1));}	  | fieldspec			{$$ = gc1(cons($1,NIL));}	  ;fieldspec : vars COCO polyType		{$$ = gc3(pair(rev($1),$3));}	  | vars COCO type		{$$ = gc3(pair(rev($1),$3));}	  | vars COCO '!' type		{$$ = gc4(pair(rev($1),bang($4)));}	  ;deriving  : /* empty */			{$$ = gc0(NIL);}	  | DERIVING qconid		{$$ = gc2(singleton($2));}	  | DERIVING '(' derivs0 ')'	{$$ = gc4($3);}	  ;derivs0	  : /* empty */			{$$ = gc0(NIL);}	  | derivs			{$$ = gc1(rev($1));}	  ;derivs	  : derivs ',' qconid		{$$ = gc3(cons($3,$1));}	  | qconid			{$$ = gc1(singleton($1));}	  ; /*- Processing definitions of primitives ----------------------------------*/ topDecl	  : PRIMITIVE prims COCO topType{primDefn($1,$2,$4); sp-=4;}	  ;prims	  : prims ',' prim		{$$ = gc3(cons($3,$1));}	  | prim			{$$ = gc1(cons($1,NIL));}	  | error			{syntaxError("primitive defn");}	  ;prim	  : var STRINGLIT		{$$ = gc2(pair($1,$2));}	  | var				{$$ = $1;}	  ; /*- Foreign Function Interface --------------------------------------------*/ topDecl   : FOREIGN IMPORT var STRINGLIT var COCO topType                {foreignImport($1,$3,NIL,$4,$5,$7); sp-=7;}          | FOREIGN IMPORT var var COCO topType                {foreignImport($1,$3,NIL,$4,$4,$6); sp-=6;}          | FOREIGN IMPORT var var STRINGLIT var COCO topType                {foreignImport($1,$3,$4,$5,$6,$8); sp-=8;}          | FOREIGN IMPORT var var var COCO topType                {foreignImport($1,$3,$4,$5,$5,$7); sp-=7;}          | FOREIGN var    var STRINGLIT var COCO topType                {foreignExport($1,$2,$3,$4,$5,$7); sp-=7;}	  ; /*- Class declarations: ---------------------------------------------------*/ topDecl	  : TCLASS crule fds wherePart	{classDefn(intOf($1),$2,$4,$3); sp-=4;}	  | TINSTANCE irule wherePart	{instDefn(intOf($1),$2,$3);  sp-=3;}	  | DEFAULT '(' dtypes ')'	{defaultDefn(intOf($1),$3);  sp-=4;}	  | TCLASS error		{syntaxError("class declaration");}	  | TINSTANCE error		{syntaxError("instance declaration");}	  | DEFAULT error		{syntaxError("default declaration");}	  ;crule	  : context IMPLIES btype2	{$$ = gc3(pair($1,checkPred($3)));}	  | btype2			{$$ = gc1(pair(NIL,checkPred($1)));}	  ;irule	  : context IMPLIES btype2	{$$ = gc3(pair($1,checkPred($3)));}	  | btype2			{$$ = gc1(pair(NIL,checkPred($1)));}	  ;dtypes	  : /* empty */			{$$ = gc0(NIL);}	  | dtypes1			{$$ = gc1(rev($1));}	  ;dtypes1	  : dtypes1 ',' type		{$$ = gc3(cons($3,$1));}	  | type			{$$ = gc1(cons($1,NIL));}	  ;fds	  : /* empty */			{$$ = gc0(NIL);}	  | '|' fds1			{h98DoesntSupport(row,"dependent parameters");					 $$ = gc2(rev($2));}	  ;fds1	  : fds1 ',' fd			{$$ = gc3(cons($3,$1));}	  | fd				{$$ = gc1(cons($1,NIL));}	  ;fd	  : varids0 ARROW varids0	{$$ = gc3(pair(rev($1),rev($3)));}	  | error			{syntaxError("functional dependency");}	  ;varids0   : /* empty */			{$$ = gc0(NIL);}	  | varids0 varid		{$$ = gc2(cons($2,$1));}	  ; /*- Type expressions: -----------------------------------------------------*/ topType	  : ALL varids '.' topType0	{$$ = gc4(ap(POLYTYPE,						     pair(rev($2),$4)));}	  | topType0			{$$ = $1;}	  ;topType0  : context IMPLIES topType1	{$$ = gc3(qualify($1,$3));}	  | topType1			{$$ = $1;}	  ;topType1  : bpolyType ARROW topType1	{$$ = gc3(fn($1,$3));}	  | btype1    ARROW topType1	{$$ = gc3(fn($1,$3));}	  | btype2    ARROW topType1	{$$ = gc3(fn($1,$3));}	  | btype			{$$ = $1;}	  ;polyType  : ALL varids '.' sigType	{$$ = gc4(ap(POLYTYPE,						     pair(rev($2),$4)));}	  | bpolyType			{$$ = $1;}	  ;bpolyType : '(' polyType ')'		{$$ = gc3($2);}	  | '(' lcontext IMPLIES type ')' {$$ = gc5(qualify($2,$4));}	  ;varids	  : varids varid		{$$ = gc2(cons($2,$1));}	  | varid			{$$ = gc1(singleton($1));}	  ;sigType   : context IMPLIES type	{$$ = gc3(qualify($1,$3));}	  | type			{$$ = $1;}	  ;context	  : '(' ')'			{$$ = gc2(NIL);}	  | btype2			{$$ = gc1(singleton(checkPred($1)));}	  | '(' btype2 ')'		{$$ = gc3(singleton(checkPred($2)));}	  | '(' btypes2 ')'		{$$ = gc3(checkCtxt(rev($2)));} 	  | lacks			{$$ = gc1(singleton($1));} 	  | '(' lacks1 ')'		{$$ = gc3(checkCtxt(rev($2)));} 	  ;lcontext  : lacks			{$$ = gc1(singleton($1));} 	  | '(' lacks1 ')'		{$$ = gc3(checkCtxt(rev($2)));}	  ;lacks	  : varid '\\' varid		{#if TREX					 $$ = gc3(ap(mkExt(textOf($3)),$1));#else					 noTREX("a type context");#endif					}          | IPVARID COCO type		{#if IPARAM					 $$ = gc3(pair(mkIParam($1),$3));#else					 noIP("a type context");#endif					}	  ;lacks1    : btypes2 ',' lacks		{$$ = gc3(cons($3,$1));}	  | lacks1  ',' btype2		{$$ = gc3(cons($3,$1));}	  | lacks1  ',' lacks		{$$ = gc3(cons($3,$1));}	  | btype2  ',' lacks		{$$ = gc3(cons($3,cons($1,NIL)));}	  | lacks			{$$ = gc1(singleton($1));}	  ; type	  : type1			{$$ = $1;}	  | btype2			{$$ = $1;}	  ;type1	  : btype1			{$$ = $1;}	  | bpolyType ARROW type	{$$ = gc3(fn($1,$3));}	  | btype1    ARROW type	{$$ = gc3(fn($1,$3));}	  | btype2    ARROW type	{$$ = gc3(fn($1,$3));}	  | error			{syntaxError("type expression");}

Lines 1–500 of 1287. Load more