PageRenderTime 75ms CodeModel.GetById 35ms RepoModel.GetById 1ms app.codeStats 0ms

/hugs98-plus-Sep2006/src/parser.y

#
Happy | 1287 lines | 1217 code | 70 blank | 0 comment | 0 complexity | 1840787fd6938ad9759c2d458d567297 MD5 | raw file
Possible License(s): LGPL-2.1, BSD-2-Clause, GPL-2.0, BSD-3-Clause
  1. /* --------------------------------------------------------------------------
  2. * Hugs parser (included as part of input.c)
  3. *
  4. * Expect 16 shift/reduce conflicts when passing this grammar through yacc,
  5. * but don't worry; they should all be resolved in an appropriate manner.
  6. *
  7. * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
  8. * Yale Haskell Group, and the OGI School of Science & Engineering at OHSU,
  9. * 1994-2003, All rights reserved. It is distributed as free software under
  10. * the license in the file "License", which is included in the distribution.
  11. *
  12. * $RCSfile: parser.y,v $
  13. * $Revision: 1.50 $
  14. * $Date: 2006/08/30 18:57:13 $
  15. * ------------------------------------------------------------------------*/
  16. %{
  17. #ifndef lint
  18. #define lint
  19. #endif
  20. #define defTycon(n,l,lhs,rhs,w) tyconDefn(intOf(l),lhs,rhs,w); sp-=n
  21. #define sigdecl(l,vs,t) ap(SIGDECL,triple(l,vs,t))
  22. #define fixdecl(l,ops,a,p) ap(FIXDECL,\
  23. triple(l,ops,mkInt(mkSyntax(a,intOf(p)))))
  24. #define grded(gs) ap(GUARDED,gs)
  25. #define bang(t) ap(BANG,t)
  26. #define only(t) ap(ONLY,t)
  27. #define letrec(bs,e) (nonNull(bs) ? ap(LETREC,pair(bs,e)) : e)
  28. #define qualify(ps,t) (nonNull(ps) ? ap(QUAL,pair(ps,t)) : t)
  29. #define exportSelf() singleton(ap(MODULEENT,mkCon(module(currentModule).text)))
  30. #define yyerror(s) /* errors handled elsewhere */
  31. #define YYSTYPE Cell
  32. #ifdef YYBISON
  33. # if !defined(__GNUC__) || __GNUC__ <= 1
  34. static void __yy_memcpy Args((char*,char*, unsigned int));
  35. # endif
  36. #endif
  37. #ifdef _MANAGED
  38. static void yymemcpy (char *yyto, const char *yyfrom, size_t yycount);
  39. #endif
  40. static Cell local gcShadow Args((Int,Cell));
  41. static Void local syntaxError Args((String));
  42. static String local unexpected Args((Void));
  43. static Cell local checkPrec Args((Cell));
  44. static Cell local buildTuple Args((List));
  45. static List local checkCtxt Args((List));
  46. static Cell local checkPred Args((Cell));
  47. static Pair local checkDo Args((List));
  48. static Cell local checkTyLhs Args((Cell));
  49. static Cell local checkConstr Args((Cell));
  50. #if MUDO
  51. static Pair local checkMDo Args((List));
  52. #endif
  53. #if !TREX
  54. static Void local noTREX Args((String));
  55. #endif
  56. #if !IPARAM
  57. static Void local noIP Args((String));
  58. #endif
  59. #if !MUDO
  60. static Void local noMDo Args((String));
  61. #endif
  62. /* For the purposes of reasonably portable garbage collection, it is
  63. * necessary to simulate the YACC stack on the Hugs stack to keep
  64. * track of all intermediate constructs. The lexical analyser
  65. * pushes a token onto the stack for each token that is found, with
  66. * these elements being removed as reduce actions are performed,
  67. * taking account of look-ahead tokens as described by gcShadow()
  68. * below.
  69. *
  70. * Of the non-terminals used below, only start, topDecl & begin
  71. * do not leave any values on the Hugs stack. The same is true for the
  72. * terminals EXPR and SCRIPT. At the end of a successful parse, there
  73. * should only be one element left on the stack, containing the result
  74. * of the parse.
  75. */
  76. #define gc0(e) gcShadow(0,e)
  77. #define gc1(e) gcShadow(1,e)
  78. #define gc2(e) gcShadow(2,e)
  79. #define gc3(e) gcShadow(3,e)
  80. #define gc4(e) gcShadow(4,e)
  81. #define gc5(e) gcShadow(5,e)
  82. #define gc6(e) gcShadow(6,e)
  83. #define gc7(e) gcShadow(7,e)
  84. %}
  85. %token EXPR CTXT SCRIPT
  86. %token CASEXP OF DATA TYPE IF
  87. %token THEN ELSE WHERE LET IN
  88. %token INFIXN INFIXL INFIXR PRIMITIVE TNEWTYPE
  89. %token DEFAULT DERIVING DO TCLASS TINSTANCE
  90. /*#if MUDO*/
  91. %token MDO
  92. /*#endif*/
  93. %token REPEAT ALL NUMLIT CHARLIT STRINGLIT
  94. %token VAROP VARID CONOP CONID
  95. %token QVAROP QVARID QCONOP QCONID
  96. /*#if TREX*/
  97. %token RECSELID IPVARID
  98. /*#endif*/
  99. %token COCO '=' UPTO '@' '\\'
  100. %token '|' '-' FROM ARROW '~'
  101. %token '!' IMPLIES '(' ',' ')'
  102. %token '[' ';' ']' '`' '.'
  103. %token TMODULE IMPORT HIDING QUALIFIED ASMOD
  104. %token NEEDPRIMS
  105. %token FOREIGN
  106. %%
  107. /*- Top level script/module structure -------------------------------------*/
  108. start : EXPR exp lwherePart {inputExpr = letrec($3,$2); sp-=2;}
  109. | CTXT context {inputContext = $2; sp-=1;}
  110. | SCRIPT topModule {valDefns = $2; sp-=1;}
  111. | error {syntaxError("input");}
  112. ;
  113. /*- Haskell module header/import parsing: -----------------------------------
  114. * Syntax for Haskell modules (module headers and imports) is parsed but
  115. * most of it is ignored. However, module names in import declarations
  116. * are used, of course, if import chasing is turned on.
  117. *-------------------------------------------------------------------------*/
  118. /* In Haskell 1.2, the default module header was "module Main where"
  119. * In 1.3, this changed to "module Main(main) where".
  120. * We use the 1.2 header because it breaks much less pre-module code.
  121. */
  122. topModule : startMain begin modBody end {
  123. setExportList(singleton(ap(MODULEENT,mkCon(module(currentModule).text))));
  124. $$ = gc3($3);
  125. }
  126. | startMain '{' modBody '}' {
  127. setExportList(singleton(ap(MODULEENT,mkCon(module(currentModule).text))));
  128. $$ = gc4($3);
  129. }
  130. | TMODULE modname expspec WHERE '{' modBody end
  131. {setExportList($3); $$ = gc7($6);}
  132. | TMODULE modname expspec WHERE error
  133. {syntaxError("declaration");}
  134. | TMODULE error {syntaxError("module definition");}
  135. ;
  136. /* To implement the Haskell module system, we have to keep track of the
  137. * current module. We rely on the use of LALR parsing to ensure that this
  138. * side effect happens before any declarations within the module.
  139. */
  140. startMain : /* empty */ {startModule(conMain);
  141. $$ = gc0(NIL);}
  142. ;
  143. modname : qconid {startModule(mkCon(mkNestedQual($1))); $$ = gc1(NIL);}
  144. ;
  145. modid : qconid {$$ = mkCon(mkNestedQual($1));}
  146. | STRINGLIT { String modName = findPathname(textToStr(textOf($1)));
  147. if (modName) { /* fillin pathname if known */
  148. $$ = mkStr(findText(modName));
  149. } else {
  150. $$ = $1;
  151. }
  152. }
  153. ;
  154. modBody : /* empty */ {$$ = gc0(NIL); }
  155. | ';' modBody {$$ = gc2($2);}
  156. | topDecls {$$ = gc1($1);}
  157. | impDecls chase {$$ = gc2(NIL);}
  158. | impDecls ';' chase topDecls {$$ = gc4($4);}
  159. ;
  160. /*- Exports: --------------------------------------------------------------*/
  161. expspec : /* empty */ {$$ = gc0(exportSelf());}
  162. | '(' ')' {$$ = gc2(NIL);}
  163. | '(' ',' ')' {$$ = gc3(NIL);}
  164. | '(' exports ')' {$$ = gc3($2);}
  165. | '(' exports ',' ')' {$$ = gc4($2);}
  166. ;
  167. exports : exports ',' export {$$ = gc3(cons($3,$1));}
  168. | export {$$ = gc1(singleton($1));}
  169. ;
  170. /* The qcon should be qconid.
  171. * Relaxing the rule lets us explicitly export (:) from the Prelude.
  172. */
  173. export : qvar {$$ = $1;}
  174. | qcon {$$ = $1;}
  175. | qconid '(' UPTO ')' {$$ = gc4(pair($1,DOTDOT));}
  176. | qconid '(' qnames ')' {$$ = gc4(pair($1,$3));}
  177. | TMODULE modid {$$ = gc2(ap(MODULEENT,$2));}
  178. ;
  179. qnames : /* empty */ {$$ = gc0(NIL);}
  180. | ',' {$$ = gc1(NIL);}
  181. | qnames1 {$$ = $1;}
  182. | qnames1 ',' {$$ = gc2($1);}
  183. ;
  184. qnames1 : qnames1 ',' qname {$$ = gc3(cons($3,$1));}
  185. | qname {$$ = gc1(singleton($1));}
  186. ;
  187. qname : qvar {$$ = $1;}
  188. | qcon {$$ = $1;}
  189. ;
  190. /*- Import declarations: --------------------------------------------------*/
  191. impDecls : impDecls ';' impDecl {imps = cons($3,imps); $$=gc3(NIL);}
  192. | impDecls ';' {$$ = gc2(NIL); }
  193. | impDecl {imps = singleton($1); $$=gc1(NIL);}
  194. ;
  195. chase : /* empty */ {if (chase(imps)) {
  196. clearStack();
  197. onto(imps);
  198. done();
  199. closeAnyInput();
  200. return 0;
  201. }
  202. $$ = gc0(NIL);
  203. }
  204. ;
  205. /* Note that qualified import ignores the import list. */
  206. impDecl : IMPORT modid impspec {addUnqualImport($2,NIL,$3);
  207. $$ = gc3($2);}
  208. | IMPORT modid ASMOD modid impspec
  209. {addUnqualImport($2,$4,$5);
  210. $$ = gc5($2);}
  211. | IMPORT QUALIFIED modid ASMOD modid impspec
  212. {addQualImport($3,$5,$6);
  213. $$ = gc6($3);}
  214. | IMPORT QUALIFIED modid impspec
  215. {addQualImport($3,$3,$4);
  216. $$ = gc4($3);}
  217. | IMPORT error {syntaxError("import declaration");}
  218. ;
  219. impspec : /* empty */ {$$ = gc0(DOTDOT);}
  220. | HIDING '(' imports ')' {$$ = gc4(ap(HIDDEN,$3));}
  221. | '(' imports ')' {$$ = gc3($2);}
  222. ;
  223. imports : /* empty */ {$$ = gc0(NIL);}
  224. | ',' {$$ = gc1(NIL);}
  225. | imports1 {$$ = $1;}
  226. | imports1 ',' {$$ = gc2($1);}
  227. ;
  228. imports1 : imports1 ',' import {$$ = gc3(cons($3,$1));}
  229. | import {$$ = gc1(singleton($1));}
  230. ;
  231. import : var {$$ = $1;}
  232. | CONID {$$ = gc1(pair($1,NONE));}
  233. | CONID '(' UPTO ')' {$$ = gc4(pair($1,DOTDOT));}
  234. | CONID '(' names ')' {$$ = gc4(pair($1,$3));}
  235. ;
  236. names : /* empty */ {$$ = gc0(NIL);}
  237. | ',' {$$ = gc1(NIL);}
  238. | names1 {$$ = $1;}
  239. | names1 ',' {$$ = gc2($1);}
  240. ;
  241. names1 : names1 ',' name {$$ = gc3(cons($3,$1));}
  242. | name {$$ = gc1(singleton($1));}
  243. ;
  244. name : var {$$ = $1;}
  245. | con {$$ = $1;}
  246. ;
  247. /*- Top-level declarations: -----------------------------------------------*/
  248. topDecls : topDecls ';' {$$ = gc2($1);}
  249. | topDecls ';' topDecl {$$ = gc2($1);}
  250. | topDecls ';' decl {$$ = gc3(cons($3,$1));}
  251. | topDecl {$$ = gc0(NIL);}
  252. | decl {$$ = gc1(cons($1,NIL));}
  253. ;
  254. /*- Type declarations: ----------------------------------------------------*/
  255. topDecl : TYPE tyLhs '=' type {defTycon(4,$3,$2,$4,SYNONYM);}
  256. | TYPE tyLhs '=' type IN invars
  257. {defTycon(6,$3,$2,
  258. ap($4,$6),RESTRICTSYN);}
  259. | TYPE error {syntaxError("type declaration");}
  260. | DATA btype2 '=' constrs deriving
  261. {defTycon(5,$3,checkTyLhs($2),
  262. ap(rev($4),$5),DATATYPE);}
  263. | DATA context IMPLIES tyLhs '=' constrs deriving
  264. {defTycon(7,$5,$4,
  265. ap(qualify($2,rev($6)),
  266. $7),DATATYPE);}
  267. | DATA btype2 {defTycon(2,$1,checkTyLhs($2),
  268. ap(NIL,NIL),DATATYPE);}
  269. | DATA context IMPLIES tyLhs {defTycon(4,$1,$4,
  270. ap(qualify($2,NIL),
  271. NIL),DATATYPE);}
  272. | DATA error {syntaxError("data declaration");}
  273. | TNEWTYPE btype2 '=' nconstr deriving
  274. {defTycon(5,$3,checkTyLhs($2),
  275. ap($4,$5),NEWTYPE);}
  276. | TNEWTYPE context IMPLIES tyLhs '=' nconstr deriving
  277. {defTycon(7,$5,$4,
  278. ap(qualify($2,$6),
  279. $7),NEWTYPE);}
  280. | TNEWTYPE error {syntaxError("newtype declaration");}
  281. | NEEDPRIMS NUMLIT {if (isInt($2)) {
  282. needPrims(intOf($2), NULL);
  283. } else {
  284. syntaxError("needprims decl");
  285. }
  286. sp-=2;}
  287. | NEEDPRIMS error {syntaxError("needprims decl");}
  288. ;
  289. tyLhs : tyLhs varid {$$ = gc2(ap($1,$2));}
  290. | CONID {$$ = $1;}
  291. | error {syntaxError("type defn lhs");}
  292. ;
  293. invars : invars ',' invar {$$ = gc3(cons($3,$1));}
  294. | invar {$$ = gc1(cons($1,NIL));}
  295. ;
  296. invar : var COCO topType {$$ = gc3(sigdecl($2,singleton($1),
  297. $3));}
  298. | var {$$ = $1;}
  299. ;
  300. constrs : constrs '|' pconstr {$$ = gc3(cons($3,$1));}
  301. | pconstr {$$ = gc1(cons($1,NIL));}
  302. ;
  303. pconstr : ALL varids '.' qconstr {$$ = gc4(ap(POLYTYPE,
  304. pair(rev($2),$4)));}
  305. | constr {$$ = $1;}
  306. ;
  307. qconstr : context IMPLIES constr {$$ = gc3(qualify($1,$3));}
  308. | constr {$$ = $1;}
  309. ;
  310. constr : '!' btype conop bbtype {$$ = gc4(ap(ap($3,bang($2)),$4));}
  311. | btype1 conop bbtype {$$ = gc3(ap(ap($2,$1),$3));}
  312. | btype2 conop bbtype {$$ = gc3(ap(ap($2,$1),$3));}
  313. | bpolyType conop bbtype {$$ = gc3(ap(ap($2,$1),$3));}
  314. | btype2 {$$ = checkConstr($1);}
  315. | btype3 {$$ = checkConstr($1);}
  316. | con '{' fieldspecs '}' {$$ = gc4(ap(LABC,pair($1,rev($3))));}
  317. | con '{' '}' {$$ = gc3(ap(LABC,pair($1,NIL)));}
  318. | error {syntaxError("data type declaration");}
  319. ;
  320. btype3 : btype2 '!' atype {$$ = gc3(ap($1,bang($3)));}
  321. | btype2 bpolyType {$$ = gc2(ap($1,$2));}
  322. | btype3 atype {$$ = gc2(ap($1,$2));}
  323. | btype3 '!' atype {$$ = gc3(ap($1,bang($3)));}
  324. | btype3 bpolyType {$$ = gc2(ap($1,$2));}
  325. | '(' CONOP ')' {$$ = gc3($2);}
  326. ;
  327. bbtype : '!' btype {$$ = gc2(bang($2));}
  328. | btype {$$ = $1;}
  329. | bpolyType {$$ = $1;}
  330. ;
  331. nconstr : pconstr {$$ = gc1(singleton($1));}
  332. ;
  333. fieldspecs: fieldspecs ',' fieldspec {$$ = gc3(cons($3,$1));}
  334. | fieldspec {$$ = gc1(cons($1,NIL));}
  335. ;
  336. fieldspec : vars COCO polyType {$$ = gc3(pair(rev($1),$3));}
  337. | vars COCO type {$$ = gc3(pair(rev($1),$3));}
  338. | vars COCO '!' type {$$ = gc4(pair(rev($1),bang($4)));}
  339. ;
  340. deriving : /* empty */ {$$ = gc0(NIL);}
  341. | DERIVING qconid {$$ = gc2(singleton($2));}
  342. | DERIVING '(' derivs0 ')' {$$ = gc4($3);}
  343. ;
  344. derivs0 : /* empty */ {$$ = gc0(NIL);}
  345. | derivs {$$ = gc1(rev($1));}
  346. ;
  347. derivs : derivs ',' qconid {$$ = gc3(cons($3,$1));}
  348. | qconid {$$ = gc1(singleton($1));}
  349. ;
  350. /*- Processing definitions of primitives ----------------------------------*/
  351. topDecl : PRIMITIVE prims COCO topType{primDefn($1,$2,$4); sp-=4;}
  352. ;
  353. prims : prims ',' prim {$$ = gc3(cons($3,$1));}
  354. | prim {$$ = gc1(cons($1,NIL));}
  355. | error {syntaxError("primitive defn");}
  356. ;
  357. prim : var STRINGLIT {$$ = gc2(pair($1,$2));}
  358. | var {$$ = $1;}
  359. ;
  360. /*- Foreign Function Interface --------------------------------------------*/
  361. topDecl : FOREIGN IMPORT var STRINGLIT var COCO topType
  362. {foreignImport($1,$3,NIL,$4,$5,$7); sp-=7;}
  363. | FOREIGN IMPORT var var COCO topType
  364. {foreignImport($1,$3,NIL,$4,$4,$6); sp-=6;}
  365. | FOREIGN IMPORT var var STRINGLIT var COCO topType
  366. {foreignImport($1,$3,$4,$5,$6,$8); sp-=8;}
  367. | FOREIGN IMPORT var var var COCO topType
  368. {foreignImport($1,$3,$4,$5,$5,$7); sp-=7;}
  369. | FOREIGN var var STRINGLIT var COCO topType
  370. {foreignExport($1,$2,$3,$4,$5,$7); sp-=7;}
  371. ;
  372. /*- Class declarations: ---------------------------------------------------*/
  373. topDecl : TCLASS crule fds wherePart {classDefn(intOf($1),$2,$4,$3); sp-=4;}
  374. | TINSTANCE irule wherePart {instDefn(intOf($1),$2,$3); sp-=3;}
  375. | DEFAULT '(' dtypes ')' {defaultDefn(intOf($1),$3); sp-=4;}
  376. | TCLASS error {syntaxError("class declaration");}
  377. | TINSTANCE error {syntaxError("instance declaration");}
  378. | DEFAULT error {syntaxError("default declaration");}
  379. ;
  380. crule : context IMPLIES btype2 {$$ = gc3(pair($1,checkPred($3)));}
  381. | btype2 {$$ = gc1(pair(NIL,checkPred($1)));}
  382. ;
  383. irule : context IMPLIES btype2 {$$ = gc3(pair($1,checkPred($3)));}
  384. | btype2 {$$ = gc1(pair(NIL,checkPred($1)));}
  385. ;
  386. dtypes : /* empty */ {$$ = gc0(NIL);}
  387. | dtypes1 {$$ = gc1(rev($1));}
  388. ;
  389. dtypes1 : dtypes1 ',' type {$$ = gc3(cons($3,$1));}
  390. | type {$$ = gc1(cons($1,NIL));}
  391. ;
  392. fds : /* empty */ {$$ = gc0(NIL);}
  393. | '|' fds1 {h98DoesntSupport(row,"dependent parameters");
  394. $$ = gc2(rev($2));}
  395. ;
  396. fds1 : fds1 ',' fd {$$ = gc3(cons($3,$1));}
  397. | fd {$$ = gc1(cons($1,NIL));}
  398. ;
  399. fd : varids0 ARROW varids0 {$$ = gc3(pair(rev($1),rev($3)));}
  400. | error {syntaxError("functional dependency");}
  401. ;
  402. varids0 : /* empty */ {$$ = gc0(NIL);}
  403. | varids0 varid {$$ = gc2(cons($2,$1));}
  404. ;
  405. /*- Type expressions: -----------------------------------------------------*/
  406. topType : ALL varids '.' topType0 {$$ = gc4(ap(POLYTYPE,
  407. pair(rev($2),$4)));}
  408. | topType0 {$$ = $1;}
  409. ;
  410. topType0 : context IMPLIES topType1 {$$ = gc3(qualify($1,$3));}
  411. | topType1 {$$ = $1;}
  412. ;
  413. topType1 : bpolyType ARROW topType1 {$$ = gc3(fn($1,$3));}
  414. | btype1 ARROW topType1 {$$ = gc3(fn($1,$3));}
  415. | btype2 ARROW topType1 {$$ = gc3(fn($1,$3));}
  416. | btype {$$ = $1;}
  417. ;
  418. polyType : ALL varids '.' sigType {$$ = gc4(ap(POLYTYPE,
  419. pair(rev($2),$4)));}
  420. | bpolyType {$$ = $1;}
  421. ;
  422. bpolyType : '(' polyType ')' {$$ = gc3($2);}
  423. | '(' lcontext IMPLIES type ')' {$$ = gc5(qualify($2,$4));}
  424. ;
  425. varids : varids varid {$$ = gc2(cons($2,$1));}
  426. | varid {$$ = gc1(singleton($1));}
  427. ;
  428. sigType : context IMPLIES type {$$ = gc3(qualify($1,$3));}
  429. | type {$$ = $1;}
  430. ;
  431. context : '(' ')' {$$ = gc2(NIL);}
  432. | btype2 {$$ = gc1(singleton(checkPred($1)));}
  433. | '(' btype2 ')' {$$ = gc3(singleton(checkPred($2)));}
  434. | '(' btypes2 ')' {$$ = gc3(checkCtxt(rev($2)));}
  435. | lacks {$$ = gc1(singleton($1));}
  436. | '(' lacks1 ')' {$$ = gc3(checkCtxt(rev($2)));}
  437. ;
  438. lcontext : lacks {$$ = gc1(singleton($1));}
  439. | '(' lacks1 ')' {$$ = gc3(checkCtxt(rev($2)));}
  440. ;
  441. lacks : varid '\\' varid {
  442. #if TREX
  443. $$ = gc3(ap(mkExt(textOf($3)),$1));
  444. #else
  445. noTREX("a type context");
  446. #endif
  447. }
  448. | IPVARID COCO type {
  449. #if IPARAM
  450. $$ = gc3(pair(mkIParam($1),$3));
  451. #else
  452. noIP("a type context");
  453. #endif
  454. }
  455. ;
  456. lacks1 : btypes2 ',' lacks {$$ = gc3(cons($3,$1));}
  457. | lacks1 ',' btype2 {$$ = gc3(cons($3,$1));}
  458. | lacks1 ',' lacks {$$ = gc3(cons($3,$1));}
  459. | btype2 ',' lacks {$$ = gc3(cons($3,cons($1,NIL)));}
  460. | lacks {$$ = gc1(singleton($1));}
  461. ;
  462. type : type1 {$$ = $1;}
  463. | btype2 {$$ = $1;}
  464. ;
  465. type1 : btype1 {$$ = $1;}
  466. | bpolyType ARROW type {$$ = gc3(fn($1,$3));}
  467. | btype1 ARROW type {$$ = gc3(fn($1,$3));}
  468. | btype2 ARROW type {$$ = gc3(fn($1,$3));}
  469. | error {syntaxError("type expression");}
  470. ;
  471. btype : btype1 {$$ = $1;}
  472. | btype2 {$$ = $1;}
  473. ;
  474. btype1 : btype1 atype {$$ = gc2(ap($1,$2));}
  475. | atype1 {$$ = $1;}
  476. ;
  477. btype2 : btype2 atype {$$ = gc2(ap($1,$2));}
  478. | qconid {$$ = $1;}
  479. ;
  480. atype : atype1 {$$ = $1;}
  481. | qconid {$$ = $1;}
  482. ;
  483. atype1 : varid {$$ = $1;}
  484. | '(' ')' {$$ = gc2(typeUnit);}
  485. | '(' ARROW ')' {$$ = gc3(typeArrow);}
  486. | '(' type1 ')' {$$ = gc3($2);}
  487. | '(' btype2 ')' {$$ = gc3($2);}
  488. | '(' tupCommas ')' {$$ = gc3($2);}
  489. | '(' btypes2 ')' {$$ = gc3(buildTuple($2));}
  490. | '(' typeTuple ')' {$$ = gc3(buildTuple($2));}
  491. | '(' tfields ')' {
  492. #if TREX
  493. $$ = gc3(revOnto($2,typeNoRow));
  494. #else
  495. noTREX("a type");
  496. #endif
  497. }
  498. | '(' tfields '|' type ')' {
  499. #if TREX
  500. $$ = gc5(revOnto($2,$4));
  501. #else
  502. noTREX("a type");
  503. #endif
  504. }
  505. | '[' type ']' {$$ = gc3(ap(typeList,$2));}
  506. | '[' ']' {$$ = gc2(typeList);}
  507. | '_' {h98DoesntSupport(row,"anonymous type variables");
  508. $$ = gc1(inventVar());}
  509. ;
  510. btypes2 : btypes2 ',' btype2 {$$ = gc3(cons($3,$1));}
  511. | btype2 ',' btype2 {$$ = gc3(cons($3,cons($1,NIL)));}
  512. ;
  513. typeTuple : type1 ',' type {$$ = gc3(cons($3,cons($1,NIL)));}
  514. | btype2 ',' type1 {$$ = gc3(cons($3,cons($1,NIL)));}
  515. | btypes2 ',' type1 {$$ = gc3(cons($3,$1));}
  516. | typeTuple ',' type {$$ = gc3(cons($3,$1));}
  517. ;
  518. /*#if TREX*/
  519. tfields : tfields ',' tfield {$$ = gc3(cons($3,$1));}
  520. | tfield {$$ = gc1(singleton($1));}
  521. ;
  522. tfield : varid COCO type {h98DoesntSupport(row,"extensible records");
  523. $$ = gc3(ap(mkExt(textOf($1)),$3));}
  524. ;
  525. /*#endif*/
  526. /*- Value declarations: ---------------------------------------------------*/
  527. gendecl : INFIXN optDigit ops {$$ = gc3(fixdecl($1,$3,NON_ASS,$2));}
  528. | INFIXN error {syntaxError("fixity decl");}
  529. | INFIXL optDigit ops {$$ = gc3(fixdecl($1,$3,LEFT_ASS,$2));}
  530. | INFIXL error {syntaxError("fixity decl");}
  531. | INFIXR optDigit ops {$$ = gc3(fixdecl($1,$3,RIGHT_ASS,$2));}
  532. | INFIXR error {syntaxError("fixity decl");}
  533. | vars COCO topType {$$ = gc3(sigdecl($2,$1,$3));}
  534. | vars COCO error {syntaxError("type signature");}
  535. ;
  536. optDigit : NUMLIT {$$ = gc1(checkPrec($1));}
  537. | /* empty */ {$$ = gc0(mkInt(DEF_PREC));}
  538. ;
  539. ops : ops ',' op {$$ = gc3(cons($3,$1));}
  540. | op {$$ = gc1(singleton($1));}
  541. ;
  542. vars : vars ',' var {$$ = gc3(cons($3,$1));}
  543. | var {$$ = gc1(singleton($1));}
  544. ;
  545. decls : '{' decls0 end {$$ = gc3($2);}
  546. | '{' decls1 end {$$ = gc3($2);}
  547. ;
  548. decls0 : /* empty */ {$$ = gc0(NIL);}
  549. | decls0 ';' {$$ = gc2($1);}
  550. | decls1 ';' {$$ = gc2($1);}
  551. ;
  552. decls1 : decls0 decl {$$ = gc2(cons($2,$1));}
  553. ;
  554. decl : gendecl {$$ = $1;}
  555. | funlhs rhs {$$ = gc2(ap(FUNBIND,pair($1,$2)));}
  556. | funlhs COCO type rhs {$$ = gc4(ap(FUNBIND,
  557. pair($1,ap(RSIGN,
  558. ap($4,$3)))));}
  559. | pat0 rhs {$$ = gc2(ap(PATBIND,pair($1,$2)));}
  560. ;
  561. funlhs : funlhs0 {$$ = $1;}
  562. | funlhs1 {$$ = $1;}
  563. | npk {$$ = $1;}
  564. ;
  565. funlhs0 : pat10_vI varop pat0 {$$ = gc3(ap2($2,$1,$3));}
  566. | infixPat varop pat0 {$$ = gc3(ap2($2,$1,$3));}
  567. | NUMLIT varop pat0 {$$ = gc3(ap2($2,$1,$3));}
  568. | var varop_pl pat0 {$$ = gc3(ap2($2,$1,$3));}
  569. | var '+' pat0_INT {$$ = gc3(ap2(varPlus,$1,$3));}
  570. ;
  571. funlhs1 : '(' funlhs0 ')' apat {$$ = gc4(ap($2,$4));}
  572. | '(' funlhs1 ')' apat {$$ = gc4(ap($2,$4));}
  573. | '(' npk ')' apat {$$ = gc4(ap($2,$4));}
  574. | var apat {$$ = gc2(ap($1,$2));}
  575. | funlhs1 apat {$$ = gc2(ap($1,$2));}
  576. ;
  577. rhs : rhs1 wherePart {$$ = gc2(letrec($2,$1));}
  578. | error {syntaxError("declaration");}
  579. ;
  580. rhs1 : '=' exp {$$ = gc2(pair($1,$2));}
  581. | gdrhs {$$ = gc1(grded(rev($1)));}
  582. ;
  583. gdrhs : gdrhs gddef {$$ = gc2(cons($2,$1));}
  584. | gddef {$$ = gc1(singleton($1));}
  585. ;
  586. gddef : '|' exp0 '=' exp {$$ = gc4(pair($3,pair($2,$4)));}
  587. ;
  588. wherePart : /* empty */ {$$ = gc0(NIL);}
  589. | WHERE decls {$$ = gc2($2);}
  590. ;
  591. /* lwherePart and ldecls permit the binding of both 'normal'
  592. * and implicit parameter bindings.
  593. */
  594. lwherePart : /* empty */ {$$ = gc0(NIL);}
  595. | WHERE ldecls {$$ = gc2($2);}
  596. ;
  597. ldecls : '{' ldecls0 end {$$ = gc3($2);}
  598. | '{' ldecls1 end {$$ = gc3($2);}
  599. ;
  600. ldecls0 : /* empty */ {$$ = gc0(NIL);}
  601. | ldecls0 ';' {$$ = gc2($1);}
  602. | ldecls1 ';' {$$ = gc2($1);}
  603. ;
  604. ldecls1 : ldecls0 ldecl {$$ = gc2(cons($2,$1));}
  605. ;
  606. ldecl : IPVARID '=' exp {
  607. #if IPARAM
  608. $$ = gc3(pair($1,$3));
  609. #else
  610. noIP("a binding");
  611. #endif
  612. }
  613. | IPVARID error {syntaxError("a binding");}
  614. | decl {$$ = $1;}
  615. ;
  616. /*- Patterns: -------------------------------------------------------------*/
  617. pat : npk {$$ = $1;}
  618. | pat_npk {$$ = $1;}
  619. ;
  620. pat_npk : pat0 COCO type {$$ = gc3(ap(ESIGN,pair($1,$3)));}
  621. | pat0 {$$ = $1;}
  622. ;
  623. npk : var '+' NUMLIT {$$ = gc3(ap2(varPlus,$1,$3));}
  624. ;
  625. pat0 : var {$$ = $1;}
  626. | NUMLIT {$$ = $1;}
  627. | pat0_vI {$$ = $1;}
  628. ;
  629. pat0_INT : var {$$ = $1;}
  630. | pat0_vI {$$ = $1;}
  631. ;
  632. pat0_vI : pat10_vI {$$ = $1;}
  633. | infixPat {$$ = gc1(ap(INFIX,$1));}
  634. ;
  635. infixPat : '-' pat10 {$$ = gc2(ap(NEG,only($2)));}
  636. | '-' error {syntaxError("pattern");}
  637. | var qconop pat10 {$$ = gc3(ap(ap($2,only($1)),$3));}
  638. | var qconop '-' pat10 {$$ = gc4(ap(NEG,ap2($2,only($1),$4)));}
  639. | NUMLIT qconop pat10 {$$ = gc3(ap(ap($2,only($1)),$3));}
  640. | NUMLIT qconop '-' pat10 {$$ = gc4(ap(NEG,ap2($2,only($1),$4)));}
  641. | pat10_vI qconop pat10 {$$ = gc3(ap(ap($2,only($1)),$3));}
  642. | pat10_vI qconop '-' pat10 {$$ = gc4(ap(NEG,ap2($2,only($1),$4)));}
  643. | infixPat qconop pat10 {$$ = gc3(ap(ap($2,$1),$3));}
  644. | infixPat qconop '-' pat10 {$$ = gc4(ap(NEG,ap(ap($2,$1),$4)));}
  645. ;
  646. pat10 : fpat {$$ = $1;}
  647. | apat {$$ = $1;}
  648. ;
  649. pat10_vI : fpat {$$ = $1;}
  650. | apat_vI {$$ = $1;}
  651. ;
  652. fpat : fpat apat {$$ = gc2(ap($1,$2));}
  653. | gcon apat {$$ = gc2(ap($1,$2));}
  654. ;
  655. apat : NUMLIT {$$ = $1;}
  656. | var {$$ = $1;}
  657. | apat_vI {$$ = $1;}
  658. ;
  659. apat_vI : var '@' apat {$$ = gc3(ap(ASPAT,pair($1,$3)));}
  660. | gcon {$$ = $1;}
  661. | qcon '{' patbinds '}' {$$ = gc4(ap(CONFLDS,pair($1,$3)));}
  662. | CHARLIT {$$ = $1;}
  663. | STRINGLIT {$$ = $1;}
  664. | '_' {$$ = gc1(WILDCARD);}
  665. | '(' pat_npk ')' {$$ = gc3($2);}
  666. | '(' npk ')' {$$ = gc3($2);}
  667. | '(' pats2 ')' {$$ = gc3(buildTuple($2));}
  668. | '[' pats1 ']' {$$ = gc3(ap(FINLIST,rev($2)));}
  669. | '~' apat {$$ = gc2(ap(LAZYPAT,$2));}
  670. /*#if TREX*/
  671. | '(' patfields ')' {
  672. #if TREX
  673. $$ = gc3(revOnto($2,nameNoRec));
  674. #else
  675. $$ = gc3(NIL);
  676. #endif
  677. }
  678. | '(' patfields '|' pat ')' {$$ = gc5(revOnto($2,$4));}
  679. /*#endif TREX*/
  680. ;
  681. pats2 : pats2 ',' pat {$$ = gc3(cons($3,$1));}
  682. | pat ',' pat {$$ = gc3(cons($3,singleton($1)));}
  683. ;
  684. pats1 : pats1 ',' pat {$$ = gc3(cons($3,$1));}
  685. | pat {$$ = gc1(singleton($1));}
  686. ;
  687. patbinds : /* empty */ {$$ = gc0(NIL);}
  688. | patbinds1 {$$ = gc1(rev($1));}
  689. ;
  690. patbinds1 : patbinds1 ',' patbind {$$ = gc3(cons($3,$1));}
  691. | patbind {$$ = gc1(singleton($1));}
  692. ;
  693. patbind : qvar '=' pat {$$ = gc3(pair($1,$3));}
  694. | var {$$ = $1;}
  695. ;
  696. /*#if TREX*/
  697. patfields : patfields ',' patfield {$$ = gc3(cons($3,$1));}
  698. | patfield {$$ = gc1(singleton($1));}
  699. ;
  700. patfield : varid '=' pat {
  701. #if TREX
  702. $$ = gc3(ap(mkExt(textOf($1)),$3));
  703. #else
  704. noTREX("a pattern");
  705. #endif
  706. }
  707. ;
  708. /*#endif TREX*/
  709. /*- Expressions: ----------------------------------------------------------*/
  710. exp : exp_err {$$ = $1;}
  711. | error {syntaxError("expression");}
  712. ;
  713. exp_err : exp0a COCO sigType {$$ = gc3(ap(ESIGN,pair($1,$3)));}
  714. | exp0 {$$ = $1;}
  715. ;
  716. exp0 : exp0a {$$ = $1;}
  717. | exp0b {$$ = $1;}
  718. ;
  719. exp0a : infixExpa {$$ = gc1(ap(INFIX,$1));}
  720. | exp10a {$$ = $1;}
  721. ;
  722. exp0b : infixExpb {$$ = gc1(ap(INFIX,$1));}
  723. | exp10b {$$ = $1;}
  724. ;
  725. infixExpa : infixExpa qop '-' exp10a {$$ = gc4(ap(NEG,ap(ap($2,$1),$4)));}
  726. | infixExpa qop exp10a {$$ = gc3(ap(ap($2,$1),$3));}
  727. | '-' exp10a {$$ = gc2(ap(NEG,only($2)));}
  728. | exp10a qop '-' exp10a {$$ = gc4(ap(NEG,
  729. ap(ap($2,only($1)),$4)));}
  730. | exp10a qop exp10a {$$ = gc3(ap(ap($2,only($1)),$3));}
  731. ;
  732. infixExpb : infixExpa qop '-' exp10b {$$ = gc4(ap(NEG,ap(ap($2,$1),$4)));}
  733. | infixExpa qop exp10b {$$ = gc3(ap(ap($2,$1),$3));}
  734. | '-' exp10b {$$ = gc2(ap(NEG,only($2)));}
  735. | exp10a qop '-' exp10b {$$ = gc4(ap(NEG,
  736. ap(ap($2,only($1)),$4)));}
  737. | exp10a qop exp10b {$$ = gc3(ap(ap($2,only($1)),$3));}
  738. ;
  739. exp10a : CASEXP exp OF '{' alts end {$$ = gc6(ap(CASE,pair($2,rev($5))));}
  740. | DO '{' stmts end {$$ = gc4(ap(DOCOMP,checkDo($3)));}
  741. | MDO '{' stmts end {
  742. #if MUDO
  743. $$ = gc4(ap(MDOCOMP, checkMDo($3)));
  744. #else
  745. noMDo("an expression");
  746. #endif
  747. }
  748. | appExp {$$ = $1;}
  749. ;
  750. exp10b : '\\' pats ARROW exp {$$ = gc4(ap(LAMBDA,
  751. pair(rev($2),
  752. pair($3,$4))));}
  753. | LET ldecls IN exp {$$ = gc4(letrec($2,$4));}
  754. | IF exp then_exp else_exp {$$ = gc4(ap(COND,triple($2,$3,$4)));}
  755. ;
  756. /* Allow optional semicolons before 'then' and 'else' (as suggested by
  757. John Meacham), to remove a common pitfall when using if-then-else
  758. inside do expressions with implicit layout. */
  759. then_exp : ';' THEN exp {$$ = gc3($3);}
  760. | THEN exp {$$ = gc2($2);}
  761. ;
  762. else_exp : ';' ELSE exp {$$ = gc3($3);}
  763. | ELSE exp {$$ = gc2($2);}
  764. ;
  765. pats : pats apat {$$ = gc2(cons($2,$1));}
  766. | apat {$$ = gc1(cons($1,NIL));}
  767. ;
  768. appExp : appExp aexp {$$ = gc2(ap($1,$2));}
  769. | aexp {$$ = $1;}
  770. ;
  771. aexp : qvar {$$ = $1;}
  772. | qvar '@' aexp {$$ = gc3(ap(ASPAT,pair($1,$3)));}
  773. | '~' aexp {$$ = gc2(ap(LAZYPAT,$2));}
  774. | IPVARID {$$ = $1;}
  775. | '_' {$$ = gc1(WILDCARD);}
  776. | gcon {$$ = $1;}
  777. | qcon '{' fbinds '}' {$$ = gc4(ap(CONFLDS,pair($1,$3)));}
  778. | aexp '{' fbinds '}' {$$ = gc4(ap(UPDFLDS,
  779. triple($1,NIL,$3)));}
  780. | NUMLIT {$$ = $1;}
  781. | CHARLIT {$$ = $1;}
  782. | STRINGLIT {$$ = $1;}
  783. | REPEAT {$$ = $1;}
  784. | '(' exp ')' {$$ = gc3($2);}
  785. | '(' exps2 ')' {$$ = gc3(buildTuple($2));}
  786. /*#if TREX*/
  787. | '(' vfields ')' {
  788. #if TREX
  789. $$ = gc3(revOnto($2,nameNoRec));
  790. #else
  791. $$ = gc3(NIL);
  792. #endif
  793. }
  794. | '(' vfields '|' exp ')' {$$ = gc5(revOnto($2,$4));}
  795. | RECSELID {$$ = $1;}
  796. /*#endif*/
  797. | '[' list ']' {$$ = gc3($2);}
  798. | '(' exp10a qop ')' {$$ = gc4(ap($3,$2));}
  799. | '(' qvarop_mi exp0 ')' {$$ = gc4(ap(ap(nameFlip,$2),$3));}
  800. | '(' qconop exp0 ')' {$$ = gc4(ap(ap(nameFlip,$2),$3));}
  801. ;
  802. exps2 : exps2 ',' exp {$$ = gc3(cons($3,$1));}
  803. | exp ',' exp {$$ = gc3(cons($3,cons($1,NIL)));}
  804. ;
  805. /*#if TREX*/
  806. vfields : vfields ',' vfield {$$ = gc3(cons($3,$1));}
  807. | vfield {$$ = gc1(singleton($1));}
  808. ;
  809. vfield : varid '=' exp {
  810. #if TREX
  811. $$ = gc3(ap(mkExt(textOf($1)),$3));
  812. #else
  813. noTREX("an expression");
  814. #endif
  815. }
  816. ;
  817. /*#endif*/
  818. alts : alts1 {$$ = $1;}
  819. | ';' alts {$$ = gc2($2);}
  820. ;
  821. alts1 : alts1 ';' alt {$$ = gc3(cons($3,$1));}
  822. | alts1 ';' {$$ = gc2($1);}
  823. | alt {$$ = gc1(cons($1,NIL));}
  824. ;
  825. alt : pat altRhs wherePart {$$ = gc3(pair($1,letrec($3,$2)));}
  826. ;
  827. altRhs : guardAlts {$$ = gc1(grded(rev($1)));}
  828. | ARROW exp {$$ = gc2(pair($1,$2));}
  829. | error {syntaxError("case expression");}
  830. ;
  831. guardAlts : guardAlts guardAlt {$$ = gc2(cons($2,$1));}
  832. | guardAlt {$$ = gc1(cons($1,NIL));}
  833. ;
  834. guardAlt : '|' exp0 ARROW exp {$$ = gc4(pair($3,pair($2,$4)));}
  835. ;
  836. stmts : stmts1 {$$ = $1;}
  837. | ';' stmts {$$ = gc2($2);}
  838. ;
  839. stmts1 : stmts1 ';' stmt {$$ = gc3(cons($3,$1));}
  840. | stmts1 ';' {$$ = gc2($1);}
  841. | stmt {$$ = gc1(cons($1,NIL));}
  842. ;
  843. stmt : exp_err FROM exp {$$ = gc3(ap(FROMQUAL,pair($1,$3)));}
  844. | LET ldecls {$$ = gc2(ap(QWHERE,$2));}
  845. /* | IF exp {$$ = gc2(ap(BOOLQUAL,$2));}*/
  846. | exp_err {$$ = gc1(ap(DOQUAL,$1));}
  847. ;
  848. fbinds : /* empty */ {$$ = gc0(NIL);}
  849. | fbinds1 {$$ = gc1(rev($1));}
  850. ;
  851. fbinds1 : fbinds1 ',' fbind {$$ = gc3(cons($3,$1));}
  852. | fbind {$$ = gc1(singleton($1));}
  853. ;
  854. fbind : var {$$ = $1;}
  855. | qvar '=' exp {$$ = gc3(pair($1,$3));}
  856. ;
  857. /*- List Expressions: -------------------------------------------------------*/
  858. list : exp {$$ = gc1(ap(FINLIST,cons($1,NIL)));}
  859. | exps2 {$$ = gc1(ap(FINLIST,rev($1)));}
  860. | exp zipquals {
  861. #if ZIP_COMP
  862. if (length($2)==1) {
  863. $$ = gc2(ap(COMP,pair($1,hd($2))));
  864. } else {
  865. if (haskell98)
  866. syntaxError("list comprehension");
  867. $$ = gc2(ap(ZCOMP,pair($1,rev($2))));
  868. }
  869. #else
  870. if (length($2)!=1) {
  871. syntaxError("list comprehension");
  872. }
  873. $$ = gc2(ap(COMP,pair($1,hd($2))));
  874. #endif
  875. }
  876. | exp UPTO exp {$$ = gc3(ap(ap(nameFromTo,$1),$3));}
  877. | exp ',' exp UPTO {$$ = gc4(ap(ap(nameFromThen,$1),$3));}
  878. | exp UPTO {$$ = gc2(ap(nameFrom,$1));}
  879. | exp ',' exp UPTO exp {$$ = gc5(ap(ap(ap(nameFromThenTo,
  880. $1),$3),$5));}
  881. ;
  882. zipquals : zipquals '|' quals {$$ = gc3(cons(rev($3),$1));}
  883. | '|' quals {$$ = gc2(cons(rev($2),NIL));}
  884. ;
  885. quals : quals ',' qual {$$ = gc3(cons($3,$1));}
  886. | qual {$$ = gc1(cons($1,NIL));}
  887. ;
  888. qual : exp FROM exp {$$ = gc3(ap(FROMQUAL,pair($1,$3)));}
  889. | exp {$$ = gc1(ap(BOOLQUAL,$1));}
  890. | LET ldecls {$$ = gc2(ap(QWHERE,$2));}
  891. ;
  892. /*- Identifiers and symbols: ----------------------------------------------*/
  893. gcon : qcon {$$ = $1;}
  894. | '(' ')' {$$ = gc2(nameUnit);}
  895. | '[' ']' {$$ = gc2(nameNil);}
  896. | '(' tupCommas ')' {$$ = gc3($2);}
  897. ;
  898. tupCommas : tupCommas ',' {$$ = gc2(mkTuple(tupleOf($1)+1));}
  899. | ',' {$$ = gc1(mkTuple(2));}
  900. ;
  901. varid : VARID {$$ = $1;}
  902. | HIDING {$$ = gc1(varHiding);}
  903. | QUALIFIED {$$ = gc1(varQualified);}
  904. | ASMOD {$$ = gc1(varAsMod);}
  905. ;
  906. qconid : QCONID {$$ = $1;}
  907. | CONID {$$ = $1;}
  908. ;
  909. var : varid {$$ = $1;}
  910. | '(' VAROP ')' {$$ = gc3($2);}
  911. | '(' '+' ')' {$$ = gc3(varPlus);}
  912. | '(' '-' ')' {$$ = gc3(varMinus);}
  913. | '(' '!' ')' {$$ = gc3(varBang);}
  914. | '(' '.' ')' {$$ = gc3(varDot);}
  915. ;
  916. qvar : QVARID {$$ = $1;}
  917. | '(' QVAROP ')' {$$ = gc3($2);}
  918. | var {$$ = $1;}
  919. ;
  920. con : CONID {$$ = $1;}
  921. | '(' CONOP ')' {$$ = gc3($2);}
  922. ;
  923. qcon : QCONID {$$ = $1;}
  924. | '(' QCONOP ')' {$$ = gc3($2);}
  925. | con {$$ = $1;}
  926. ;
  927. varop : '+' {$$ = gc1(varPlus);}
  928. | '-' {$$ = gc1(varMinus);}
  929. | varop_mipl {$$ = $1;}
  930. ;
  931. varop_mi : '+' {$$ = gc1(varPlus);}
  932. | varop_mipl {$$ = $1;}
  933. ;
  934. varop_pl : '-' {$$ = gc1(varMinus);}
  935. | varop_mipl {$$ = $1;}
  936. ;
  937. varop_mipl: VAROP {$$ = $1;}
  938. | '`' varid '`' {$$ = gc3($2);}
  939. | '!' {$$ = gc1(varBang);}
  940. | '.' {$$ = gc1(varDot);}
  941. ;
  942. qvarop : '-' {$$ = gc1(varMinus);}
  943. | qvarop_mi {$$ = $1;}
  944. ;
  945. qvarop_mi : QVAROP {$$ = $1;}
  946. | '`' QVARID '`' {$$ = gc3($2);}
  947. | varop_mi {$$ = $1;}
  948. ;
  949. conop : CONOP {$$ = $1;}
  950. | '`' CONID '`' {$$ = gc3($2);}
  951. ;
  952. qconop : QCONOP {$$ = $1;}
  953. | '`' QCONID '`' {$$ = gc3($2);}
  954. | conop {$$ = $1;}
  955. ;
  956. op : varop {$$ = $1;}
  957. | conop {$$ = $1;}
  958. ;
  959. qop : qvarop {$$ = $1;}
  960. | qconop {$$ = $1;}
  961. ;
  962. /*- Tricks to force insertion of leading and closing braces ---------------*/
  963. begin : /* empty */ {goOffside(startColumn);}
  964. ;
  965. /* deal with trailing semicolon */
  966. end : '}' {$$ = $1;}
  967. | error {yyerrok;
  968. if (canUnOffside()) {
  969. unOffside();
  970. /* insert extra token on stack*/
  971. push(NIL);
  972. pushed(0) = pushed(1);
  973. pushed(1) = mkInt(column);
  974. }
  975. else
  976. syntaxError("declaration");
  977. }
  978. ;
  979. /*-------------------------------------------------------------------------*/
  980. %%
  981. static Cell local gcShadow(n,e) /* keep parsed fragments on stack */
  982. Int n;
  983. Cell e; {
  984. /* If a look ahead token is held then the required stack transformation
  985. * is:
  986. * pushed: n 1 0 1 0
  987. * x1 | ... | xn | la ===> e | la
  988. * top() top()
  989. *
  990. * Othwerwise, the transformation is:
  991. * pushed: n-1 0 0
  992. * x1 | ... | xn ===> e
  993. * top() top()
  994. */
  995. if (yychar>=0) {
  996. pushed(n-1) = top();
  997. pushed(n) = e;
  998. }
  999. else
  1000. pushed(n-1) = e;
  1001. sp -= (n-1);
  1002. return e;
  1003. }
  1004. static Void local syntaxError(s) /* report on syntax error */
  1005. String s; {
  1006. ERRMSG(row) "Syntax error in %s (unexpected %s)", s, unexpected()
  1007. EEND;
  1008. }
  1009. static String local unexpected() { /* find name for unexpected token */
  1010. static char buffer[100];
  1011. static char *fmt = "%s \"%s\"";
  1012. static char *kwd = "keyword";
  1013. switch (yychar) {
  1014. case 0 : return "end of input";
  1015. #define keyword(kw) sprintf(buffer,fmt,kwd,kw); return buffer;
  1016. case INFIXL : keyword("infixl");
  1017. case INFIXR : keyword("infixr");
  1018. case INFIXN : keyword("infix");
  1019. case TINSTANCE : keyword("instance");
  1020. case TCLASS : keyword("class");
  1021. case PRIMITIVE : keyword("primitive");
  1022. case CASEXP : keyword("case");
  1023. case OF : keyword("of");
  1024. case IF : keyword("if");
  1025. case THEN : keyword("then");
  1026. case ELSE : keyword("else");
  1027. case WHERE : keyword("where");
  1028. case TYPE : keyword("type");
  1029. case DATA : keyword("data");
  1030. case TNEWTYPE : keyword("newtype");
  1031. case LET : keyword("let");
  1032. case IN : keyword("in");
  1033. case DERIVING : keyword("deriving");
  1034. case DEFAULT : keyword("default");
  1035. case IMPORT : keyword("import");
  1036. case TMODULE : keyword("module");
  1037. case ALL : keyword("forall");
  1038. #undef keyword
  1039. case ARROW : return "`->'";
  1040. case '=' : return "`='";
  1041. case COCO : return "`::'";
  1042. case '-' : return "`-'";
  1043. case '!' : return "`!'";
  1044. case ',' : return "comma";
  1045. case '@' : return "`@'";
  1046. case '(' : return "`('";
  1047. case ')' : return "`)'";
  1048. case '{' : return "`{', possibly due to bad layout";
  1049. case '}' : return "`}', possibly due to bad layout";
  1050. case '_' : return "`_'";
  1051. case '|' : return "`|'";
  1052. case '.' : return "`.'";
  1053. case ';' : return "`;', possibly due to bad layout";
  1054. case UPTO : return "`..'";
  1055. case '[' : return "`['";
  1056. case ']' : return "`]'";
  1057. case FROM : return "`<-'";
  1058. case '\\' : return "backslash (lambda)";
  1059. case '~' : return "tilde";
  1060. case '`' : return "backquote";
  1061. #if TREX
  1062. case RECSELID : sprintf(buffer,"selector \"#%s\"",
  1063. textToStr(extText(snd(yylval))));
  1064. return buffer;
  1065. #endif
  1066. #if IPARAM
  1067. case IPVARID : sprintf(buffer,"implicit parameter \"?%s\"",
  1068. textToStr(textOf(yylval)));
  1069. return buffer;
  1070. #endif
  1071. case VAROP :
  1072. case VARID :
  1073. case CONOP :
  1074. case CONID : sprintf(buffer,"symbol \"%s\"",
  1075. textToStr(textOf(yylval)));
  1076. return buffer;
  1077. case QVAROP :
  1078. case QVARID :
  1079. case QCONOP :
  1080. case QCONID : sprintf(buffer,"symbol \"%s\"",
  1081. identToStr(yylval));
  1082. return buffer;
  1083. case HIDING : return "symbol \"hiding\"";
  1084. case QUALIFIED : return "symbol \"qualified\"";
  1085. case ASMOD : return "symbol \"as\"";
  1086. case NUMLIT : return "numeric literal";
  1087. case CHARLIT : return "character literal";
  1088. case STRINGLIT : return "string literal";
  1089. case IMPLIES : return "`=>'";
  1090. default : return "token";
  1091. }
  1092. }
  1093. static Cell local checkPrec(p) /* Check for valid precedence value*/
  1094. Cell p; {
  1095. if (!isInt(p) || intOf(p)<MIN_PREC || intOf(p)>MAX_PREC) {
  1096. ERRMSG(row) "Precedence value must be an integer in the range [%d..%d]",
  1097. MIN_PREC, MAX_PREC
  1098. EEND;
  1099. }
  1100. return p;
  1101. }
  1102. static Cell local buildTuple(tup) /* build tuple (x1,...,xn) from */
  1103. List tup; { /* list [xn,...,x1] */
  1104. Int n = 0;
  1105. Cell t = tup;
  1106. Cell x;
  1107. do { /* . . */
  1108. x = fst(t); /* / \ / \ */
  1109. fst(t) = snd(t); /* xn . . xn */
  1110. snd(t) = x; /* . ===> . */
  1111. x = t; /* . . */
  1112. t = fun(x); /* . . */
  1113. n++; /* / \ / \ */
  1114. } while (nonNull(t)); /* x1 NIL (n) x1 */
  1115. fst(x) = mkTuple(n);
  1116. return tup;
  1117. }
  1118. static List local checkCtxt(con) /* validate context */
  1119. Type con; {
  1120. mapOver(checkPred, con);
  1121. return con;
  1122. }
  1123. static Cell local checkPred(c) /* check that type expr is a valid */
  1124. Cell c; { /* constraint */
  1125. Cell cn = getHead(c);
  1126. #if TREX
  1127. if (isExt(cn) && argCount==1)
  1128. return c;
  1129. #endif
  1130. #if IPARAM
  1131. if (isIP(cn))
  1132. return c;
  1133. #endif
  1134. if (!isQCon(cn) /*|| argCount==0*/)
  1135. syntaxError("class expression");
  1136. return c;
  1137. }
  1138. static Pair local checkDo(dqs) /* convert reversed list of dquals */
  1139. List dqs; { /* to an (expr,quals) pair */
  1140. if (isNull(dqs) || whatIs(hd(dqs))!=DOQUAL) {
  1141. ERRMSG(row) "Last generator in do {...} must be an expression"
  1142. EEND;
  1143. }
  1144. fst(dqs) = snd(fst(dqs)); /* put expression in fst of pair */
  1145. snd(dqs) = rev(snd(dqs)); /* & reversed list of quals in snd */
  1146. return dqs;
  1147. }
  1148. #if MUDO
  1149. static Pair local checkMDo(dqs) /* convert reversed list of dquals */
  1150. List dqs; { /* to an (expr,quals) pair */
  1151. if (isNull(dqs) || whatIs(hd(dqs))!=DOQUAL) {
  1152. ERRMSG(row) "Last generator in mdo {...} must be an expression"
  1153. EEND;
  1154. }
  1155. fst(dqs) = snd(fst(dqs)); /* put expression in fst of pair */
  1156. snd(dqs) = rev(snd(dqs)); /* & reversed list of quals in snd */
  1157. return dqs;
  1158. }
  1159. #endif
  1160. static Cell local checkTyLhs(c) /* check that lhs is of the form */
  1161. Cell c; { /* T a1 ... a */
  1162. Cell tlhs = c;
  1163. while (isAp(tlhs) && whatIs(arg(tlhs))==VARIDCELL) {
  1164. tlhs = fun(tlhs);
  1165. }
  1166. if (whatIs(tlhs)!=CONIDCELL) {
  1167. ERRMSG(row) "Illegal left hand side in data type declaration"
  1168. EEND;
  1169. }
  1170. return c;
  1171. }
  1172. static Cell local checkConstr(c) /* check that data constructor has */
  1173. Cell c; { /* an unqualified conid as head */
  1174. Cell chd = c;
  1175. while (isAp(chd)) {
  1176. chd = fun(chd);
  1177. }
  1178. if (whatIs(chd)==QUALIDENT) {
  1179. ERRMSG(row) "Qualified constructor in data type declaration"
  1180. EEND;
  1181. }
  1182. return c;
  1183. }
  1184. #if !TREX
  1185. static Void local noTREX(where)
  1186. String where; {
  1187. ERRMSG(row) "Attempt to use TREX records while parsing %s.\n", where ETHEN
  1188. ERRTEXT "(TREX is disabled in this build of Hugs)"
  1189. EEND;
  1190. }
  1191. #endif
  1192. #if !IPARAM
  1193. static Void local noIP(where)
  1194. String where; {
  1195. ERRMSG(row) "Attempt to use Implicit Parameters while parsing %s.\n", where ETHEN
  1196. ERRTEXT "(Implicit Parameters are disabled in this build of Hugs)"
  1197. EEND;
  1198. }
  1199. #endif
  1200. #if !MUDO
  1201. /***
  1202. Due to the way we implement this stuff, this function will actually
  1203. never be called. When MUDO is not defined, the lexer thinks that mdo
  1204. is just another identifier, and hence the MDO token is never returned
  1205. to the parser: consequently the mdo production is never reduced, making
  1206. this code unreachable. The alternative is to let the lexer to
  1207. recognize "mdo" all the time, but that's not Haskell compliant. In any
  1208. case we keep this function here, even if just for documentation purposes.
  1209. ***/
  1210. static Void local noMDo(where)
  1211. String where; {
  1212. ERRMSG(row) "Attempt to use MDO while parsing %s.\n", where ETHEN
  1213. ERRTEXT "(Recursive monadic bindings are disabled in this build of Hugs)"
  1214. EEND;
  1215. }
  1216. #endif
  1217. /*-------------------------------------------------------------------------*/