Mercurial > urweb

comparison src/urweb.grm @ 244:71bafe66dbe1

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Laconic -> Ur
author Adam Chlipala <adamc@hcoop.net>
date Sun, 31 Aug 2008 08:32:18 -0400
parents src/lacweb.grm@2b9dfaffb008
children e52243e20858
comparison
equal deleted inserted replaced
243:2b9dfaffb008 244:71bafe66dbe1
1 (* Copyright (c) 2008, Adam Chlipala
2 * All rights reserved.
3 *
4 * Redistribution and use in source and binary forms, with or without
5 * modification, are permitted provided that the following conditions are met:
6 *
7 * - Redistributions of source code must retain the above copyright notice,
8 * this list of conditions and the following disclaimer.
9 * - Redistributions in binary form must reproduce the above copyright notice,
10 * this list of conditions and the following disclaimer in the documentation
11 * and/or other materials provided with the distribution.
12 * - The names of contributors may not be used to endorse or promote products
13 * derived from this software without specific prior written permission.
14 *
15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
25 * POSSIBILITY OF SUCH DAMAGE.
26 *)
27
28 (* Grammar for Ur/Web programs *)
29
30 open Source
31
32 val s = ErrorMsg.spanOf
33 val dummy = ErrorMsg.dummySpan
34
35 fun capitalize "" = ""
36 | capitalize s = str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
37
38 fun entable t =
39 case #1 t of
40 TRecord c => c
41 | _ => t
42
43 datatype select_item =
44 Field of con * con
45 | Exp of con * exp
46
47 datatype select =
48 Star
49 | Items of select_item list
50
51 datatype group_item =
52 GField of con * con
53
54 fun eqTnames ((c1, _), (c2, _)) =
55 case (c1, c2) of
56 (CVar (ms1, x1), CVar (ms2, x2)) => ms1 = ms2 andalso x1 = x2
57 | (CName x1, CName x2) => x1 = x2
58 | _ => false
59
60 fun amend_select loc (si, (tabs, exps)) =
61 case si of
62 Field (tx, fx) =>
63 let
64 val c = (CRecord ([(fx, (CWild (KType, loc), loc))]), loc)
65
66 val (tabs, found) = ListUtil.foldlMap (fn ((tx', c'), found) =>
67 if eqTnames (tx, tx') then
68 ((tx', (CConcat (c, c'), loc)), true)
69 else
70 ((tx', c'), found))
71 false tabs
72 in
73 if found then
74 ()
75 else
76 ErrorMsg.errorAt loc "Select of field from unbound table";
77
78 (tabs, exps)
79 end
80 | Exp (c, e) => (tabs, (c, e) :: exps)
81
82 fun amend_group loc (gi, tabs) =
83 let
84 val (tx, c) = case gi of
85 GField (tx, fx) => (tx, (CRecord ([(fx, (CWild (KType, loc), loc))]), loc))
86
87 val (tabs, found) = ListUtil.foldlMap (fn ((tx', c'), found) =>
88 if eqTnames (tx, tx') then
89 ((tx', (CConcat (c, c'), loc)), true)
90 else
91 ((tx', c'), found))
92 false tabs
93 in
94 if found then
95 ()
96 else
97 ErrorMsg.errorAt loc "Select of field from unbound table";
98
99 tabs
100 end
101
102 fun sql_inject (v, t, loc) =
103 let
104 val e = (EApp ((EVar (["Basis"], "sql_inject"), loc), (t, loc)), loc)
105 in
106 (EApp (e, (v, loc)), loc)
107 end
108
109 fun sql_compare (oper, sqlexp1, sqlexp2, loc) =
110 let
111 val e = (EVar (["Basis"], "sql_comparison"), loc)
112 val e = (EApp (e, (EVar (["Basis"], "sql_" ^ oper), loc)), loc)
113 val e = (EApp (e, sqlexp1), loc)
114 in
115 (EApp (e, sqlexp2), loc)
116 end
117
118 fun sql_binary (oper, sqlexp1, sqlexp2, loc) =
119 let
120 val e = (EVar (["Basis"], "sql_binary"), loc)
121 val e = (EApp (e, (EVar (["Basis"], "sql_" ^ oper), loc)), loc)
122 val e = (EApp (e, sqlexp1), loc)
123 in
124 (EApp (e, sqlexp2), loc)
125 end
126
127 fun sql_unary (oper, sqlexp, loc) =
128 let
129 val e = (EVar (["Basis"], "sql_unary"), loc)
130 val e = (EApp (e, (EVar (["Basis"], "sql_" ^ oper), loc)), loc)
131 in
132 (EApp (e, sqlexp), loc)
133 end
134
135 fun sql_relop (oper, sqlexp1, sqlexp2, loc) =
136 let
137 val e = (EVar (["Basis"], "sql_relop"), loc)
138 val e = (EApp (e, (EVar (["Basis"], "sql_" ^ oper), loc)), loc)
139 val e = (EApp (e, sqlexp1), loc)
140 in
141 (EApp (e, sqlexp2), loc)
142 end
143
144 %%
145 %header (functor UrwebLrValsFn(structure Token : TOKEN))
146
147 %term
148 EOF
149 | STRING of string | INT of Int64.int | FLOAT of Real64.real
150 | SYMBOL of string | CSYMBOL of string
151 | LPAREN | RPAREN | LBRACK | RBRACK | LBRACE | RBRACE
152 | EQ | COMMA | COLON | DCOLON | TCOLON | DOT | HASH | UNDER | UNDERUNDER | BAR
153 | DIVIDE | DOTDOTDOT
154 | CON | LTYPE | VAL | REC | AND | FUN | FOLD | UNIT | KUNIT | CLASS
155 | DATATYPE | OF
156 | TYPE | NAME
157 | ARROW | LARROW | DARROW | STAR | SEMI
158 | FN | PLUSPLUS | MINUSMINUS | DOLLAR | TWIDDLE
159 | STRUCTURE | SIGNATURE | STRUCT | SIG | END | FUNCTOR | WHERE | EXTERN
160 | INCLUDE | OPEN | CONSTRAINT | CONSTRAINTS | EXPORT | TABLE
161 | CASE | IF | THEN | ELSE
162
163 | XML_BEGIN of string | XML_END
164 | NOTAGS of string
165 | BEGIN_TAG of string | END_TAG of string
166
167 | SELECT | FROM | AS | CWHERE | GROUP | ORDER | BY | HAVING
168 | UNION | INTERSECT | EXCEPT
169 | LIMIT | OFFSET | ALL
170 | TRUE | FALSE | CAND | OR | NOT
171 | COUNT | AVG | SUM | MIN | MAX
172 | NE | LT | LE | GT | GE
173
174 %nonterm
175 file of decl list
176 | decls of decl list
177 | decl of decl
178 | vali of string * con option * exp
179 | valis of (string * con option * exp) list
180 | copt of con option
181
182 | dargs of string list
183 | barOpt of unit
184 | dcons of (string * con option) list
185 | dcon of string * con option
186
187 | sgn of sgn
188 | sgntm of sgn
189 | sgi of sgn_item
190 | sgis of sgn_item list
191
192 | str of str
193
194 | kind of kind
195 | ktuple of kind list
196 | kcolon of explicitness
197 | kopt of kind option
198
199 | path of string list * string
200 | cpath of string list * string
201 | spath of str
202 | mpath of string list
203
204 | cexp of con
205 | capps of con
206 | cterm of con
207 | ctuple of con list
208 | ctuplev of con list
209 | ident of con
210 | idents of con list
211 | rcon of (con * con) list
212 | rconn of (con * con) list
213 | rcone of (con * con) list
214 | cargs of con * kind -> con * kind
215 | cargl of con * kind -> con * kind
216 | cargl2 of con * kind -> con * kind
217 | carg of con * kind -> con * kind
218 | cargp of con * kind -> con * kind
219
220 | eexp of exp
221 | eapps of exp
222 | eterm of exp
223 | etuple of exp list
224 | rexp of (con * exp) list
225 | xml of exp
226 | xmlOne of exp
227 | tag of string * exp
228 | tagHead of string * exp
229
230 | earg of exp * con -> exp * con
231 | eargp of exp * con -> exp * con
232 | eargs of exp * con -> exp * con
233 | eargl of exp * con -> exp * con
234 | eargl2 of exp * con -> exp * con
235
236 | branch of pat * exp
237 | branchs of (pat * exp) list
238 | pat of pat
239 | pterm of pat
240 | rpat of (string * pat) list * bool
241 | ptuple of pat list
242
243 | attrs of (con * exp) list
244 | attr of con * exp
245 | attrv of exp
246
247 | query of exp
248 | query1 of exp
249 | tables of (con * exp) list
250 | tname of con
251 | table of con * exp
252 | tident of con
253 | fident of con
254 | seli of select_item
255 | selis of select_item list
256 | select of select
257 | sqlexp of exp
258 | wopt of exp
259 | groupi of group_item
260 | groupis of group_item list
261 | gopt of group_item list option
262 | hopt of exp
263 | obopt of exp
264 | obexps of exp
265 | lopt of exp
266 | ofopt of exp
267 | sqlint of exp
268 | sqlagg of string
269
270
271 %verbose (* print summary of errors *)
272 %pos int (* positions *)
273 %start file
274 %pure
275 %eop EOF
276 %noshift EOF
277
278 %name Urweb
279
280 %right SEMI
281 %nonassoc LARROW
282 %nonassoc IF THEN ELSE
283 %nonassoc DARROW
284 %nonassoc COLON
285 %nonassoc DCOLON TCOLON
286 %left UNION INTERSECT EXCEPT
287 %right COMMA
288 %right OR
289 %right CAND
290 %nonassoc EQ NE LT LE GT GE
291 %right ARROW
292 %right PLUSPLUS MINUSMINUS
293 %right STAR
294 %left NOT
295 %nonassoc TWIDDLE
296 %nonassoc DOLLAR
297 %left DOT
298 %nonassoc LBRACE RBRACE
299
300 %%
301
302 file : decls (decls)
303 | SIG sgis ([(DSgn ("?", (SgnConst sgis, s (SIGleft, sgisright))),
304 s (SIGleft, sgisright))])
305
306 decls : ([])
307 | decl decls (decl :: decls)
308
309 decl : CON SYMBOL cargl2 kopt EQ cexp (let
310 val loc = s (CONleft, cexpright)
311
312 val k = Option.getOpt (kopt, (KWild, loc))
313 val (c, k) = cargl2 (cexp, k)
314 in
315 (DCon (SYMBOL, SOME k, c), loc)
316 end)
317 | LTYPE SYMBOL EQ cexp (DCon (SYMBOL, SOME (KType, s (LTYPEleft, cexpright)), cexp),
318 s (LTYPEleft, cexpright))
319 | DATATYPE SYMBOL dargs EQ barOpt dcons(DDatatype (SYMBOL, dargs, dcons), s (DATATYPEleft, dconsright))
320 | DATATYPE SYMBOL dargs EQ DATATYPE CSYMBOL DOT path
321 (case dargs of
322 [] => (DDatatypeImp (SYMBOL, CSYMBOL :: #1 path, #2 path), s (DATATYPEleft, pathright))
323 | _ => raise Fail "Arguments specified for imported datatype")
324 | VAL vali (DVal vali, s (VALleft, valiright))
325 | VAL REC valis (DValRec valis, s (VALleft, valisright))
326 | FUN valis (DValRec valis, s (FUNleft, valisright))
327
328 | SIGNATURE CSYMBOL EQ sgn (DSgn (CSYMBOL, sgn), s (SIGNATUREleft, sgnright))
329 | STRUCTURE CSYMBOL EQ str (DStr (CSYMBOL, NONE, str), s (STRUCTUREleft, strright))
330 | STRUCTURE CSYMBOL COLON sgn EQ str (DStr (CSYMBOL, SOME sgn, str), s (STRUCTUREleft, strright))
331 | FUNCTOR CSYMBOL LPAREN CSYMBOL COLON sgn RPAREN EQ str
332 (DStr (CSYMBOL1, NONE,
333 (StrFun (CSYMBOL2, sgn1, NONE, str), s (FUNCTORleft, strright))),
334 s (FUNCTORleft, strright))
335 | FUNCTOR CSYMBOL LPAREN CSYMBOL COLON sgn RPAREN COLON sgn EQ str
336 (DStr (CSYMBOL1, NONE,
337 (StrFun (CSYMBOL2, sgn1, SOME sgn2, str), s (FUNCTORleft, strright))),
338 s (FUNCTORleft, strright))
339 | EXTERN STRUCTURE CSYMBOL COLON sgn (DFfiStr (CSYMBOL, sgn), s (EXTERNleft, sgnright))
340 | OPEN mpath (case mpath of
341 [] => raise Fail "Impossible mpath parse [1]"
342 | m :: ms => (DOpen (m, ms), s (OPENleft, mpathright)))
343 | OPEN CONSTRAINTS mpath (case mpath of
344 [] => raise Fail "Impossible mpath parse [3]"
345 | m :: ms => (DOpenConstraints (m, ms), s (OPENleft, mpathright)))
346 | CONSTRAINT cterm TWIDDLE cterm (DConstraint (cterm1, cterm2), s (CONSTRAINTleft, ctermright))
347 | EXPORT spath (DExport spath, s (EXPORTleft, spathright))
348 | TABLE SYMBOL COLON cexp (DTable (SYMBOL, entable cexp), s (TABLEleft, cexpright))
349 | CLASS SYMBOL EQ cexp (DClass (SYMBOL, cexp), s (CLASSleft, cexpright))
350 | CLASS SYMBOL SYMBOL EQ cexp (let
351 val loc = s (CLASSleft, cexpright)
352 val k = (KType, loc)
353 val c = (CAbs (SYMBOL2, SOME k, cexp), loc)
354 in
355 (DClass (SYMBOL1, c), s (CLASSleft, cexpright))
356 end)
357
358 kopt : (NONE)
359 | DCOLON kind (SOME kind)
360
361 dargs : ([])
362 | SYMBOL dargs (SYMBOL :: dargs)
363
364 barOpt : ()
365 | BAR ()
366
367 dcons : dcon ([dcon])
368 | dcon BAR dcons (dcon :: dcons)
369
370 dcon : CSYMBOL (CSYMBOL, NONE)
371 | CSYMBOL OF cexp (CSYMBOL, SOME cexp)
372
373 vali : SYMBOL eargl2 copt EQ eexp (let
374 val loc = s (SYMBOLleft, eexpright)
375 val t = Option.getOpt (copt, (CWild (KType, loc), loc))
376
377 val (e, t) = eargl2 (eexp, t)
378 in
379 (SYMBOL, SOME t, e)
380 end)
381
382 copt : (NONE)
383 | COLON cexp (SOME cexp)
384
385 valis : vali ([vali])
386 | vali AND valis (vali :: valis)
387
388 sgn : sgntm (sgntm)
389 | FUNCTOR LPAREN CSYMBOL COLON sgn RPAREN COLON sgn
390 (SgnFun (CSYMBOL, sgn1, sgn2), s (FUNCTORleft, sgn2right))
391
392 sgntm : SIG sgis END (SgnConst sgis, s (SIGleft, ENDright))
393 | mpath (case mpath of
394 [] => raise Fail "Impossible mpath parse [2]"
395 | [x] => SgnVar x
396 | m :: ms => SgnProj (m,
397 List.take (ms, length ms - 1),
398 List.nth (ms, length ms - 1)),
399 s (mpathleft, mpathright))
400 | sgntm WHERE CON SYMBOL EQ cexp (SgnWhere (sgntm, SYMBOL, cexp), s (sgntmleft, cexpright))
401 | sgntm WHERE LTYPE SYMBOL EQ cexp(SgnWhere (sgntm, SYMBOL, cexp), s (sgntmleft, cexpright))
402 | LPAREN sgn RPAREN (sgn)
403
404 sgi : CON SYMBOL DCOLON kind (SgiConAbs (SYMBOL, kind), s (CONleft, kindright))
405 | LTYPE SYMBOL (SgiConAbs (SYMBOL, (KType, s (LTYPEleft, SYMBOLright))),
406 s (LTYPEleft, SYMBOLright))
407 | CON SYMBOL EQ cexp (SgiCon (SYMBOL, NONE, cexp), s (CONleft, cexpright))
408 | CON SYMBOL DCOLON kind EQ cexp (SgiCon (SYMBOL, SOME kind, cexp), s (CONleft, cexpright))
409 | LTYPE SYMBOL EQ cexp (SgiCon (SYMBOL, SOME (KType, s (LTYPEleft, cexpright)), cexp),
410 s (LTYPEleft, cexpright))
411 | DATATYPE SYMBOL dargs EQ barOpt dcons(SgiDatatype (SYMBOL, dargs, dcons), s (DATATYPEleft, dconsright))
412 | DATATYPE SYMBOL dargs EQ DATATYPE CSYMBOL DOT path
413 (case dargs of
414 [] => (SgiDatatypeImp (SYMBOL, CSYMBOL :: #1 path, #2 path), s (DATATYPEleft, pathright))
415 | _ => raise Fail "Arguments specified for imported datatype")
416 | VAL SYMBOL COLON cexp (SgiVal (SYMBOL, cexp), s (VALleft, cexpright))
417
418 | STRUCTURE CSYMBOL COLON sgn (SgiStr (CSYMBOL, sgn), s (STRUCTUREleft, sgnright))
419 | SIGNATURE CSYMBOL EQ sgn (SgiSgn (CSYMBOL, sgn), s (SIGNATUREleft, sgnright))
420 | FUNCTOR CSYMBOL LPAREN CSYMBOL COLON sgn RPAREN COLON sgn
421 (SgiStr (CSYMBOL1,
422 (SgnFun (CSYMBOL2, sgn1, sgn2), s (FUNCTORleft, sgn2right))),
423 s (FUNCTORleft, sgn2right))
424 | INCLUDE sgn (SgiInclude sgn, s (INCLUDEleft, sgnright))
425 | CONSTRAINT cterm TWIDDLE cterm (SgiConstraint (cterm1, cterm2), s (CONSTRAINTleft, ctermright))
426 | TABLE SYMBOL COLON cexp (SgiTable (SYMBOL, entable cexp), s (TABLEleft, cexpright))
427 | CLASS SYMBOL (SgiClassAbs SYMBOL, s (CLASSleft, SYMBOLright))
428 | CLASS SYMBOL EQ cexp (SgiClass (SYMBOL, cexp), s (CLASSleft, cexpright))
429 | CLASS SYMBOL SYMBOL EQ cexp (let
430 val loc = s (CLASSleft, cexpright)
431 val k = (KType, loc)
432 val c = (CAbs (SYMBOL2, SOME k, cexp), loc)
433 in
434 (SgiClass (SYMBOL1, c), s (CLASSleft, cexpright))
435 end)
436
437 sgis : ([])
438 | sgi sgis (sgi :: sgis)
439
440 str : STRUCT decls END (StrConst decls, s (STRUCTleft, ENDright))
441 | spath (spath)
442 | FUNCTOR LPAREN CSYMBOL COLON sgn RPAREN DARROW str
443 (StrFun (CSYMBOL, sgn, NONE, str), s (FUNCTORleft, strright))
444 | FUNCTOR LPAREN CSYMBOL COLON sgn RPAREN COLON sgn DARROW str
445 (StrFun (CSYMBOL, sgn1, SOME sgn2, str), s (FUNCTORleft, strright))
446 | spath LPAREN str RPAREN (StrApp (spath, str), s (spathleft, RPARENright))
447
448 spath : CSYMBOL (StrVar CSYMBOL, s (CSYMBOLleft, CSYMBOLright))
449 | spath DOT CSYMBOL (StrProj (spath, CSYMBOL), s (spathleft, CSYMBOLright))
450
451 kind : TYPE (KType, s (TYPEleft, TYPEright))
452 | NAME (KName, s (NAMEleft, NAMEright))
453 | LBRACE kind RBRACE (KRecord kind, s (LBRACEleft, RBRACEright))
454 | kind ARROW kind (KArrow (kind1, kind2), s (kind1left, kind2right))
455 | LPAREN kind RPAREN (#1 kind, s (LPARENleft, RPARENright))
456 | KUNIT (KUnit, s (KUNITleft, KUNITright))
457 | UNDERUNDER (KWild, s (UNDERUNDERleft, UNDERUNDERright))
458 | LPAREN ktuple RPAREN (KTuple ktuple, s (LPARENleft, RPARENright))
459
460 ktuple : kind STAR kind ([kind1, kind2])
461 | kind STAR ktuple (kind :: ktuple)
462
463 capps : cterm (cterm)
464 | capps cterm (CApp (capps, cterm), s (cappsleft, ctermright))
465
466 cexp : capps (capps)
467 | cexp ARROW cexp (TFun (cexp1, cexp2), s (cexp1left, cexp2right))
468 | SYMBOL kcolon kind ARROW cexp (TCFun (kcolon, SYMBOL, kind, cexp), s (SYMBOLleft, cexpright))
469
470 | cexp PLUSPLUS cexp (CConcat (cexp1, cexp2), s (cexp1left, cexp1right))
471
472 | FN cargs DARROW cexp (#1 (cargs (cexp, (KWild, s (FNleft, cexpright)))))
473 | cterm TWIDDLE cterm DARROW cexp(CDisjoint (cterm1, cterm2, cexp), s (cterm1left, cexpright))
474 | cterm TWIDDLE cterm ARROW cexp (TDisjoint (cterm1, cterm2, cexp), s (cterm1left, cexpright))
475
476 | LPAREN cexp RPAREN DCOLON kind (CAnnot (cexp, kind), s (LPARENleft, kindright))
477
478 | UNDER DCOLON kind (CWild kind, s (UNDERleft, UNDERright))
479 | ctuple (let
480 val loc = s (ctupleleft, ctupleright)
481 in
482 (TRecord (CRecord (ListUtil.mapi (fn (i, c) =>
483 ((CName (Int.toString (i + 1)), loc),
484 c)) ctuple),
485 loc), loc)
486 end)
487
488 kcolon : DCOLON (Explicit)
489 | TCOLON (Implicit)
490
491 cargs : carg (carg)
492 | cargl (cargl)
493
494 cargl : cargp cargp (cargp1 o cargp2)
495 | cargp cargl (cargp o cargl)
496
497 cargl2 : (fn x => x)
498 | cargp cargl2 (cargp o cargl2)
499
500 carg : SYMBOL DCOLON kind (fn (c, k) =>
501 let
502 val loc = s (SYMBOLleft, kindright)
503 in
504 ((CAbs (SYMBOL, SOME kind, c), loc),
505 (KArrow (kind, k), loc))
506 end)
507 | cargp (cargp)
508
509 cargp : SYMBOL (fn (c, k) =>
510 let
511 val loc = s (SYMBOLleft, SYMBOLright)
512 in
513 ((CAbs (SYMBOL, NONE, c), loc),
514 (KArrow ((KWild, loc), k), loc))
515 end)
516 | LPAREN SYMBOL DCOLON kind RPAREN (fn (c, k) =>
517 let
518 val loc = s (LPARENleft, RPARENright)
519 in
520 ((CAbs (SYMBOL, SOME kind, c), loc),
521 (KArrow (kind, k), loc))
522 end)
523
524 path : SYMBOL ([], SYMBOL)
525 | CSYMBOL DOT path (let val (ms, x) = path in (CSYMBOL :: ms, x) end)
526
527 cpath : CSYMBOL ([], CSYMBOL)
528 | CSYMBOL DOT cpath (let val (ms, x) = cpath in (CSYMBOL :: ms, x) end)
529
530 mpath : CSYMBOL ([CSYMBOL])
531 | CSYMBOL DOT mpath (CSYMBOL :: mpath)
532
533 cterm : LPAREN cexp RPAREN (#1 cexp, s (LPARENleft, RPARENright))
534 | LBRACK rcon RBRACK (CRecord rcon, s (LBRACKleft, RBRACKright))
535 | LBRACK rconn RBRACK (CRecord rconn, s (LBRACKleft, RBRACKright))
536 | LBRACE rcone RBRACE (TRecord (CRecord rcone, s (LBRACEleft, RBRACEright)),
537 s (LBRACEleft, RBRACEright))
538 | DOLLAR cterm (TRecord cterm, s (DOLLARleft, ctermright))
539 | HASH CSYMBOL (CName CSYMBOL, s (HASHleft, CSYMBOLright))
540 | HASH INT (CName (Int64.toString INT), s (HASHleft, INTright))
541
542 | path (CVar path, s (pathleft, pathright))
543 | path DOT INT (CProj ((CVar path, s (pathleft, pathright)), Int64.toInt INT),
544 s (pathleft, INTright))
545 | UNDER (CWild (KWild, s (UNDERleft, UNDERright)), s (UNDERleft, UNDERright))
546 | FOLD (CFold, s (FOLDleft, FOLDright))
547 | UNIT (CUnit, s (UNITleft, UNITright))
548 | LPAREN ctuplev RPAREN (CTuple ctuplev, s (LPARENleft, RPARENright))
549
550 ctuplev: cexp COMMA cexp ([cexp1, cexp2])
551 | cexp COMMA ctuplev (cexp :: ctuplev)
552
553 ctuple : capps STAR capps ([capps1, capps2])
554 | capps STAR ctuple (capps :: ctuple)
555
556 rcon : ([])
557 | ident EQ cexp ([(ident, cexp)])
558 | ident EQ cexp COMMA rcon ((ident, cexp) :: rcon)
559
560 rconn : ident ([(ident, (CUnit, s (identleft, identright)))])
561 | ident COMMA rconn ((ident, (CUnit, s (identleft, identright))) :: rconn)
562
563 rcone : ([])
564 | ident COLON cexp ([(ident, cexp)])
565 | ident COLON cexp COMMA rcone ((ident, cexp) :: rcone)
566
567 ident : CSYMBOL (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright))
568 | INT (CName (Int64.toString INT), s (INTleft, INTright))
569 | SYMBOL (CVar ([], SYMBOL), s (SYMBOLleft, SYMBOLright))
570
571 eapps : eterm (eterm)
572 | eapps eterm (EApp (eapps, eterm), s (eappsleft, etermright))
573 | eapps LBRACK cexp RBRACK (ECApp (eapps, cexp), s (eappsleft, RBRACKright))
574
575 eexp : eapps (eapps)
576 | FN eargs DARROW eexp (let
577 val loc = s (FNleft, eexpright)
578 in
579 #1 (eargs (eexp, (CWild (KType, loc), loc)))
580 end)
581 | LBRACK cterm TWIDDLE cterm RBRACK DARROW eexp(EDisjoint (cterm1, cterm2, eexp), s (LBRACKleft, RBRACKright))
582 | eexp COLON cexp (EAnnot (eexp, cexp), s (eexpleft, cexpright))
583 | eexp MINUSMINUS cexp (ECut (eexp, cexp), s (eexpleft, cexpright))
584 | CASE eexp OF barOpt branch branchs (ECase (eexp, branch :: branchs), s (CASEleft, branchsright))
585 | IF eexp THEN eexp ELSE eexp (let
586 val loc = s (IFleft, eexp3right)
587 in
588 (ECase (eexp1, [((PCon (["Basis"], "True", NONE), loc), eexp2),
589 ((PCon (["Basis"], "False", NONE), loc), eexp3)]), loc)
590 end)
591 | SYMBOL LARROW eexp SEMI eexp (let
592 val loc = s (SYMBOLleft, eexp2right)
593 val e = (EVar (["Basis"], "bind"), loc)
594 val e = (EApp (e, eexp1), loc)
595 in
596 (EApp (e, (EAbs (SYMBOL, NONE, eexp2), loc)), loc)
597 end)
598
599 eargs : earg (earg)
600 | eargl (eargl)
601
602 eargl : eargp eargp (eargp1 o eargp2)
603 | eargp eargl (eargp o eargl)
604
605 eargl2 : (fn x => x)
606 | eargp eargl2 (eargp o eargl2)
607
608 earg : SYMBOL kcolon kind (fn (e, t) =>
609 let
610 val loc = s (SYMBOLleft, kindright)
611 in
612 ((ECAbs (kcolon, SYMBOL, kind, e), loc),
613 (TCFun (kcolon, SYMBOL, kind, t), loc))
614 end)
615 | SYMBOL COLON cexp (fn (e, t) =>
616 let
617 val loc = s (SYMBOLleft, cexpright)
618 in
619 ((EAbs (SYMBOL, SOME cexp, e), loc),
620 (TFun (cexp, t), loc))
621 end)
622 | UNDER COLON cexp (fn (e, t) =>
623 let
624 val loc = s (UNDERleft, cexpright)
625 in
626 ((EAbs ("_", SOME cexp, e), loc),
627 (TFun (cexp, t), loc))
628 end)
629 | eargp (eargp)
630
631 eargp : SYMBOL (fn (e, t) =>
632 let
633 val loc = s (SYMBOLleft, SYMBOLright)
634 in
635 ((EAbs (SYMBOL, NONE, e), loc),
636 (TFun ((CWild (KType, loc), loc), t), loc))
637 end)
638 | UNIT (fn (e, t) =>
639 let
640 val loc = s (UNITleft, UNITright)
641 val t' = (TRecord (CRecord [], loc), loc)
642 in
643 ((EAbs ("_", SOME t', e), loc),
644 (TFun (t', t), loc))
645 end)
646 | UNDER (fn (e, t) =>
647 let
648 val loc = s (UNDERleft, UNDERright)
649 in
650 ((EAbs ("_", NONE, e), loc),
651 (TFun ((CWild (KType, loc), loc), t), loc))
652 end)
653 | LPAREN SYMBOL kcolon kind RPAREN(fn (e, t) =>
654 let
655 val loc = s (LPARENleft, RPARENright)
656 in
657 ((ECAbs (kcolon, SYMBOL, kind, e), loc),
658 (TCFun (kcolon, SYMBOL, kind, t), loc))
659 end)
660 | LPAREN SYMBOL COLON cexp RPAREN (fn (e, t) =>
661 let
662 val loc = s (LPARENleft, RPARENright)
663 in
664 ((EAbs (SYMBOL, SOME cexp, e), loc),
665 (TFun (cexp, t), loc))
666 end)
667 | LPAREN UNDER COLON cexp RPAREN (fn (e, t) =>
668 let
669 val loc = s (LPARENleft, RPARENright)
670 in
671 ((EAbs ("_", SOME cexp, e), loc),
672 (TFun (cexp, t), loc))
673 end)
674
675 eterm : LPAREN eexp RPAREN (#1 eexp, s (LPARENleft, RPARENright))
676 | LPAREN etuple RPAREN (let
677 val loc = s (LPARENleft, RPARENright)
678 in
679 (ERecord (ListUtil.mapi (fn (i, e) =>
680 ((CName (Int.toString (i + 1)), loc),
681 e)) etuple), loc)
682 end)
683
684 | path (EVar path, s (pathleft, pathright))
685 | cpath (EVar cpath, s (cpathleft, cpathright))
686 | LBRACE rexp RBRACE (ERecord rexp, s (LBRACEleft, RBRACEright))
687 | UNIT (ERecord [], s (UNITleft, UNITright))
688
689 | INT (EPrim (Prim.Int INT), s (INTleft, INTright))
690 | FLOAT (EPrim (Prim.Float FLOAT), s (FLOATleft, FLOATright))
691 | STRING (EPrim (Prim.String STRING), s (STRINGleft, STRINGright))
692
693 | path DOT idents (let
694 val loc = s (pathleft, identsright)
695 in
696 foldl (fn (ident, e) =>
697 (EField (e, ident), loc))
698 (EVar path, s (pathleft, pathright)) idents
699 end)
700 | FOLD (EFold, s (FOLDleft, FOLDright))
701
702 | XML_BEGIN xml XML_END (xml)
703 | XML_BEGIN XML_END (EApp ((EVar (["Basis"], "cdata"), s (XML_BEGINleft, XML_ENDright)),
704 (EPrim (Prim.String ""), s (XML_BEGINleft, XML_ENDright))),
705 s (XML_BEGINleft, XML_ENDright))
706 | LPAREN query RPAREN (query)
707 | UNDER (EWild, s (UNDERleft, UNDERright))
708
709 idents : ident ([ident])
710 | ident DOT idents (ident :: idents)
711
712 etuple : eexp COMMA eexp ([eexp1, eexp2])
713 | eexp COMMA etuple (eexp :: etuple)
714
715 branch : pat DARROW eexp (pat, eexp)
716
717 branchs: ([])
718 | BAR branch branchs (branch :: branchs)
719
720 pat : pterm (pterm)
721 | cpath pterm (PCon (#1 cpath, #2 cpath, SOME pterm), s (cpathleft, ptermright))
722
723 pterm : SYMBOL (PVar SYMBOL, s (SYMBOLleft, SYMBOLright))
724 | cpath (PCon (#1 cpath, #2 cpath, NONE), s (cpathleft, cpathright))
725 | UNDER (PWild, s (UNDERleft, UNDERright))
726 | INT (PPrim (Prim.Int INT), s (INTleft, INTright))
727 | STRING (PPrim (Prim.String STRING), s (STRINGleft, STRINGright))
728 | LPAREN pat RPAREN (pat)
729 | LBRACE RBRACE (PRecord ([], false), s (LBRACEleft, RBRACEright))
730 | UNIT (PRecord ([], false), s (UNITleft, UNITright))
731 | LBRACE rpat RBRACE (PRecord rpat, s (LBRACEleft, RBRACEright))
732 | LPAREN ptuple RPAREN (PRecord (ListUtil.mapi (fn (i, p) => (Int.toString (i + 1), p)) ptuple,
733 false),
734 s (LPARENleft, RPARENright))
735
736 rpat : CSYMBOL EQ pat ([(CSYMBOL, pat)], false)
737 | INT EQ pat ([(Int64.toString INT, pat)], false)
738 | DOTDOTDOT ([], true)
739 | CSYMBOL EQ pat COMMA rpat ((CSYMBOL, pat) :: #1 rpat, #2 rpat)
740 | INT EQ pat COMMA rpat ((Int64.toString INT, pat) :: #1 rpat, #2 rpat)
741
742 ptuple : pat COMMA pat ([pat1, pat2])
743 | pat COMMA ptuple (pat :: ptuple)
744
745 rexp : ([])
746 | ident EQ eexp ([(ident, eexp)])
747 | ident EQ eexp COMMA rexp ((ident, eexp) :: rexp)
748
749 xml : xmlOne xml (let
750 val pos = s (xmlOneleft, xmlright)
751 in
752 (EApp ((EApp (
753 (EVar (["Basis"], "join"), pos),
754 xmlOne), pos),
755 xml), pos)
756 end)
757 | xmlOne (xmlOne)
758
759 xmlOne : NOTAGS (EApp ((EVar (["Basis"], "cdata"), s (NOTAGSleft, NOTAGSright)),
760 (EPrim (Prim.String NOTAGS), s (NOTAGSleft, NOTAGSright))),
761 s (NOTAGSleft, NOTAGSright))
762 | tag DIVIDE GT (let
763 val pos = s (tagleft, GTright)
764 in
765 (EApp (#2 tag,
766 (EApp ((EVar (["Basis"], "cdata"), pos),
767 (EPrim (Prim.String ""), pos)),
768 pos)), pos)
769 end)
770
771 | tag GT xml END_TAG (let
772 val pos = s (tagleft, GTright)
773 in
774 if #1 tag = END_TAG then
775 if END_TAG = "lform" then
776 (EApp ((EVar (["Basis"], "lform"), pos),
777 xml), pos)
778 else
779 (EApp (#2 tag, xml), pos)
780 else
781 (ErrorMsg.errorAt pos "Begin and end tags don't match.";
782 (EFold, pos))
783 end)
784 | LBRACE eexp RBRACE (eexp)
785
786 tag : tagHead attrs (let
787 val pos = s (tagHeadleft, attrsright)
788 in
789 (#1 tagHead,
790 (EApp ((EApp ((EVar (["Basis"], "tag"), pos),
791 (ERecord attrs, pos)), pos),
792 (EApp (#2 tagHead,
793 (ERecord [], pos)), pos)),
794 pos))
795 end)
796
797 tagHead: BEGIN_TAG (let
798 val pos = s (BEGIN_TAGleft, BEGIN_TAGright)
799 in
800 (BEGIN_TAG,
801 (EVar ([], BEGIN_TAG), pos))
802 end)
803 | tagHead LBRACE cexp RBRACE (#1 tagHead, (ECApp (#2 tagHead, cexp), s (tagHeadleft, RBRACEright)))
804
805 attrs : ([])
806 | attr attrs (attr :: attrs)
807
808 attr : SYMBOL EQ attrv ((CName (capitalize SYMBOL), s (SYMBOLleft, SYMBOLright)), attrv)
809
810 attrv : INT (EPrim (Prim.Int INT), s (INTleft, INTright))
811 | FLOAT (EPrim (Prim.Float FLOAT), s (FLOATleft, FLOATright))
812 | STRING (EPrim (Prim.String STRING), s (STRINGleft, STRINGright))
813 | LBRACE eexp RBRACE (eexp)
814
815 query : query1 obopt lopt ofopt (let
816 val loc = s (query1left, query1right)
817
818 val re = (ERecord [((CName "Rows", loc),
819 query1),
820 ((CName "OrderBy", loc),
821 obopt),
822 ((CName "Limit", loc),
823 lopt),
824 ((CName "Offset", loc),
825 ofopt)], loc)
826 in
827 (EApp ((EVar (["Basis"], "sql_query"), loc), re), loc)
828 end)
829
830 query1 : SELECT select FROM tables wopt gopt hopt
831 (let
832 val loc = s (SELECTleft, tablesright)
833
834 val (sel, exps) =
835 case select of
836 Star => (map (fn (nm, _) =>
837 (nm, (CTuple [(CWild (KRecord (KType, loc), loc),
838 loc),
839 (CRecord [], loc)],
840 loc))) tables,
841 [])
842 | Items sis =>
843 let
844 val tabs = map (fn (nm, _) => (nm, (CRecord [], loc))) tables
845 val (tabs, exps) = foldl (amend_select loc) (tabs, []) sis
846 in
847 (map (fn (nm, c) => (nm,
848 (CTuple [c,
849 (CWild (KRecord (KType, loc), loc),
850 loc)], loc))) tabs,
851 exps)
852 end
853
854 val sel = (CRecord sel, loc)
855
856 val grp = case gopt of
857 NONE => (ECApp ((EVar (["Basis"], "sql_subset_all"), loc),
858 (CWild (KRecord (KRecord (KType, loc), loc),
859 loc), loc)), loc)
860 | SOME gis =>
861 let
862 val tabs = map (fn (nm, _) =>
863 (nm, (CRecord [], loc))) tables
864 val tabs = foldl (amend_group loc) tabs gis
865
866 val tabs = map (fn (nm, c) =>
867 (nm,
868 (CTuple [c,
869 (CWild (KRecord (KType, loc),
870 loc),
871 loc)], loc))) tabs
872 in
873 (ECApp ((EVar (["Basis"], "sql_subset"), loc),
874 (CRecord tabs, loc)), loc)
875 end
876
877 val e = (EVar (["Basis"], "sql_query1"), loc)
878 val re = (ERecord [((CName "From", loc),
879 (ERecord tables, loc)),
880 ((CName "Where", loc),
881 wopt),
882 ((CName "GroupBy", loc),
883 grp),
884 ((CName "Having", loc),
885 hopt),
886 ((CName "SelectFields", loc),
887 (ECApp ((EVar (["Basis"], "sql_subset"), loc),
888 sel), loc)),
889 ((CName "SelectExps", loc),
890 (ERecord exps, loc))], loc)
891
892 val e = (EApp (e, re), loc)
893 in
894 e
895 end)
896 | query1 UNION query1 (sql_relop ("union", query11, query12, s (query11left, query12right)))
897 | query1 INTERSECT query1 (sql_relop ("intersect", query11, query12, s (query11left, query12right)))
898 | query1 EXCEPT query1 (sql_relop ("except", query11, query12, s (query11left, query12right)))
899
900 tables : table ([table])
901 | table COMMA tables (table :: tables)
902
903 tname : CSYMBOL (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright))
904 | LBRACE cexp RBRACE (cexp)
905
906 table : SYMBOL ((CName (capitalize SYMBOL), s (SYMBOLleft, SYMBOLright)),
907 (EVar ([], SYMBOL), s (SYMBOLleft, SYMBOLright)))
908 | SYMBOL AS tname (tname, (EVar ([], SYMBOL), s (SYMBOLleft, SYMBOLright)))
909 | LBRACE LBRACE eexp RBRACE RBRACE AS tname (tname, eexp)
910
911 tident : SYMBOL (CName (capitalize SYMBOL), s (SYMBOLleft, SYMBOLright))
912 | CSYMBOL (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright))
913 | LBRACE LBRACE cexp RBRACE RBRACE (cexp)
914
915 fident : CSYMBOL (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright))
916 | LBRACE cexp RBRACE (cexp)
917
918 seli : tident DOT fident (Field (tident, fident))
919 | sqlexp AS fident (Exp (fident, sqlexp))
920
921 selis : seli ([seli])
922 | seli COMMA selis (seli :: selis)
923
924 select : STAR (Star)
925 | selis (Items selis)
926
927 sqlexp : TRUE (sql_inject (EVar (["Basis"], "True"),
928 EVar (["Basis"], "sql_bool"),
929 s (TRUEleft, TRUEright)))
930 | FALSE (sql_inject (EVar (["Basis"], "False"),
931 EVar (["Basis"], "sql_bool"),
932 s (FALSEleft, FALSEright)))
933
934 | INT (sql_inject (EPrim (Prim.Int INT),
935 EVar (["Basis"], "sql_int"),
936 s (INTleft, INTright)))
937 | FLOAT (sql_inject (EPrim (Prim.Float FLOAT),
938 EVar (["Basis"], "sql_float"),
939 s (FLOATleft, FLOATright)))
940 | STRING (sql_inject (EPrim (Prim.String STRING),
941 EVar (["Basis"], "sql_string"),
942 s (STRINGleft, STRINGright)))
943
944 | tident DOT fident (let
945 val loc = s (tidentleft, fidentright)
946 val e = (EVar (["Basis"], "sql_field"), loc)
947 val e = (ECApp (e, tident), loc)
948 in
949 (ECApp (e, fident), loc)
950 end)
951 | CSYMBOL (let
952 val loc = s (CSYMBOLleft, CSYMBOLright)
953 val e = (EVar (["Basis"], "sql_exp"), loc)
954 in
955 (ECApp (e, (CName CSYMBOL, loc)), loc)
956 end)
957
958 | sqlexp EQ sqlexp (sql_compare ("eq", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
959 | sqlexp NE sqlexp (sql_compare ("ne", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
960 | sqlexp LT sqlexp (sql_compare ("lt", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
961 | sqlexp LE sqlexp (sql_compare ("le", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
962 | sqlexp GT sqlexp (sql_compare ("gt", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
963 | sqlexp GE sqlexp (sql_compare ("ge", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
964
965 | sqlexp CAND sqlexp (sql_binary ("and", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
966 | sqlexp OR sqlexp (sql_binary ("or", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
967 | NOT sqlexp (sql_unary ("not", sqlexp, s (NOTleft, sqlexpright)))
968
969 | LBRACE eexp RBRACE (sql_inject (#1 eexp,
970 EWild,
971 s (LBRACEleft, RBRACEright)))
972 | LPAREN sqlexp RPAREN (sqlexp)
973
974 | COUNT LPAREN STAR RPAREN (let
975 val loc = s (COUNTleft, RPARENright)
976 in
977 (EApp ((EVar (["Basis"], "sql_count"), loc),
978 (ERecord [], loc)), loc)
979 end)
980 | sqlagg LPAREN sqlexp RPAREN (let
981 val loc = s (sqlaggleft, RPARENright)
982
983 val e = (EApp ((EVar (["Basis"], "sql_" ^ sqlagg), loc),
984 (EWild, loc)), loc)
985 val e = (EApp ((EVar (["Basis"], "sql_aggregate"), loc),
986 e), loc)
987 in
988 (EApp (e, sqlexp), loc)
989 end)
990
991 wopt : (sql_inject (EVar (["Basis"], "True"),
992 EVar (["Basis"], "sql_bool"),
993 dummy))
994 | CWHERE sqlexp (sqlexp)
995
996 groupi : tident DOT fident (GField (tident, fident))
997
998 groupis: groupi ([groupi])
999 | groupi COMMA groupis (groupi :: groupis)
1000
1001 gopt : (NONE)
1002 | GROUP BY groupis (SOME groupis)
1003
1004 hopt : (sql_inject (EVar (["Basis"], "True"),
1005 EVar (["Basis"], "sql_bool"),
1006 dummy))
1007 | HAVING sqlexp (sqlexp)
1008
1009 obopt : (ECApp ((EVar (["Basis"], "sql_order_by_Nil"), dummy),
1010 (CWild (KRecord (KType, dummy), dummy), dummy)),
1011 dummy)
1012 | ORDER BY obexps (obexps)
1013
1014 obexps : sqlexp (let
1015 val loc = s (sqlexpleft, sqlexpright)
1016
1017 val e' = (ECApp ((EVar (["Basis"], "sql_order_by_Nil"), loc),
1018 (CWild (KRecord (KType, loc), loc), loc)),
1019 loc)
1020 val e = (EApp ((EVar (["Basis"], "sql_order_by_Cons"), loc),
1021 sqlexp), loc)
1022 in
1023 (EApp (e, e'), loc)
1024 end)
1025 | sqlexp COMMA obexps (let
1026 val loc = s (sqlexpleft, obexpsright)
1027
1028 val e = (EApp ((EVar (["Basis"], "sql_order_by_Cons"), loc),
1029 sqlexp), loc)
1030 in
1031 (EApp (e, obexps), loc)
1032 end)
1033
1034 lopt : (EVar (["Basis"], "sql_no_limit"), dummy)
1035 | LIMIT ALL (EVar (["Basis"], "sql_no_limit"), dummy)
1036 | LIMIT sqlint (let
1037 val loc = s (LIMITleft, sqlintright)
1038 in
1039 (EApp ((EVar (["Basis"], "sql_limit"), loc), sqlint), loc)
1040 end)
1041
1042 ofopt : (EVar (["Basis"], "sql_no_offset"), dummy)
1043 | OFFSET sqlint (let
1044 val loc = s (OFFSETleft, sqlintright)
1045 in
1046 (EApp ((EVar (["Basis"], "sql_offset"), loc), sqlint), loc)
1047 end)
1048
1049 sqlint : INT (EPrim (Prim.Int INT), s (INTleft, INTright))
1050 | LBRACE eexp RBRACE (eexp)
1051
1052 sqlagg : AVG ("avg")
1053 | SUM ("sum")
1054 | MIN ("min")
1055 | MAX ("max")