adamc@1191
|
1 (* Copyright (c) 2008-2010, Adam Chlipala
|
adamc@1
|
2 * All rights reserved.
|
adamc@1
|
3 *
|
adamc@1
|
4 * Redistribution and use in source and binary forms, with or without
|
adamc@1
|
5 * modification, are permitted provided that the following conditions are met:
|
adamc@1
|
6 *
|
adamc@1
|
7 * - Redistributions of source code must retain the above copyright notice,
|
adamc@1
|
8 * this list of conditions and the following disclaimer.
|
adamc@1
|
9 * - Redistributions in binary form must reproduce the above copyright notice,
|
adamc@1
|
10 * this list of conditions and the following disclaimer in the documentation
|
adamc@1
|
11 * and/or other materials provided with the distribution.
|
adamc@1
|
12 * - The names of contributors may not be used to endorse or promote products
|
adamc@1
|
13 * derived from this software without specific prior written permission.
|
adamc@1
|
14 *
|
adamc@339
|
15 * THIS SOFTARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
|
adamc@1
|
16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
|
adamc@1
|
17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
adamc@1
|
18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
|
adamc@1
|
19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
adamc@1
|
20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
adamc@1
|
21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
adamc@1
|
22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
adamc@1
|
23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
adamc@1
|
24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
adamc@1
|
25 * POSSIBILITY OF SUCH DAMAGE.
|
adamc@1
|
26 *)
|
adamc@1
|
27
|
adamc@244
|
28 (* Grammar for Ur/Web programs *)
|
adamc@1
|
29
|
adamc@4
|
30 open Source
|
adamc@1
|
31
|
adamc@1
|
32 val s = ErrorMsg.spanOf
|
adamc@230
|
33 val dummy = ErrorMsg.dummySpan
|
adamc@1
|
34
|
adamc@204
|
35 fun capitalize "" = ""
|
adamc@204
|
36 | capitalize s = str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
|
adamc@104
|
37
|
adamc@203
|
38 fun entable t =
|
adamc@203
|
39 case #1 t of
|
adamc@203
|
40 TRecord c => c
|
adamc@203
|
41 | _ => t
|
adamc@203
|
42
|
adamc@207
|
43 datatype select_item =
|
adamc@207
|
44 Field of con * con
|
adamc@1194
|
45 | Exp of con option * exp
|
adamc@341
|
46 | Fields of con * con
|
adamc@207
|
47
|
adamc@207
|
48 datatype select =
|
adamc@207
|
49 Star
|
adamc@207
|
50 | Items of select_item list
|
adamc@207
|
51
|
adamc@226
|
52 datatype group_item =
|
adamc@226
|
53 GField of con * con
|
adamc@226
|
54
|
adamc@207
|
55 fun eqTnames ((c1, _), (c2, _)) =
|
adamc@207
|
56 case (c1, c2) of
|
adamc@207
|
57 (CVar (ms1, x1), CVar (ms2, x2)) => ms1 = ms2 andalso x1 = x2
|
adamc@207
|
58 | (CName x1, CName x2) => x1 = x2
|
adamc@207
|
59 | _ => false
|
adamc@207
|
60
|
adamc@1194
|
61 fun amend_select loc (si, (count, tabs, exps)) =
|
adamc@233
|
62 case si of
|
adamc@233
|
63 Field (tx, fx) =>
|
adamc@233
|
64 let
|
adamc@233
|
65 val c = (CRecord ([(fx, (CWild (KType, loc), loc))]), loc)
|
adamc@207
|
66
|
adamc@233
|
67 val (tabs, found) = ListUtil.foldlMap (fn ((tx', c'), found) =>
|
adamc@233
|
68 if eqTnames (tx, tx') then
|
adamc@233
|
69 ((tx', (CConcat (c, c'), loc)), true)
|
adamc@233
|
70 else
|
adamc@233
|
71 ((tx', c'), found))
|
adamc@233
|
72 false tabs
|
adamc@233
|
73 in
|
adamc@233
|
74 if found then
|
adamc@233
|
75 ()
|
adamc@233
|
76 else
|
adamc@233
|
77 ErrorMsg.errorAt loc "Select of field from unbound table";
|
adamc@233
|
78
|
adamc@1194
|
79 (count, tabs, exps)
|
adamc@233
|
80 end
|
adamc@341
|
81 | Fields (tx, fs) =>
|
adamc@341
|
82 let
|
adamc@341
|
83 val (tabs, found) = ListUtil.foldlMap (fn ((tx', c'), found) =>
|
adamc@341
|
84 if eqTnames (tx, tx') then
|
adamc@341
|
85 ((tx', (CConcat (fs, c'), loc)), true)
|
adamc@341
|
86 else
|
adamc@341
|
87 ((tx', c'), found))
|
adamc@341
|
88 false tabs
|
adamc@341
|
89 in
|
adamc@341
|
90 if found then
|
adamc@341
|
91 ()
|
adamc@341
|
92 else
|
adamc@341
|
93 ErrorMsg.errorAt loc "Select of field from unbound table";
|
adamc@341
|
94
|
adamc@1194
|
95 (count, tabs, exps)
|
adamc@341
|
96 end
|
adamc@1194
|
97 | Exp (SOME c, e) => (count, tabs, (c, e) :: exps)
|
adamc@1194
|
98 | Exp (NONE, e) => (count+1, tabs, ((CName (Int.toString count), loc), e) :: exps)
|
adamc@207
|
99
|
adamc@226
|
100 fun amend_group loc (gi, tabs) =
|
adamc@226
|
101 let
|
adamc@226
|
102 val (tx, c) = case gi of
|
adamc@226
|
103 GField (tx, fx) => (tx, (CRecord ([(fx, (CWild (KType, loc), loc))]), loc))
|
adamc@226
|
104
|
adamc@226
|
105 val (tabs, found) = ListUtil.foldlMap (fn ((tx', c'), found) =>
|
adamc@226
|
106 if eqTnames (tx, tx') then
|
adamc@226
|
107 ((tx', (CConcat (c, c'), loc)), true)
|
adamc@226
|
108 else
|
adamc@226
|
109 ((tx', c'), found))
|
adamc@226
|
110 false tabs
|
adamc@226
|
111 in
|
adamc@226
|
112 if found then
|
adamc@226
|
113 ()
|
adamc@226
|
114 else
|
adamc@226
|
115 ErrorMsg.errorAt loc "Select of field from unbound table";
|
adamc@226
|
116
|
adamc@226
|
117 tabs
|
adamc@226
|
118 end
|
adamc@226
|
119
|
adamc@403
|
120 fun sql_inject (v, loc) =
|
adamc@403
|
121 (EApp ((EVar (["Basis"], "sql_inject", Infer), loc), (v, loc)), loc)
|
adamc@209
|
122
|
adamc@220
|
123 fun sql_binary (oper, sqlexp1, sqlexp2, loc) =
|
adamc@220
|
124 let
|
adamc@403
|
125 val e = (EVar (["Basis"], "sql_binary", Infer), loc)
|
adamc@403
|
126 val e = (EApp (e, (EVar (["Basis"], "sql_" ^ oper, Infer), loc)), loc)
|
adamc@220
|
127 val e = (EApp (e, sqlexp1), loc)
|
adamc@220
|
128 in
|
adamc@220
|
129 (EApp (e, sqlexp2), loc)
|
adamc@220
|
130 end
|
adamc@220
|
131
|
adamc@220
|
132 fun sql_unary (oper, sqlexp, loc) =
|
adamc@220
|
133 let
|
adamc@403
|
134 val e = (EVar (["Basis"], "sql_unary", Infer), loc)
|
adamc@403
|
135 val e = (EApp (e, (EVar (["Basis"], "sql_" ^ oper, Infer), loc)), loc)
|
adamc@220
|
136 in
|
adamc@220
|
137 (EApp (e, sqlexp), loc)
|
adamc@219
|
138 end
|
adamc@219
|
139
|
adamc@229
|
140 fun sql_relop (oper, sqlexp1, sqlexp2, loc) =
|
adamc@229
|
141 let
|
adamc@403
|
142 val e = (EVar (["Basis"], "sql_relop", Infer), loc)
|
adamc@403
|
143 val e = (EApp (e, (EVar (["Basis"], "sql_" ^ oper, Infer), loc)), loc)
|
adamc@229
|
144 val e = (EApp (e, sqlexp1), loc)
|
adamc@229
|
145 in
|
adamc@229
|
146 (EApp (e, sqlexp2), loc)
|
adamc@229
|
147 end
|
adamc@229
|
148
|
adamc@441
|
149 fun sql_nfunc (oper, loc) =
|
adamc@441
|
150 let
|
adamc@441
|
151 val e = (EVar (["Basis"], "sql_nfunc", Infer), loc)
|
adamc@441
|
152 in
|
adamc@441
|
153 (EApp (e, (EVar (["Basis"], "sql_" ^ oper, Infer), loc)), loc)
|
adamc@441
|
154 end
|
adamc@441
|
155
|
adamc@389
|
156 fun native_unop (oper, e1, loc) =
|
adamc@389
|
157 let
|
adamc@403
|
158 val e = (EVar (["Basis"], oper, Infer), loc)
|
adamc@389
|
159 in
|
adamc@389
|
160 (EApp (e, e1), loc)
|
adamc@389
|
161 end
|
adamc@389
|
162
|
adamc@256
|
163 fun native_op (oper, e1, e2, loc) =
|
adamc@256
|
164 let
|
adamc@403
|
165 val e = (EVar (["Basis"], oper, Infer), loc)
|
adamc@256
|
166 val e = (EApp (e, e1), loc)
|
adamc@256
|
167 in
|
adamc@256
|
168 (EApp (e, e2), loc)
|
adamc@256
|
169 end
|
adamc@256
|
170
|
adamc@310
|
171 val inDml = ref false
|
adamc@310
|
172
|
adamc@325
|
173 fun tagIn bt =
|
adamc@325
|
174 case bt of
|
adamc@325
|
175 "table" => "tabl"
|
adamc@325
|
176 | _ => bt
|
adamc@325
|
177
|
adamc@709
|
178 datatype prop_kind = Delete | Update
|
adamc@709
|
179
|
adamc@721
|
180 datatype attr = Class of exp | Normal of con * exp
|
adamc@721
|
181
|
adamc@822
|
182 fun patType loc (p : pat) =
|
adamc@822
|
183 case #1 p of
|
adamc@822
|
184 PAnnot (_, t) => t
|
adamc@822
|
185 | _ => (CWild (KType, loc), loc)
|
adamc@822
|
186
|
adamc@1
|
187 %%
|
adamc@244
|
188 %header (functor UrwebLrValsFn(structure Token : TOKEN))
|
adamc@1
|
189
|
adamc@1
|
190 %term
|
adamc@1
|
191 EOF
|
adamc@821
|
192 | STRING of string | INT of Int64.int | FLOAT of Real64.real | CHAR of char
|
adamc@1
|
193 | SYMBOL of string | CSYMBOL of string
|
adamc@1
|
194 | LPAREN | RPAREN | LBRACK | RBRACK | LBRACE | RBRACE
|
adamc@156
|
195 | EQ | COMMA | COLON | DCOLON | TCOLON | DOT | HASH | UNDER | UNDERUNDER | BAR
|
adamc@403
|
196 | PLUS | MINUS | DIVIDE | DOTDOTDOT | MOD | AT
|
adamc@623
|
197 | CON | LTYPE | VAL | REC | AND | FUN | MAP | UNIT | KUNIT | CLASS
|
adamc@156
|
198 | DATATYPE | OF
|
adamc@7
|
199 | TYPE | NAME
|
adamc@629
|
200 | ARROW | LARROW | DARROW | STAR | SEMI | KARROW | DKARROW | BANG
|
adamc@674
|
201 | FN | PLUSPLUS | MINUSMINUS | MINUSMINUSMINUS | DOLLAR | TWIDDLE | CARET
|
adamc@446
|
202 | LET | IN
|
adamc@1071
|
203 | STRUCTURE | SIGNATURE | STRUCT | SIG | END | FUNCTOR | WHERE | EXTERN | SQL | SELECT1
|
adamc@754
|
204 | INCLUDE | OPEN | CONSTRAINT | CONSTRAINTS | EXPORT | TABLE | SEQUENCE | VIEW
|
adamc@1199
|
205 | COOKIE | STYLE | TASK | POLICY
|
adamc@842
|
206 | CASE | IF | THEN | ELSE | ANDALSO | ORELSE
|
adamc@1
|
207
|
adamc@360
|
208 | XML_BEGIN of string | XML_END | XML_BEGIN_END of string
|
adamc@91
|
209 | NOTAGS of string
|
adamc@91
|
210 | BEGIN_TAG of string | END_TAG of string
|
adamc@91
|
211
|
adamc@993
|
212 | SELECT | DISTINCT | FROM | AS | CWHERE | GROUP | ORDER | BY | HAVING
|
adamc@229
|
213 | UNION | INTERSECT | EXCEPT
|
adamc@232
|
214 | LIMIT | OFFSET | ALL
|
adamc@220
|
215 | TRUE | FALSE | CAND | OR | NOT
|
adamc@236
|
216 | COUNT | AVG | SUM | MIN | MAX
|
adamc@268
|
217 | ASC | DESC
|
adamc@470
|
218 | INSERT | INTO | VALUES | UPDATE | SET | DELETE | NULL | IS
|
adamc@441
|
219 | CURRENT_TIMESTAMP
|
adamc@219
|
220 | NE | LT | LE | GT | GE
|
adamc@714
|
221 | CCONSTRAINT | UNIQUE | CHECK | PRIMARY | FOREIGN | KEY | ON | NO | ACTION | RESTRICT | CASCADE | REFERENCES
|
adamc@751
|
222 | JOIN | INNER | CROSS | OUTER | LEFT | RIGHT | FULL
|
adamc@204
|
223
|
adamc@30
|
224 %nonterm
|
adamc@1
|
225 file of decl list
|
adamc@1
|
226 | decls of decl list
|
adamc@325
|
227 | decl of decl list
|
adamc@123
|
228 | vali of string * con option * exp
|
adamc@123
|
229 | valis of (string * con option * exp) list
|
adamc@242
|
230 | copt of con option
|
adamc@1
|
231
|
adamc@191
|
232 | dargs of string list
|
adamc@156
|
233 | barOpt of unit
|
adamc@156
|
234 | dcons of (string * con option) list
|
adamc@805
|
235 | dtype of string * string list * (string * con option) list
|
adamc@805
|
236 | dtypes of (string * string list * (string * con option) list) list
|
adamc@156
|
237 | dcon of string * con option
|
adamc@156
|
238
|
adamc@707
|
239 | pkopt of exp
|
adamc@707
|
240 | commaOpt of unit
|
adamc@707
|
241
|
adamc@704
|
242 | cst of exp
|
adamc@704
|
243 | csts of exp
|
adamc@704
|
244 | cstopt of exp
|
adamc@704
|
245
|
adamc@1001
|
246 | ckl of (string * kind option) list
|
adamc@1001
|
247
|
adamc@709
|
248 | pmode of prop_kind * exp
|
adamc@709
|
249 | pkind of prop_kind
|
adamc@709
|
250 | prule of exp
|
adamc@709
|
251 | pmodes of (prop_kind * exp) list
|
adamc@709
|
252
|
adamc@30
|
253 | sgn of sgn
|
adamc@42
|
254 | sgntm of sgn
|
adamc@30
|
255 | sgi of sgn_item
|
adamc@30
|
256 | sgis of sgn_item list
|
adamc@30
|
257
|
adamc@30
|
258 | str of str
|
adamc@30
|
259
|
adamc@1
|
260 | kind of kind
|
adamc@207
|
261 | ktuple of kind list
|
adamc@1
|
262 | kcolon of explicitness
|
adamc@240
|
263 | kopt of kind option
|
adamc@1
|
264
|
adamc@34
|
265 | path of string list * string
|
adamc@156
|
266 | cpath of string list * string
|
adamc@34
|
267 | spath of str
|
adamc@59
|
268 | mpath of string list
|
adamc@34
|
269
|
adamc@1
|
270 | cexp of con
|
adamc@1
|
271 | capps of con
|
adamc@1
|
272 | cterm of con
|
adamc@195
|
273 | ctuple of con list
|
adamc@207
|
274 | ctuplev of con list
|
adamc@1
|
275 | ident of con
|
adamc@200
|
276 | idents of con list
|
adamc@1
|
277 | rcon of (con * con) list
|
adamc@83
|
278 | rconn of (con * con) list
|
adamc@1
|
279 | rcone of (con * con) list
|
adamc@239
|
280 | cargs of con * kind -> con * kind
|
adamc@239
|
281 | cargl of con * kind -> con * kind
|
adamc@240
|
282 | cargl2 of con * kind -> con * kind
|
adamc@239
|
283 | carg of con * kind -> con * kind
|
adamc@239
|
284 | cargp of con * kind -> con * kind
|
adamc@1
|
285
|
adamc@8
|
286 | eexp of exp
|
adamc@8
|
287 | eapps of exp
|
adamc@8
|
288 | eterm of exp
|
adamc@195
|
289 | etuple of exp list
|
adamc@12
|
290 | rexp of (con * exp) list
|
adamc@91
|
291 | xml of exp
|
adamc@91
|
292 | xmlOne of exp
|
adamc@1045
|
293 | xmlOpt of exp
|
adamc@756
|
294 | tag of (string * exp) * exp
|
adamc@141
|
295 | tagHead of string * exp
|
adamc@434
|
296 | bind of string * con option * exp
|
adamc@446
|
297 | edecl of edecl
|
adamc@446
|
298 | edecls of edecl list
|
adamc@8
|
299
|
adamc@241
|
300 | earg of exp * con -> exp * con
|
adamc@241
|
301 | eargp of exp * con -> exp * con
|
adamc@822
|
302 | earga of exp * con -> exp * con
|
adamc@241
|
303 | eargs of exp * con -> exp * con
|
adamc@241
|
304 | eargl of exp * con -> exp * con
|
adamc@242
|
305 | eargl2 of exp * con -> exp * con
|
adamc@241
|
306
|
adamc@170
|
307 | branch of pat * exp
|
adamc@170
|
308 | branchs of (pat * exp) list
|
adamc@170
|
309 | pat of pat
|
adamc@822
|
310 | patS of pat
|
adamc@170
|
311 | pterm of pat
|
adamc@174
|
312 | rpat of (string * pat) list * bool
|
adamc@195
|
313 | ptuple of pat list
|
adamc@170
|
314
|
adamc@721
|
315 | attrs of exp option * (con * exp) list
|
adamc@721
|
316 | attr of attr
|
adamc@104
|
317 | attrv of exp
|
adamc@104
|
318
|
adamc@204
|
319 | query of exp
|
adamc@226
|
320 | query1 of exp
|
adamc@993
|
321 | dopt of exp
|
adamc@748
|
322 | tables of con list * exp
|
adamc@749
|
323 | fitem of con list * exp
|
adamc@204
|
324 | tname of con
|
adamc@705
|
325 | tnameW of con * con
|
adamc@705
|
326 | tnames of (con * con) * (con * con) list
|
adamc@705
|
327 | tnames' of (con * con) * (con * con) list
|
adamc@204
|
328 | table of con * exp
|
adamc@748
|
329 | table' of con * exp
|
adamc@207
|
330 | tident of con
|
adamc@207
|
331 | fident of con
|
adamc@207
|
332 | seli of select_item
|
adamc@207
|
333 | selis of select_item list
|
adamc@207
|
334 | select of select
|
adamc@209
|
335 | sqlexp of exp
|
adamc@209
|
336 | wopt of exp
|
adamc@226
|
337 | groupi of group_item
|
adamc@226
|
338 | groupis of group_item list
|
adamc@226
|
339 | gopt of group_item list option
|
adamc@227
|
340 | hopt of exp
|
adamc@230
|
341 | obopt of exp
|
adamc@268
|
342 | obitem of exp * exp
|
adamc@230
|
343 | obexps of exp
|
adamc@268
|
344 | diropt of exp
|
adamc@231
|
345 | lopt of exp
|
adamc@232
|
346 | ofopt of exp
|
adamc@231
|
347 | sqlint of exp
|
adamc@236
|
348 | sqlagg of string
|
adamc@746
|
349 | fname of exp
|
adamc@207
|
350
|
adamc@302
|
351 | texp of exp
|
adamc@302
|
352 | fields of con list
|
adamc@302
|
353 | sqlexps of exp list
|
adamc@303
|
354 | fsets of (con * exp) list
|
adamc@310
|
355 | enterDml of unit
|
adamc@310
|
356 | leaveDml of unit
|
adamc@302
|
357
|
adamc@204
|
358
|
adamc@1
|
359 %verbose (* print summary of errors *)
|
adamc@1
|
360 %pos int (* positions *)
|
adamc@1
|
361 %start file
|
adamc@1
|
362 %pure
|
adamc@1
|
363 %eop EOF
|
adamc@1
|
364 %noshift EOF
|
adamc@1
|
365
|
adamc@244
|
366 %name Urweb
|
adamc@1
|
367
|
adamc@623
|
368 %right KARROW
|
adamc@623
|
369 %nonassoc DKARROW
|
adamc@243
|
370 %right SEMI
|
adamc@243
|
371 %nonassoc LARROW
|
adamc@195
|
372 %nonassoc IF THEN ELSE
|
adamc@843
|
373 %nonassoc DARROW
|
adamc@842
|
374 %left ANDALSO
|
adamc@842
|
375 %left ORELSE
|
adamc@1
|
376 %nonassoc COLON
|
adamc@6
|
377 %nonassoc DCOLON TCOLON
|
adamc@229
|
378 %left UNION INTERSECT EXCEPT
|
adamc@1
|
379 %right COMMA
|
adamc@751
|
380 %right JOIN INNER CROSS OUTER LEFT RIGHT FULL
|
adamc@220
|
381 %right OR
|
adamc@220
|
382 %right CAND
|
adamc@470
|
383 %nonassoc EQ NE LT LE GT GE IS
|
adamc@243
|
384 %right ARROW
|
adamc@837
|
385 %right CARET PLUSPLUS
|
adamc@837
|
386 %left MINUSMINUS MINUSMINUSMINUS
|
adamc@389
|
387 %left PLUS MINUS
|
adamc@389
|
388 %left STAR DIVIDE MOD
|
adamc@220
|
389 %left NOT
|
adamc@84
|
390 %nonassoc TWIDDLE
|
adamc@1
|
391 %nonassoc DOLLAR
|
adamc@1
|
392 %left DOT
|
adamc@221
|
393 %nonassoc LBRACE RBRACE
|
adamc@1
|
394
|
adamc@1
|
395 %%
|
adamc@1
|
396
|
adamc@1
|
397 file : decls (decls)
|
adamc@54
|
398 | SIG sgis ([(DSgn ("?", (SgnConst sgis, s (SIGleft, sgisright))),
|
adamc@54
|
399 s (SIGleft, sgisright))])
|
adamc@1
|
400
|
adamc@1
|
401 decls : ([])
|
adamc@325
|
402 | decl decls (decl @ decls)
|
adamc@1
|
403
|
adamc@240
|
404 decl : CON SYMBOL cargl2 kopt EQ cexp (let
|
adamc@240
|
405 val loc = s (CONleft, cexpright)
|
adamc@240
|
406
|
adamc@240
|
407 val k = Option.getOpt (kopt, (KWild, loc))
|
adamc@240
|
408 val (c, k) = cargl2 (cexp, k)
|
adamc@240
|
409 in
|
adamc@325
|
410 [(DCon (SYMBOL, SOME k, c), loc)]
|
adamc@240
|
411 end)
|
adamc@325
|
412 | LTYPE SYMBOL EQ cexp ([(DCon (SYMBOL, SOME (KType, s (LTYPEleft, cexpright)), cexp),
|
adamc@325
|
413 s (LTYPEleft, cexpright))])
|
adamc@805
|
414 | DATATYPE dtypes ([(DDatatype dtypes, s (DATATYPEleft, dtypesright))])
|
adamc@191
|
415 | DATATYPE SYMBOL dargs EQ DATATYPE CSYMBOL DOT path
|
adamc@191
|
416 (case dargs of
|
adamc@325
|
417 [] => [(DDatatypeImp (SYMBOL, CSYMBOL :: #1 path, #2 path), s (DATATYPEleft, pathright))]
|
adamc@191
|
418 | _ => raise Fail "Arguments specified for imported datatype")
|
adamc@325
|
419 | VAL vali ([(DVal vali, s (VALleft, valiright))])
|
adamc@325
|
420 | VAL REC valis ([(DValRec valis, s (VALleft, valisright))])
|
adamc@325
|
421 | FUN valis ([(DValRec valis, s (FUNleft, valisright))])
|
adamc@1
|
422
|
adamc@325
|
423 | SIGNATURE CSYMBOL EQ sgn ([(DSgn (CSYMBOL, sgn), s (SIGNATUREleft, sgnright))])
|
adamc@325
|
424 | STRUCTURE CSYMBOL EQ str ([(DStr (CSYMBOL, NONE, str), s (STRUCTUREleft, strright))])
|
adamc@325
|
425 | STRUCTURE CSYMBOL COLON sgn EQ str ([(DStr (CSYMBOL, SOME sgn, str), s (STRUCTUREleft, strright))])
|
adamc@42
|
426 | FUNCTOR CSYMBOL LPAREN CSYMBOL COLON sgn RPAREN EQ str
|
adamc@325
|
427 ([(DStr (CSYMBOL1, NONE,
|
adamc@325
|
428 (StrFun (CSYMBOL2, sgn1, NONE, str), s (FUNCTORleft, strright))),
|
adamc@325
|
429 s (FUNCTORleft, strright))])
|
adamc@42
|
430 | FUNCTOR CSYMBOL LPAREN CSYMBOL COLON sgn RPAREN COLON sgn EQ str
|
adamc@325
|
431 ([(DStr (CSYMBOL1, NONE,
|
adamc@325
|
432 (StrFun (CSYMBOL2, sgn1, SOME sgn2, str), s (FUNCTORleft, strright))),
|
adamc@325
|
433 s (FUNCTORleft, strright))])
|
adamc@325
|
434 | EXTERN STRUCTURE CSYMBOL COLON sgn ([(DFfiStr (CSYMBOL, sgn), s (EXTERNleft, sgnright))])
|
adamc@61
|
435 | OPEN mpath (case mpath of
|
adamc@61
|
436 [] => raise Fail "Impossible mpath parse [1]"
|
adamc@325
|
437 | m :: ms => [(DOpen (m, ms), s (OPENleft, mpathright))])
|
adamc@325
|
438 | OPEN mpath LPAREN str RPAREN (let
|
adamc@325
|
439 val loc = s (OPENleft, RPARENright)
|
adamc@325
|
440
|
adamc@325
|
441 val m = case mpath of
|
adamc@325
|
442 [] => raise Fail "Impossible mpath parse [4]"
|
adamc@325
|
443 | m :: ms =>
|
adamc@325
|
444 foldl (fn (m, str) => (StrProj (str, m), loc))
|
adamc@325
|
445 (StrVar m, loc) ms
|
adamc@325
|
446 in
|
adamc@325
|
447 [(DStr ("anon", NONE, (StrApp (m, str), loc)), loc),
|
adamc@325
|
448 (DOpen ("anon", []), loc)]
|
adamc@325
|
449 end)
|
adamc@88
|
450 | OPEN CONSTRAINTS mpath (case mpath of
|
adamc@88
|
451 [] => raise Fail "Impossible mpath parse [3]"
|
adamc@325
|
452 | m :: ms => [(DOpenConstraints (m, ms), s (OPENleft, mpathright))])
|
adamc@325
|
453 | CONSTRAINT cterm TWIDDLE cterm ([(DConstraint (cterm1, cterm2), s (CONSTRAINTleft, ctermright))])
|
adamc@325
|
454 | EXPORT spath ([(DExport spath, s (EXPORTleft, spathright))])
|
adamc@707
|
455 | TABLE SYMBOL COLON cterm pkopt commaOpt cstopt([(DTable (SYMBOL, entable cterm, pkopt, cstopt),
|
adamc@707
|
456 s (TABLEleft, cstoptright))])
|
adamc@338
|
457 | SEQUENCE SYMBOL ([(DSequence SYMBOL, s (SEQUENCEleft, SYMBOLright))])
|
adamc@754
|
458 | VIEW SYMBOL EQ query ([(DView (SYMBOL, query),
|
adamc@754
|
459 s (VIEWleft, queryright))])
|
adamc@754
|
460 | VIEW SYMBOL EQ LBRACE eexp RBRACE ([(DView (SYMBOL, eexp),
|
adamc@754
|
461 s (VIEWleft, RBRACEright))])
|
adamc@563
|
462 | CLASS SYMBOL EQ cexp (let
|
adamc@563
|
463 val loc = s (CLASSleft, cexpright)
|
adamc@563
|
464 in
|
adamc@563
|
465 [(DClass (SYMBOL, (KWild, loc), cexp), loc)]
|
adamc@563
|
466 end)
|
adamc@563
|
467 | CLASS SYMBOL DCOLON kind EQ cexp ([(DClass (SYMBOL, kind, cexp), s (CLASSleft, cexpright))])
|
adamc@211
|
468 | CLASS SYMBOL SYMBOL EQ cexp (let
|
adamc@211
|
469 val loc = s (CLASSleft, cexpright)
|
adamc@563
|
470 val k = (KWild, loc)
|
adamc@211
|
471 val c = (CAbs (SYMBOL2, SOME k, cexp), loc)
|
adamc@211
|
472 in
|
adamc@563
|
473 [(DClass (SYMBOL1, k, c), s (CLASSleft, cexpright))]
|
adamc@563
|
474 end)
|
adamc@563
|
475 | CLASS SYMBOL LPAREN SYMBOL DCOLON kind RPAREN EQ cexp (let
|
adamc@563
|
476 val loc = s (CLASSleft, cexpright)
|
adamc@563
|
477 val c = (CAbs (SYMBOL2, SOME kind, cexp), loc)
|
adamc@563
|
478 in
|
adamc@563
|
479 [(DClass (SYMBOL1, kind, c), s (CLASSleft, cexpright))]
|
adamc@211
|
480 end)
|
adamc@459
|
481 | COOKIE SYMBOL COLON cexp ([(DCookie (SYMBOL, cexp), s (COOKIEleft, cexpright))])
|
adamc@720
|
482 | STYLE SYMBOL ([(DStyle SYMBOL, s (STYLEleft, SYMBOLright))])
|
adamc@1075
|
483 | TASK eapps EQ eexp ([(DTask (eapps, eexp), s (TASKleft, eexpright))])
|
adamc@1199
|
484 | POLICY eexp ([(DPolicy eexp, s (POLICYleft, eexpright))])
|
adamc@30
|
485
|
adamc@805
|
486 dtype : SYMBOL dargs EQ barOpt dcons (SYMBOL, dargs, dcons)
|
adamc@805
|
487
|
adamc@805
|
488 dtypes : dtype ([dtype])
|
adamc@805
|
489 | dtype AND dtypes (dtype :: dtypes)
|
adamc@805
|
490
|
adamc@240
|
491 kopt : (NONE)
|
adamc@240
|
492 | DCOLON kind (SOME kind)
|
adamc@240
|
493
|
adamc@191
|
494 dargs : ([])
|
adamc@191
|
495 | SYMBOL dargs (SYMBOL :: dargs)
|
adamc@191
|
496
|
adamc@156
|
497 barOpt : ()
|
adamc@156
|
498 | BAR ()
|
adamc@156
|
499
|
adamc@156
|
500 dcons : dcon ([dcon])
|
adamc@156
|
501 | dcon BAR dcons (dcon :: dcons)
|
adamc@156
|
502
|
adamc@156
|
503 dcon : CSYMBOL (CSYMBOL, NONE)
|
adamc@156
|
504 | CSYMBOL OF cexp (CSYMBOL, SOME cexp)
|
adamc@156
|
505
|
adamc@242
|
506 vali : SYMBOL eargl2 copt EQ eexp (let
|
adamc@242
|
507 val loc = s (SYMBOLleft, eexpright)
|
adamc@242
|
508 val t = Option.getOpt (copt, (CWild (KType, loc), loc))
|
adamc@242
|
509
|
adamc@242
|
510 val (e, t) = eargl2 (eexp, t)
|
adamc@242
|
511 in
|
adamc@242
|
512 (SYMBOL, SOME t, e)
|
adamc@242
|
513 end)
|
adamc@242
|
514
|
adamc@242
|
515 copt : (NONE)
|
adamc@242
|
516 | COLON cexp (SOME cexp)
|
adamc@123
|
517
|
adamc@704
|
518 cstopt : (EVar (["Basis"], "no_constraint", Infer), dummy)
|
adamc@704
|
519 | csts (csts)
|
adamc@704
|
520
|
adamc@704
|
521 csts : CCONSTRAINT tname cst (let
|
adamc@704
|
522 val loc = s (CCONSTRAINTleft, cstright)
|
adamc@704
|
523
|
adamc@704
|
524 val e = (EVar (["Basis"], "one_constraint", Infer), loc)
|
adamc@704
|
525 val e = (ECApp (e, tname), loc)
|
adamc@704
|
526 in
|
adamc@704
|
527 (EApp (e, cst), loc)
|
adamc@704
|
528 end)
|
adamc@704
|
529 | csts COMMA csts (let
|
adamc@704
|
530 val loc = s (csts1left, csts2right)
|
adamc@704
|
531
|
adamc@704
|
532 val e = (EVar (["Basis"], "join_constraints", Infer), loc)
|
adamc@704
|
533 val e = (EApp (e, csts1), loc)
|
adamc@704
|
534 in
|
adamc@704
|
535 (EApp (e, csts2), loc)
|
adamc@704
|
536 end)
|
adamc@704
|
537 | LBRACE LBRACE eexp RBRACE RBRACE (eexp)
|
adamc@704
|
538
|
adamc@704
|
539 cst : UNIQUE tnames (let
|
adamc@704
|
540 val loc = s (UNIQUEleft, tnamesright)
|
adamc@704
|
541
|
adamc@704
|
542 val e = (EVar (["Basis"], "unique", Infer), loc)
|
adamc@705
|
543 val e = (ECApp (e, #1 (#1 tnames)), loc)
|
adamc@705
|
544 val e = (ECApp (e, (CRecord (#2 tnames), loc)), loc)
|
adamc@704
|
545 in
|
adamc@1093
|
546 e
|
adamc@704
|
547 end)
|
adamc@709
|
548
|
adamc@714
|
549 | CHECK sqlexp (let
|
adamc@714
|
550 val loc = s (CHECKleft, sqlexpright)
|
adamc@714
|
551 in
|
adamc@714
|
552 (EApp ((EVar (["Basis"], "check", Infer), loc),
|
adamc@714
|
553 sqlexp), loc)
|
adamc@714
|
554 end)
|
adamc@714
|
555
|
adamc@709
|
556 | FOREIGN KEY tnames REFERENCES texp LPAREN tnames' RPAREN pmodes
|
adamc@709
|
557 (let
|
adamc@709
|
558 val loc = s (FOREIGNleft, pmodesright)
|
adamc@709
|
559
|
adamc@709
|
560 val mat = ListPair.foldrEq
|
adamc@709
|
561 (fn ((nm1, _), (nm2, _), mat) =>
|
adamc@709
|
562 let
|
adamc@709
|
563 val e = (EVar (["Basis"], "mat_cons", Infer), loc)
|
adamc@709
|
564 val e = (ECApp (e, nm1), loc)
|
adamc@709
|
565 val e = (ECApp (e, nm2), loc)
|
adamc@709
|
566 in
|
adamc@709
|
567 (EApp (e, mat), loc)
|
adamc@709
|
568 end)
|
adamc@709
|
569 (EVar (["Basis"], "mat_nil", Infer), loc)
|
adamc@709
|
570 (#1 tnames :: #2 tnames, #1 tnames' :: #2 tnames')
|
adamc@709
|
571
|
adamc@709
|
572 fun findMode mode =
|
adamc@709
|
573 let
|
adamc@709
|
574 fun findMode' pmodes =
|
adamc@709
|
575 case pmodes of
|
adamc@709
|
576 [] => (EVar (["Basis"], "no_action", Infer), loc)
|
adamc@709
|
577 | (mode', rule) :: pmodes' =>
|
adamc@709
|
578 if mode' = mode then
|
adamc@709
|
579 (if List.exists (fn (mode', _) => mode' = mode)
|
adamc@709
|
580 pmodes' then
|
adamc@709
|
581 ErrorMsg.errorAt loc "Duplicate propagation rule"
|
adamc@709
|
582 else
|
adamc@709
|
583 ();
|
adamc@709
|
584 rule)
|
adamc@709
|
585 else
|
adamc@709
|
586 findMode' pmodes'
|
adamc@709
|
587 in
|
adamc@709
|
588 findMode' pmodes
|
adamc@709
|
589 end
|
adamc@709
|
590
|
adamc@709
|
591 val e = (EVar (["Basis"], "foreign_key", Infer), loc)
|
adamc@709
|
592 val e = (EApp (e, mat), loc)
|
adamc@709
|
593 val e = (EApp (e, texp), loc)
|
adamc@709
|
594 in
|
adamc@709
|
595 (EApp (e, (ERecord [((CName "OnDelete", loc),
|
adamc@709
|
596 findMode Delete),
|
adamc@709
|
597 ((CName "OnUpdate", loc),
|
adamc@709
|
598 findMode Update)], loc)), loc)
|
adamc@709
|
599 end)
|
adamc@709
|
600
|
adamc@704
|
601 | LBRACE eexp RBRACE (eexp)
|
adamc@704
|
602
|
adamc@704
|
603 tnameW : tname (let
|
adamc@704
|
604 val loc = s (tnameleft, tnameright)
|
adamc@704
|
605 in
|
adamc@704
|
606 (tname, (CWild (KType, loc), loc))
|
adamc@704
|
607 end)
|
adamc@704
|
608
|
adamc@705
|
609 tnames : tnameW (tnameW, [])
|
adamc@705
|
610 | LPAREN tnames' RPAREN (tnames')
|
adamc@704
|
611
|
adamc@705
|
612 tnames': tnameW (tnameW, [])
|
adamc@705
|
613 | tnameW COMMA tnames' (#1 tnames', tnameW :: #2 tnames')
|
adamc@704
|
614
|
adamc@709
|
615 pmode : ON pkind prule (pkind, prule)
|
adamc@709
|
616
|
adamc@709
|
617 pkind : DELETE (Delete)
|
adamc@709
|
618 | UPDATE (Update)
|
adamc@709
|
619
|
adamc@709
|
620 prule : NO ACTION (EVar (["Basis"], "no_action", Infer), s (NOleft, ACTIONright))
|
adamc@709
|
621 | RESTRICT (EVar (["Basis"], "restrict", Infer), s (RESTRICTleft, RESTRICTright))
|
adamc@709
|
622 | CASCADE (EVar (["Basis"], "cascade", Infer), s (CASCADEleft, CASCADEright))
|
adamc@709
|
623 | SET NULL (EVar (["Basis"], "set_null", Infer), s (SETleft, NULLright))
|
adamc@709
|
624
|
adamc@709
|
625 pmodes : ([])
|
adamc@709
|
626 | pmode pmodes (pmode :: pmodes)
|
adamc@709
|
627
|
adamc@707
|
628 commaOpt: ()
|
adamc@707
|
629 | COMMA ()
|
adamc@707
|
630
|
adamc@993
|
631 pkopt : (EVar (["Basis"], "no_primary_key", Infer), dummy)
|
adamc@707
|
632 | PRIMARY KEY tnames (let
|
adamc@707
|
633 val loc = s (PRIMARYleft, tnamesright)
|
adamc@707
|
634
|
adamc@1093
|
635 val e = (EVar (["Basis"], "primary_key", TypesOnly), loc)
|
adamc@707
|
636 val e = (ECApp (e, #1 (#1 tnames)), loc)
|
adamc@707
|
637 val e = (ECApp (e, (CRecord (#2 tnames), loc)), loc)
|
adamc@707
|
638 val e = (EDisjointApp e, loc)
|
adamc@707
|
639 val e = (EDisjointApp e, loc)
|
adamc@707
|
640
|
adamc@707
|
641 val witness = map (fn (c, _) =>
|
adamc@707
|
642 (c, (EWild, loc)))
|
adamc@707
|
643 (#1 tnames :: #2 tnames)
|
adamc@707
|
644 val witness = (ERecord witness, loc)
|
adamc@707
|
645 in
|
adamc@707
|
646 (EApp (e, witness), loc)
|
adamc@707
|
647 end)
|
adamc@707
|
648
|
adamc@123
|
649 valis : vali ([vali])
|
adamc@123
|
650 | vali AND valis (vali :: valis)
|
adamc@123
|
651
|
adamc@42
|
652 sgn : sgntm (sgntm)
|
adamc@40
|
653 | FUNCTOR LPAREN CSYMBOL COLON sgn RPAREN COLON sgn
|
adamc@40
|
654 (SgnFun (CSYMBOL, sgn1, sgn2), s (FUNCTORleft, sgn2right))
|
adamc@30
|
655
|
adamc@42
|
656 sgntm : SIG sgis END (SgnConst sgis, s (SIGleft, ENDright))
|
adamc@59
|
657 | mpath (case mpath of
|
adamc@61
|
658 [] => raise Fail "Impossible mpath parse [2]"
|
adamc@59
|
659 | [x] => SgnVar x
|
adamc@59
|
660 | m :: ms => SgnProj (m,
|
adamc@59
|
661 List.take (ms, length ms - 1),
|
adamc@59
|
662 List.nth (ms, length ms - 1)),
|
adamc@59
|
663 s (mpathleft, mpathright))
|
adamc@42
|
664 | sgntm WHERE CON SYMBOL EQ cexp (SgnWhere (sgntm, SYMBOL, cexp), s (sgntmleft, cexpright))
|
adamc@42
|
665 | sgntm WHERE LTYPE SYMBOL EQ cexp(SgnWhere (sgntm, SYMBOL, cexp), s (sgntmleft, cexpright))
|
adamc@42
|
666 | LPAREN sgn RPAREN (sgn)
|
adamc@42
|
667
|
adamc@706
|
668 sgi : CON SYMBOL DCOLON kind ((SgiConAbs (SYMBOL, kind), s (CONleft, kindright)))
|
adamc@706
|
669 | LTYPE SYMBOL ((SgiConAbs (SYMBOL, (KType, s (LTYPEleft, SYMBOLright))),
|
adamc@706
|
670 s (LTYPEleft, SYMBOLright)))
|
adamc@706
|
671 | CON SYMBOL EQ cexp ((SgiCon (SYMBOL, NONE, cexp), s (CONleft, cexpright)))
|
adamc@706
|
672 | CON SYMBOL DCOLON kind EQ cexp ((SgiCon (SYMBOL, SOME kind, cexp), s (CONleft, cexpright)))
|
adamc@706
|
673 | LTYPE SYMBOL EQ cexp ((SgiCon (SYMBOL, SOME (KType, s (LTYPEleft, cexpright)), cexp),
|
adamc@706
|
674 s (LTYPEleft, cexpright)))
|
adamc@805
|
675 | DATATYPE dtypes ((SgiDatatype dtypes, s (DATATYPEleft, dtypesright)))
|
adamc@191
|
676 | DATATYPE SYMBOL dargs EQ DATATYPE CSYMBOL DOT path
|
adamc@191
|
677 (case dargs of
|
adamc@191
|
678 [] => (SgiDatatypeImp (SYMBOL, CSYMBOL :: #1 path, #2 path), s (DATATYPEleft, pathright))
|
adamc@191
|
679 | _ => raise Fail "Arguments specified for imported datatype")
|
adamc@706
|
680 | VAL SYMBOL COLON cexp ((SgiVal (SYMBOL, cexp), s (VALleft, cexpright)))
|
adamc@30
|
681
|
adamc@706
|
682 | STRUCTURE CSYMBOL COLON sgn ((SgiStr (CSYMBOL, sgn), s (STRUCTUREleft, sgnright)))
|
adamc@706
|
683 | SIGNATURE CSYMBOL EQ sgn ((SgiSgn (CSYMBOL, sgn), s (SIGNATUREleft, sgnright)))
|
adamc@42
|
684 | FUNCTOR CSYMBOL LPAREN CSYMBOL COLON sgn RPAREN COLON sgn
|
adamc@706
|
685 ((SgiStr (CSYMBOL1,
|
adamc@706
|
686 (SgnFun (CSYMBOL2, sgn1, sgn2), s (FUNCTORleft, sgn2right))),
|
adamc@706
|
687 s (FUNCTORleft, sgn2right)))
|
adamc@706
|
688 | INCLUDE sgn ((SgiInclude sgn, s (INCLUDEleft, sgnright)))
|
adamc@706
|
689 | CONSTRAINT cterm TWIDDLE cterm ((SgiConstraint (cterm1, cterm2), s (CONSTRAINTleft, ctermright)))
|
adamc@707
|
690 | TABLE SYMBOL COLON cterm pkopt commaOpt cstopt (let
|
adamc@707
|
691 val loc = s (TABLEleft, ctermright)
|
adamc@707
|
692 in
|
adamc@707
|
693 (SgiTable (SYMBOL, entable cterm, pkopt, cstopt), loc)
|
adamc@707
|
694 end)
|
adamc@460
|
695 | SEQUENCE SYMBOL (let
|
adamc@460
|
696 val loc = s (SEQUENCEleft, SYMBOLright)
|
adamc@460
|
697 val t = (CVar (["Basis"], "sql_sequence"), loc)
|
adamc@460
|
698 in
|
adamc@460
|
699 (SgiVal (SYMBOL, t), loc)
|
adamc@460
|
700 end)
|
adamc@754
|
701 | VIEW SYMBOL COLON cexp (let
|
adamc@754
|
702 val loc = s (VIEWleft, cexpright)
|
adamc@754
|
703 val t = (CVar (["Basis"], "sql_view"), loc)
|
adamc@1076
|
704 val t = (CApp (t, entable cexp), loc)
|
adamc@754
|
705 in
|
adamc@754
|
706 (SgiVal (SYMBOL, t), loc)
|
adamc@754
|
707 end)
|
adamc@563
|
708 | CLASS SYMBOL (let
|
adamc@563
|
709 val loc = s (CLASSleft, SYMBOLright)
|
adamc@711
|
710 val k = (KArrow ((KType, loc), (KType, loc)), loc)
|
adamc@563
|
711 in
|
adamc@711
|
712 (SgiClassAbs (SYMBOL, k), loc)
|
adamc@563
|
713 end)
|
adamc@563
|
714 | CLASS SYMBOL DCOLON kind (let
|
adamc@563
|
715 val loc = s (CLASSleft, kindright)
|
adamc@563
|
716 in
|
adamc@563
|
717 (SgiClassAbs (SYMBOL, kind), loc)
|
adamc@563
|
718 end)
|
adamc@563
|
719 | CLASS SYMBOL EQ cexp (let
|
adamc@563
|
720 val loc = s (CLASSleft, cexpright)
|
adamc@563
|
721 in
|
adamc@563
|
722 (SgiClass (SYMBOL, (KWild, loc), cexp), loc)
|
adamc@563
|
723 end)
|
adamc@563
|
724 | CLASS SYMBOL DCOLON kind EQ cexp (let
|
adamc@563
|
725 val loc = s (CLASSleft, cexpright)
|
adamc@563
|
726 in
|
adamc@563
|
727 (SgiClass (SYMBOL, kind, cexp), loc)
|
adamc@563
|
728 end)
|
adamc@211
|
729 | CLASS SYMBOL SYMBOL EQ cexp (let
|
adamc@211
|
730 val loc = s (CLASSleft, cexpright)
|
adamc@563
|
731 val k = (KWild, loc)
|
adamc@211
|
732 val c = (CAbs (SYMBOL2, SOME k, cexp), loc)
|
adamc@211
|
733 in
|
adamc@563
|
734 (SgiClass (SYMBOL1, k, c), s (CLASSleft, cexpright))
|
adamc@563
|
735 end)
|
adamc@563
|
736 | CLASS SYMBOL LPAREN SYMBOL DCOLON kind RPAREN EQ cexp (let
|
adamc@563
|
737 val loc = s (CLASSleft, cexpright)
|
adamc@563
|
738 val c = (CAbs (SYMBOL2, SOME kind, cexp), loc)
|
adamc@563
|
739 in
|
adamc@563
|
740 (SgiClass (SYMBOL1, kind, c), s (CLASSleft, cexpright))
|
adamc@211
|
741 end)
|
adamc@460
|
742 | COOKIE SYMBOL COLON cexp (let
|
adamc@460
|
743 val loc = s (COOKIEleft, cexpright)
|
adamc@460
|
744 val t = (CApp ((CVar (["Basis"], "http_cookie"), loc),
|
adamc@460
|
745 entable cexp), loc)
|
adamc@460
|
746 in
|
adamc@460
|
747 (SgiVal (SYMBOL, t), loc)
|
adamc@460
|
748 end)
|
adamc@720
|
749 | STYLE SYMBOL (let
|
adamc@720
|
750 val loc = s (STYLEleft, SYMBOLright)
|
adamc@720
|
751 val t = (CVar (["Basis"], "css_class"), loc)
|
adamc@718
|
752 in
|
adamc@718
|
753 (SgiVal (SYMBOL, t), loc)
|
adamc@718
|
754 end)
|
adamc@30
|
755
|
adamc@30
|
756 sgis : ([])
|
adamc@30
|
757 | sgi sgis (sgi :: sgis)
|
adamc@30
|
758
|
adamc@30
|
759 str : STRUCT decls END (StrConst decls, s (STRUCTleft, ENDright))
|
adamc@34
|
760 | spath (spath)
|
adamc@40
|
761 | FUNCTOR LPAREN CSYMBOL COLON sgn RPAREN DARROW str
|
adamc@40
|
762 (StrFun (CSYMBOL, sgn, NONE, str), s (FUNCTORleft, strright))
|
adamc@40
|
763 | FUNCTOR LPAREN CSYMBOL COLON sgn RPAREN COLON sgn DARROW str
|
adamc@40
|
764 (StrFun (CSYMBOL, sgn1, SOME sgn2, str), s (FUNCTORleft, strright))
|
adamc@44
|
765 | spath LPAREN str RPAREN (StrApp (spath, str), s (spathleft, RPARENright))
|
adamc@34
|
766
|
adamc@34
|
767 spath : CSYMBOL (StrVar CSYMBOL, s (CSYMBOLleft, CSYMBOLright))
|
adamc@34
|
768 | spath DOT CSYMBOL (StrProj (spath, CSYMBOL), s (spathleft, CSYMBOLright))
|
adamc@30
|
769
|
adamc@1
|
770 kind : TYPE (KType, s (TYPEleft, TYPEright))
|
adamc@1
|
771 | NAME (KName, s (NAMEleft, NAMEright))
|
adamc@1
|
772 | LBRACE kind RBRACE (KRecord kind, s (LBRACEleft, RBRACEright))
|
adamc@1
|
773 | kind ARROW kind (KArrow (kind1, kind2), s (kind1left, kind2right))
|
adamc@1
|
774 | LPAREN kind RPAREN (#1 kind, s (LPARENleft, RPARENright))
|
adamc@82
|
775 | KUNIT (KUnit, s (KUNITleft, KUNITright))
|
adamc@18
|
776 | UNDERUNDER (KWild, s (UNDERUNDERleft, UNDERUNDERright))
|
adamc@207
|
777 | LPAREN ktuple RPAREN (KTuple ktuple, s (LPARENleft, RPARENright))
|
adamc@623
|
778 | CSYMBOL (KVar CSYMBOL, s (CSYMBOLleft, CSYMBOLright))
|
adamc@623
|
779 | CSYMBOL KARROW kind (KFun (CSYMBOL, kind), s (CSYMBOLleft, kindright))
|
adamc@207
|
780
|
adamc@207
|
781 ktuple : kind STAR kind ([kind1, kind2])
|
adamc@207
|
782 | kind STAR ktuple (kind :: ktuple)
|
adamc@1
|
783
|
adamc@1
|
784 capps : cterm (cterm)
|
adamc@1
|
785 | capps cterm (CApp (capps, cterm), s (cappsleft, ctermright))
|
adamc@1
|
786
|
adamc@1
|
787 cexp : capps (capps)
|
adamc@1
|
788 | cexp ARROW cexp (TFun (cexp1, cexp2), s (cexp1left, cexp2right))
|
adamc@15
|
789 | SYMBOL kcolon kind ARROW cexp (TCFun (kcolon, SYMBOL, kind, cexp), s (SYMBOLleft, cexpright))
|
adamc@623
|
790 | CSYMBOL KARROW cexp (TKFun (CSYMBOL, cexp), s (CSYMBOLleft, cexpright))
|
adamc@1
|
791
|
adamc@1
|
792 | cexp PLUSPLUS cexp (CConcat (cexp1, cexp2), s (cexp1left, cexp1right))
|
adamc@1
|
793
|
adamc@239
|
794 | FN cargs DARROW cexp (#1 (cargs (cexp, (KWild, s (FNleft, cexpright)))))
|
adamc@628
|
795 | LBRACK cexp TWIDDLE cexp RBRACK DARROW cexp (TDisjoint (cexp1, cexp2, cexp3), s (LBRACKleft, cexp3right))
|
adamc@623
|
796 | CSYMBOL DKARROW cexp (CKAbs (CSYMBOL, cexp), s (CSYMBOLleft, cexpright))
|
adamc@1
|
797
|
adamc@8
|
798 | LPAREN cexp RPAREN DCOLON kind (CAnnot (cexp, kind), s (LPARENleft, kindright))
|
adamc@6
|
799
|
adamc@18
|
800 | UNDER DCOLON kind (CWild kind, s (UNDERleft, UNDERright))
|
adamc@195
|
801 | ctuple (let
|
adamc@195
|
802 val loc = s (ctupleleft, ctupleright)
|
adamc@195
|
803 in
|
adamc@195
|
804 (TRecord (CRecord (ListUtil.mapi (fn (i, c) =>
|
adamc@195
|
805 ((CName (Int.toString (i + 1)), loc),
|
adamc@195
|
806 c)) ctuple),
|
adamc@195
|
807 loc), loc)
|
adamc@195
|
808 end)
|
adamc@18
|
809
|
adamc@1
|
810 kcolon : DCOLON (Explicit)
|
adamc@1
|
811 | TCOLON (Implicit)
|
adamc@1
|
812
|
adamc@239
|
813 cargs : carg (carg)
|
adamc@239
|
814 | cargl (cargl)
|
adamc@239
|
815
|
adamc@239
|
816 cargl : cargp cargp (cargp1 o cargp2)
|
adamc@239
|
817 | cargp cargl (cargp o cargl)
|
adamc@239
|
818
|
adamc@240
|
819 cargl2 : (fn x => x)
|
adamc@240
|
820 | cargp cargl2 (cargp o cargl2)
|
adamc@240
|
821
|
adamc@241
|
822 carg : SYMBOL DCOLON kind (fn (c, k) =>
|
adamc@239
|
823 let
|
adamc@239
|
824 val loc = s (SYMBOLleft, kindright)
|
adamc@239
|
825 in
|
adamc@239
|
826 ((CAbs (SYMBOL, SOME kind, c), loc),
|
adamc@239
|
827 (KArrow (kind, k), loc))
|
adamc@239
|
828 end)
|
adamc@329
|
829 | UNDER DCOLON kind (fn (c, k) =>
|
adamc@329
|
830 let
|
adamc@329
|
831 val loc = s (UNDERleft, kindright)
|
adamc@329
|
832 in
|
adamc@329
|
833 ((CAbs ("_", SOME kind, c), loc),
|
adamc@329
|
834 (KArrow (kind, k), loc))
|
adamc@329
|
835 end)
|
adamc@241
|
836 | cargp (cargp)
|
adamc@239
|
837
|
adamc@239
|
838 cargp : SYMBOL (fn (c, k) =>
|
adamc@239
|
839 let
|
adamc@239
|
840 val loc = s (SYMBOLleft, SYMBOLright)
|
adamc@239
|
841 in
|
adamc@239
|
842 ((CAbs (SYMBOL, NONE, c), loc),
|
adamc@239
|
843 (KArrow ((KWild, loc), k), loc))
|
adamc@239
|
844 end)
|
adamc@329
|
845 | UNDER (fn (c, k) =>
|
adamc@329
|
846 let
|
adamc@329
|
847 val loc = s (UNDERleft, UNDERright)
|
adamc@329
|
848 in
|
adamc@329
|
849 ((CAbs ("_", NONE, c), loc),
|
adamc@329
|
850 (KArrow ((KWild, loc), k), loc))
|
adamc@329
|
851 end)
|
adamc@1001
|
852 | LPAREN SYMBOL kopt ckl RPAREN (fn (c, k) =>
|
adamc@239
|
853 let
|
adamc@239
|
854 val loc = s (LPARENleft, RPARENright)
|
adamc@1001
|
855 val ckl = (SYMBOL, kopt) :: ckl
|
adamc@1001
|
856 val ckl = map (fn (x, ko) => (x, case ko of
|
adamc@1001
|
857 NONE => (KWild, loc)
|
adamc@1001
|
858 | SOME k => k)) ckl
|
adamc@239
|
859 in
|
adamc@1001
|
860 case ckl of
|
adamc@1001
|
861 [(x, k')] => ((CAbs (SYMBOL, SOME k', c), loc),
|
adamc@1001
|
862 (KArrow (k', k), loc))
|
adamc@1001
|
863 | _ =>
|
adamc@1001
|
864 let
|
adamc@1001
|
865 val k' = (KTuple (map #2 ckl), loc)
|
adamc@1001
|
866
|
adamc@1001
|
867 val c = foldr (fn ((x, k), c) =>
|
adamc@1001
|
868 (CAbs (x, SOME k, c), loc)) c ckl
|
adamc@1001
|
869 val v = (CVar ([], "$x"), loc)
|
adamc@1001
|
870 val c = ListUtil.foldli (fn (i, _, c) =>
|
adamc@1001
|
871 (CApp (c, (CProj (v, i + 1), loc)),
|
adamc@1001
|
872 loc)) c ckl
|
adamc@1001
|
873 in
|
adamc@1001
|
874 ((CAbs ("$x", SOME k', c), loc),
|
adamc@1001
|
875 (KArrow (k', k), loc))
|
adamc@1001
|
876 end
|
adamc@239
|
877 end)
|
adamc@628
|
878
|
adamc@1001
|
879 ckl : ([])
|
adamc@1001
|
880 | COMMA SYMBOL kopt ckl ((SYMBOL, kopt) :: ckl)
|
adamc@239
|
881
|
adamc@34
|
882 path : SYMBOL ([], SYMBOL)
|
adamc@34
|
883 | CSYMBOL DOT path (let val (ms, x) = path in (CSYMBOL :: ms, x) end)
|
adamc@34
|
884
|
adamc@156
|
885 cpath : CSYMBOL ([], CSYMBOL)
|
adamc@156
|
886 | CSYMBOL DOT cpath (let val (ms, x) = cpath in (CSYMBOL :: ms, x) end)
|
adamc@156
|
887
|
adamc@59
|
888 mpath : CSYMBOL ([CSYMBOL])
|
adamc@59
|
889 | CSYMBOL DOT mpath (CSYMBOL :: mpath)
|
adamc@59
|
890
|
adamc@1
|
891 cterm : LPAREN cexp RPAREN (#1 cexp, s (LPARENleft, RPARENright))
|
adamc@1
|
892 | LBRACK rcon RBRACK (CRecord rcon, s (LBRACKleft, RBRACKright))
|
adamc@83
|
893 | LBRACK rconn RBRACK (CRecord rconn, s (LBRACKleft, RBRACKright))
|
adamc@1
|
894 | LBRACE rcone RBRACE (TRecord (CRecord rcone, s (LBRACEleft, RBRACEright)),
|
adamc@1
|
895 s (LBRACEleft, RBRACEright))
|
adamc@1
|
896 | DOLLAR cterm (TRecord cterm, s (DOLLARleft, ctermright))
|
adamc@1
|
897 | HASH CSYMBOL (CName CSYMBOL, s (HASHleft, CSYMBOLright))
|
adamc@195
|
898 | HASH INT (CName (Int64.toString INT), s (HASHleft, INTright))
|
adamc@1
|
899
|
adamc@34
|
900 | path (CVar path, s (pathleft, pathright))
|
adamc@207
|
901 | path DOT INT (CProj ((CVar path, s (pathleft, pathright)), Int64.toInt INT),
|
adamc@207
|
902 s (pathleft, INTright))
|
adamc@18
|
903 | UNDER (CWild (KWild, s (UNDERleft, UNDERright)), s (UNDERleft, UNDERright))
|
adamc@621
|
904 | MAP (CMap, s (MAPleft, MAPright))
|
adamc@82
|
905 | UNIT (CUnit, s (UNITleft, UNITright))
|
adamc@207
|
906 | LPAREN ctuplev RPAREN (CTuple ctuplev, s (LPARENleft, RPARENright))
|
adamc@207
|
907
|
adamc@207
|
908 ctuplev: cexp COMMA cexp ([cexp1, cexp2])
|
adamc@207
|
909 | cexp COMMA ctuplev (cexp :: ctuplev)
|
adamc@1
|
910
|
adamc@196
|
911 ctuple : capps STAR capps ([capps1, capps2])
|
adamc@196
|
912 | capps STAR ctuple (capps :: ctuple)
|
adamc@195
|
913
|
adamc@1
|
914 rcon : ([])
|
adamc@1
|
915 | ident EQ cexp ([(ident, cexp)])
|
adamc@1
|
916 | ident EQ cexp COMMA rcon ((ident, cexp) :: rcon)
|
adamc@1
|
917
|
adamc@83
|
918 rconn : ident ([(ident, (CUnit, s (identleft, identright)))])
|
adamc@83
|
919 | ident COMMA rconn ((ident, (CUnit, s (identleft, identright))) :: rconn)
|
adamc@83
|
920
|
adamc@1
|
921 rcone : ([])
|
adamc@1
|
922 | ident COLON cexp ([(ident, cexp)])
|
adamc@1
|
923 | ident COLON cexp COMMA rcone ((ident, cexp) :: rcone)
|
adamc@1
|
924
|
adamc@1
|
925 ident : CSYMBOL (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright))
|
adamc@195
|
926 | INT (CName (Int64.toString INT), s (INTleft, INTright))
|
adamc@200
|
927 | SYMBOL (CVar ([], SYMBOL), s (SYMBOLleft, SYMBOLright))
|
adamc@8
|
928
|
adamc@8
|
929 eapps : eterm (eterm)
|
adamc@8
|
930 | eapps eterm (EApp (eapps, eterm), s (eappsleft, etermright))
|
adamc@8
|
931 | eapps LBRACK cexp RBRACK (ECApp (eapps, cexp), s (eappsleft, RBRACKright))
|
adamc@629
|
932 | eapps BANG (EDisjointApp eapps, s (eappsleft, BANGright))
|
adamc@8
|
933
|
adamc@8
|
934 eexp : eapps (eapps)
|
adamc@241
|
935 | FN eargs DARROW eexp (let
|
adamc@93
|
936 val loc = s (FNleft, eexpright)
|
adamc@93
|
937 in
|
adamc@241
|
938 #1 (eargs (eexp, (CWild (KType, loc), loc)))
|
adamc@93
|
939 end)
|
adamc@623
|
940 | CSYMBOL DKARROW eexp (EKAbs (CSYMBOL, eexp), s (CSYMBOLleft, eexpright))
|
adamc@196
|
941 | eexp COLON cexp (EAnnot (eexp, cexp), s (eexpleft, cexpright))
|
adamc@149
|
942 | eexp MINUSMINUS cexp (ECut (eexp, cexp), s (eexpleft, cexpright))
|
adamc@493
|
943 | eexp MINUSMINUSMINUS cexp (ECutMulti (eexp, cexp), s (eexpleft, cexpright))
|
adamc@170
|
944 | CASE eexp OF barOpt branch branchs (ECase (eexp, branch :: branchs), s (CASEleft, branchsright))
|
adamc@190
|
945 | IF eexp THEN eexp ELSE eexp (let
|
adamc@190
|
946 val loc = s (IFleft, eexp3right)
|
adamc@190
|
947 in
|
adamc@190
|
948 (ECase (eexp1, [((PCon (["Basis"], "True", NONE), loc), eexp2),
|
adamc@190
|
949 ((PCon (["Basis"], "False", NONE), loc), eexp3)]), loc)
|
adamc@190
|
950 end)
|
adamc@434
|
951 | bind SEMI eexp (let
|
adamc@434
|
952 val loc = s (bindleft, eexpright)
|
adamc@434
|
953 val (v, to, e1) = bind
|
adamc@403
|
954 val e = (EVar (["Basis"], "bind", Infer), loc)
|
adamc@434
|
955 val e = (EApp (e, e1), loc)
|
adamc@243
|
956 in
|
adamc@434
|
957 (EApp (e, (EAbs (v, to, eexp), loc)), loc)
|
adamc@299
|
958 end)
|
adamc@256
|
959 | eexp EQ eexp (native_op ("eq", eexp1, eexp2, s (eexp1left, eexp2right)))
|
adamc@257
|
960 | eexp NE eexp (native_op ("ne", eexp1, eexp2, s (eexp1left, eexp2right)))
|
adamc@389
|
961 | MINUS eterm (native_unop ("neg", eterm, s (MINUSleft, etermright)))
|
adamc@389
|
962 | eexp PLUS eexp (native_op ("plus", eexp1, eexp2, s (eexp1left, eexp2right)))
|
adamc@389
|
963 | eexp MINUS eexp (native_op ("minus", eexp1, eexp2, s (eexp1left, eexp2right)))
|
adamc@1116
|
964 | eapps STAR eexp (native_op ("times", eapps, eexp, s (eappsleft, eexpright)))
|
adamc@964
|
965 | eexp DIVIDE eexp (native_op ("divide", eexp1, eexp2, s (eexp1left, eexp2right)))
|
adamc@389
|
966 | eexp MOD eexp (native_op ("mod", eexp1, eexp2, s (eexp1left, eexp2right)))
|
adamc@391
|
967
|
adamc@391
|
968 | eexp LT eexp (native_op ("lt", eexp1, eexp2, s (eexp1left, eexp2right)))
|
adamc@391
|
969 | eexp LE eexp (native_op ("le", eexp1, eexp2, s (eexp1left, eexp2right)))
|
adamc@391
|
970 | eexp GT eexp (native_op ("gt", eexp1, eexp2, s (eexp1left, eexp2right)))
|
adamc@391
|
971 | eexp GE eexp (native_op ("ge", eexp1, eexp2, s (eexp1left, eexp2right)))
|
adamc@391
|
972
|
adamc@842
|
973 | eexp ANDALSO eexp (let
|
adamc@842
|
974 val loc = s (eexp1left, eexp2right)
|
adamc@842
|
975 in
|
adamc@842
|
976 (ECase (eexp1, [((PCon (["Basis"], "True", NONE), loc),
|
adamc@842
|
977 eexp2),
|
adamc@842
|
978 ((PCon (["Basis"], "False", NONE), loc),
|
adamc@842
|
979 (EVar (["Basis"], "False", Infer), loc))]), loc)
|
adamc@842
|
980 end)
|
adamc@842
|
981 | eexp ORELSE eexp (let
|
adamc@842
|
982 val loc = s (eexp1left, eexp2right)
|
adamc@842
|
983 in
|
adamc@842
|
984 (ECase (eexp1, [((PCon (["Basis"], "True", NONE), loc),
|
adamc@842
|
985 (EVar (["Basis"], "True", Infer), loc)),
|
adamc@842
|
986 ((PCon (["Basis"], "False", NONE), loc),
|
adamc@842
|
987 eexp2)]), loc)
|
adamc@842
|
988 end)
|
adamc@842
|
989
|
adamc@445
|
990 | eexp PLUSPLUS eexp (EConcat (eexp1, eexp2), s (eexp1left, eexp2right))
|
adamc@8
|
991
|
adamc@674
|
992 | eexp CARET eexp (native_op ("strcat", eexp1, eexp2, s (eexp1left, eexp2right)))
|
adamc@674
|
993
|
adamc@794
|
994 | eapps DCOLON eexp (let
|
adamc@794
|
995 val loc = s (eappsleft, eexpright)
|
adamc@762
|
996 in
|
adamc@762
|
997 (EApp ((EVar (["Basis"], "Cons", Infer), loc),
|
adamc@762
|
998 (ERecord [((CName "1", loc),
|
adamc@794
|
999 eapps),
|
adamc@762
|
1000 ((CName "2", loc),
|
adamc@762
|
1001 eexp)], loc)), loc)
|
adamc@762
|
1002 end)
|
adamc@762
|
1003
|
adamc@434
|
1004 bind : SYMBOL LARROW eapps (SYMBOL, NONE, eapps)
|
adamc@434
|
1005 | eapps (let
|
adamc@434
|
1006 val loc = s (eappsleft, eappsright)
|
adamc@434
|
1007 in
|
adamc@434
|
1008 ("_", SOME (TRecord (CRecord [], loc), loc), eapps)
|
adamc@434
|
1009 end)
|
adamc@434
|
1010
|
adamc@241
|
1011 eargs : earg (earg)
|
adamc@241
|
1012 | eargl (eargl)
|
adamc@241
|
1013
|
adamc@241
|
1014 eargl : eargp eargp (eargp1 o eargp2)
|
adamc@241
|
1015 | eargp eargl (eargp o eargl)
|
adamc@241
|
1016
|
adamc@242
|
1017 eargl2 : (fn x => x)
|
adamc@242
|
1018 | eargp eargl2 (eargp o eargl2)
|
adamc@242
|
1019
|
adamc@822
|
1020 earg : patS (fn (e, t) =>
|
adamc@241
|
1021 let
|
adamc@822
|
1022 val loc = s (patSleft, patSright)
|
adamc@822
|
1023 val pt = patType loc patS
|
adamc@822
|
1024
|
adamc@822
|
1025 val e' = case #1 patS of
|
adamc@822
|
1026 PVar x => (EAbs (x, NONE, e), loc)
|
adamc@823
|
1027 | PAnnot ((PVar x, _), t) => (EAbs (x, SOME t, e), loc)
|
adamc@822
|
1028 | _ => (EAbs ("$x", SOME pt,
|
adamc@822
|
1029 (ECase ((EVar ([], "$x", DontInfer),
|
adamc@822
|
1030 loc),
|
adamc@822
|
1031 [(patS, e)]), loc)), loc)
|
adamc@241
|
1032 in
|
adamc@822
|
1033 (e', (TFun (pt, t), loc))
|
adamc@241
|
1034 end)
|
adamc@822
|
1035 | earga (earga)
|
adamc@822
|
1036
|
adamc@822
|
1037 eargp : pterm (fn (e, t) =>
|
adamc@241
|
1038 let
|
adamc@822
|
1039 val loc = s (ptermleft, ptermright)
|
adamc@822
|
1040 val pt = patType loc pterm
|
adamc@822
|
1041
|
adamc@822
|
1042 val e' = case #1 pterm of
|
adamc@822
|
1043 PVar x => (EAbs (x, NONE, e), loc)
|
adamc@823
|
1044 | PAnnot ((PVar x, _), t) => (EAbs (x, SOME t, e), loc)
|
adamc@822
|
1045 | _ => (EAbs ("$x", SOME pt,
|
adamc@822
|
1046 (ECase ((EVar ([], "$x", DontInfer),
|
adamc@822
|
1047 loc),
|
adamc@822
|
1048 [(pterm, e)]), loc)), loc)
|
adamc@241
|
1049 in
|
adamc@822
|
1050 (e', (TFun (pt, t), loc))
|
adamc@241
|
1051 end)
|
adamc@822
|
1052 | earga (earga)
|
adamc@241
|
1053
|
adamc@822
|
1054 earga : LBRACK SYMBOL RBRACK (fn (e, t) =>
|
adamc@241
|
1055 let
|
adamc@822
|
1056 val loc = s (LBRACKleft, RBRACKright)
|
adamc@822
|
1057 val kind = (KWild, loc)
|
adamc@822
|
1058 in
|
adamc@822
|
1059 ((ECAbs (Implicit, SYMBOL, kind, e), loc),
|
adamc@822
|
1060 (TCFun (Implicit, SYMBOL, kind, t), loc))
|
adamc@822
|
1061 end)
|
adamc@822
|
1062 | LBRACK SYMBOL kcolon kind RBRACK(fn (e, t) =>
|
adamc@822
|
1063 let
|
adamc@822
|
1064 val loc = s (LBRACKleft, RBRACKright)
|
adamc@241
|
1065 in
|
adamc@241
|
1066 ((ECAbs (kcolon, SYMBOL, kind, e), loc),
|
adamc@241
|
1067 (TCFun (kcolon, SYMBOL, kind, t), loc))
|
adamc@241
|
1068 end)
|
adamc@478
|
1069 | LBRACK cexp TWIDDLE cexp RBRACK(fn (e, t) =>
|
adamc@356
|
1070 let
|
adamc@356
|
1071 val loc = s (LBRACKleft, RBRACKright)
|
adamc@356
|
1072 in
|
adamc@478
|
1073 ((EDisjoint (cexp1, cexp2, e), loc),
|
adamc@628
|
1074 (TDisjoint (cexp1, cexp2, t), loc))
|
adamc@356
|
1075 end)
|
adamc@822
|
1076 | LBRACK CSYMBOL RBRACK (fn (e, t) =>
|
adamc@623
|
1077 let
|
adamc@623
|
1078 val loc = s (CSYMBOLleft, CSYMBOLright)
|
adamc@623
|
1079 in
|
adamc@623
|
1080 ((EKAbs (CSYMBOL, e), loc),
|
adamc@623
|
1081 (TKFun (CSYMBOL, t), loc))
|
adamc@623
|
1082 end)
|
adamc@241
|
1083
|
adamc@8
|
1084 eterm : LPAREN eexp RPAREN (#1 eexp, s (LPARENleft, RPARENright))
|
adamc@195
|
1085 | LPAREN etuple RPAREN (let
|
adamc@195
|
1086 val loc = s (LPARENleft, RPARENright)
|
adamc@195
|
1087 in
|
adamc@195
|
1088 (ERecord (ListUtil.mapi (fn (i, e) =>
|
adamc@195
|
1089 ((CName (Int.toString (i + 1)), loc),
|
adamc@195
|
1090 e)) etuple), loc)
|
adamc@195
|
1091 end)
|
adamc@8
|
1092
|
adamc@403
|
1093 | path (EVar (#1 path, #2 path, Infer), s (pathleft, pathright))
|
adamc@403
|
1094 | cpath (EVar (#1 cpath, #2 cpath, Infer), s (cpathleft, cpathright))
|
adamc@403
|
1095 | AT path (EVar (#1 path, #2 path, TypesOnly), s (ATleft, pathright))
|
adamc@403
|
1096 | AT AT path (EVar (#1 path, #2 path, DontInfer), s (AT1left, pathright))
|
adamc@403
|
1097 | AT cpath (EVar (#1 cpath, #2 cpath, TypesOnly), s (ATleft, cpathright))
|
adamc@403
|
1098 | AT AT cpath (EVar (#1 cpath, #2 cpath, DontInfer), s (AT1left, cpathright))
|
adamc@12
|
1099 | LBRACE rexp RBRACE (ERecord rexp, s (LBRACEleft, RBRACEright))
|
adamc@110
|
1100 | UNIT (ERecord [], s (UNITleft, UNITright))
|
adamc@12
|
1101
|
adamc@14
|
1102 | INT (EPrim (Prim.Int INT), s (INTleft, INTright))
|
adamc@14
|
1103 | FLOAT (EPrim (Prim.Float FLOAT), s (FLOATleft, FLOATright))
|
adamc@14
|
1104 | STRING (EPrim (Prim.String STRING), s (STRINGleft, STRINGright))
|
adamc@821
|
1105 | CHAR (EPrim (Prim.Char CHAR), s (CHARleft, CHARright))
|
adamc@14
|
1106
|
adamc@200
|
1107 | path DOT idents (let
|
adamc@200
|
1108 val loc = s (pathleft, identsright)
|
adamc@200
|
1109 in
|
adamc@200
|
1110 foldl (fn (ident, e) =>
|
adamc@200
|
1111 (EField (e, ident), loc))
|
adamc@403
|
1112 (EVar (#1 path, #2 path, Infer), s (pathleft, pathright)) idents
|
adamc@403
|
1113 end)
|
adamc@910
|
1114 | LPAREN eexp RPAREN DOT idents (let
|
adamc@910
|
1115 val loc = s (LPARENleft, identsright)
|
adamc@910
|
1116 in
|
adamc@910
|
1117 foldl (fn (ident, e) =>
|
adamc@910
|
1118 (EField (e, ident), loc))
|
adamc@910
|
1119 eexp idents
|
adamc@910
|
1120 end)
|
adamc@403
|
1121 | AT path DOT idents (let
|
adamc@403
|
1122 val loc = s (ATleft, identsright)
|
adamc@403
|
1123 in
|
adamc@403
|
1124 foldl (fn (ident, e) =>
|
adamc@403
|
1125 (EField (e, ident), loc))
|
adamc@403
|
1126 (EVar (#1 path, #2 path, TypesOnly), s (pathleft, pathright)) idents
|
adamc@403
|
1127 end)
|
adamc@403
|
1128 | AT AT path DOT idents (let
|
adamc@403
|
1129 val loc = s (AT1left, identsright)
|
adamc@403
|
1130 in
|
adamc@403
|
1131 foldl (fn (ident, e) =>
|
adamc@403
|
1132 (EField (e, ident), loc))
|
adamc@403
|
1133 (EVar (#1 path, #2 path, DontInfer), s (pathleft, pathright)) idents
|
adamc@200
|
1134 end)
|
adamc@71
|
1135
|
adamc@360
|
1136 | XML_BEGIN xml XML_END (let
|
adamc@360
|
1137 val loc = s (XML_BEGINleft, XML_ENDright)
|
adamc@360
|
1138 in
|
adamc@360
|
1139 if XML_BEGIN = "xml" then
|
adamc@360
|
1140 ()
|
adamc@360
|
1141 else
|
adamc@360
|
1142 ErrorMsg.errorAt loc "Initial XML tag pair aren't both tagged \"xml\".";
|
adamc@360
|
1143 xml
|
adamc@360
|
1144 end)
|
adamc@360
|
1145 | XML_BEGIN XML_END (let
|
adamc@360
|
1146 val loc = s (XML_BEGINleft, XML_ENDright)
|
adamc@360
|
1147 in
|
adamc@360
|
1148 if XML_BEGIN = "xml" then
|
adamc@360
|
1149 ()
|
adamc@360
|
1150 else
|
adamc@360
|
1151 ErrorMsg.errorAt loc "Initial XML tag pair aren't both tagged \"xml\".";
|
adamc@403
|
1152 (EApp ((EVar (["Basis"], "cdata", Infer), loc),
|
adamc@360
|
1153 (EPrim (Prim.String ""), loc)),
|
adamc@360
|
1154 loc)
|
adamc@360
|
1155 end)
|
adamc@360
|
1156 | XML_BEGIN_END (let
|
adamc@360
|
1157 val loc = s (XML_BEGIN_ENDleft, XML_BEGIN_ENDright)
|
adamc@360
|
1158 in
|
adamc@360
|
1159 if XML_BEGIN_END = "xml" then
|
adamc@360
|
1160 ()
|
adamc@360
|
1161 else
|
adamc@360
|
1162 ErrorMsg.errorAt loc "Initial XML tag pair aren't both tagged \"xml\".";
|
adamc@403
|
1163 (EApp ((EVar (["Basis"], "cdata", Infer), loc),
|
adamc@360
|
1164 (EPrim (Prim.String ""), loc)),
|
adamc@360
|
1165 loc)
|
adamc@360
|
1166 end)
|
adamc@302
|
1167
|
adamc@204
|
1168 | LPAREN query RPAREN (query)
|
adamc@300
|
1169 | LPAREN CWHERE sqlexp RPAREN (sqlexp)
|
adamc@339
|
1170 | LPAREN SQL sqlexp RPAREN (sqlexp)
|
adamc@1070
|
1171 | LPAREN FROM tables RPAREN (#2 tables)
|
adamc@1071
|
1172 | LPAREN SELECT1 query1 RPAREN (query1)
|
adamc@302
|
1173
|
adamc@302
|
1174 | LPAREN INSERT INTO texp LPAREN fields RPAREN VALUES LPAREN sqlexps RPAREN RPAREN
|
adamc@302
|
1175 (let
|
adamc@302
|
1176 val loc = s (LPAREN1left, RPAREN3right)
|
adamc@302
|
1177
|
adamc@403
|
1178 val e = (EVar (["Basis"], "insert", Infer), loc)
|
adamc@302
|
1179 val e = (EApp (e, texp), loc)
|
adamc@302
|
1180 in
|
adamc@302
|
1181 if length fields <> length sqlexps then
|
adamc@302
|
1182 ErrorMsg.errorAt loc "Length mismatch in INSERT field specification"
|
adamc@302
|
1183 else
|
adamc@302
|
1184 ();
|
adamc@302
|
1185 (EApp (e, (ERecord (ListPair.zip (fields, sqlexps)), loc)), loc)
|
adamc@302
|
1186 end)
|
adamc@310
|
1187 | LPAREN enterDml UPDATE texp SET fsets CWHERE sqlexp leaveDml RPAREN
|
adamc@303
|
1188 (let
|
adamc@303
|
1189 val loc = s (LPARENleft, RPARENright)
|
adamc@303
|
1190
|
adamc@403
|
1191 val e = (EVar (["Basis"], "update", Infer), loc)
|
adamc@342
|
1192 val e = (ECApp (e, (CWild (KRecord (KType, loc), loc), loc)), loc)
|
adamc@306
|
1193 val e = (EApp (e, (ERecord fsets, loc)), loc)
|
adamc@305
|
1194 val e = (EApp (e, texp), loc)
|
adamc@303
|
1195 in
|
adamc@303
|
1196 (EApp (e, sqlexp), loc)
|
adamc@303
|
1197 end)
|
adamc@310
|
1198 | LPAREN enterDml DELETE FROM texp CWHERE sqlexp leaveDml RPAREN
|
adamc@304
|
1199 (let
|
adamc@304
|
1200 val loc = s (LPARENleft, RPARENright)
|
adamc@304
|
1201
|
adamc@403
|
1202 val e = (EVar (["Basis"], "delete", Infer), loc)
|
adamc@304
|
1203 val e = (EApp (e, texp), loc)
|
adamc@304
|
1204 in
|
adamc@304
|
1205 (EApp (e, sqlexp), loc)
|
adamc@304
|
1206 end)
|
adamc@302
|
1207
|
adamc@211
|
1208 | UNDER (EWild, s (UNDERleft, UNDERright))
|
adamc@91
|
1209
|
adamc@446
|
1210 | LET edecls IN eexp END (ELet (edecls, eexp), s (LETleft, ENDright))
|
adamc@446
|
1211
|
adamc@762
|
1212 | LBRACK RBRACK (EVar (["Basis"], "Nil", Infer), s (LBRACKleft, RBRACKright))
|
adamc@762
|
1213
|
adamc@446
|
1214 edecls : ([])
|
adamc@446
|
1215 | edecl edecls (edecl :: edecls)
|
adamc@446
|
1216
|
adamc@825
|
1217 edecl : VAL pat EQ eexp ((EDVal (pat, eexp), s (VALleft, eexpright)))
|
adamc@446
|
1218 | VAL REC valis ((EDValRec valis, s (VALleft, valisright)))
|
adamc@446
|
1219 | FUN valis ((EDValRec valis, s (FUNleft, valisright)))
|
adamc@446
|
1220
|
adamc@310
|
1221 enterDml : (inDml := true)
|
adamc@310
|
1222 leaveDml : (inDml := false)
|
adamc@310
|
1223
|
adamc@403
|
1224 texp : SYMBOL (EVar ([], SYMBOL, Infer), s (SYMBOLleft, SYMBOLright))
|
adamc@302
|
1225 | LBRACE LBRACE eexp RBRACE RBRACE (eexp)
|
adamc@302
|
1226
|
adamc@302
|
1227 fields : fident ([fident])
|
adamc@302
|
1228 | fident COMMA fields (fident :: fields)
|
adamc@302
|
1229
|
adamc@302
|
1230 sqlexps: sqlexp ([sqlexp])
|
adamc@302
|
1231 | sqlexp COMMA sqlexps (sqlexp :: sqlexps)
|
adamc@302
|
1232
|
adamc@303
|
1233 fsets : fident EQ sqlexp ([(fident, sqlexp)])
|
adamc@303
|
1234 | fident EQ sqlexp COMMA fsets ((fident, sqlexp) :: fsets)
|
adamc@303
|
1235
|
adamc@200
|
1236 idents : ident ([ident])
|
adamc@200
|
1237 | ident DOT idents (ident :: idents)
|
adamc@200
|
1238
|
adamc@195
|
1239 etuple : eexp COMMA eexp ([eexp1, eexp2])
|
adamc@195
|
1240 | eexp COMMA etuple (eexp :: etuple)
|
adamc@195
|
1241
|
adamc@170
|
1242 branch : pat DARROW eexp (pat, eexp)
|
adamc@170
|
1243
|
adamc@170
|
1244 branchs: ([])
|
adamc@170
|
1245 | BAR branch branchs (branch :: branchs)
|
adamc@170
|
1246
|
adamc@822
|
1247 patS : pterm (pterm)
|
adamc@822
|
1248 | pterm DCOLON patS (let
|
adamc@822
|
1249 val loc = s (ptermleft, patSright)
|
adamc@762
|
1250 in
|
adamc@762
|
1251 (PCon (["Basis"], "Cons", SOME (PRecord ([("1", pterm),
|
adamc@822
|
1252 ("2", patS)], false), loc)),
|
adamc@762
|
1253 loc)
|
adamc@762
|
1254 end)
|
adamc@822
|
1255 | patS COLON cexp (PAnnot (patS, cexp), s (patSleft, cexpright))
|
adamc@822
|
1256
|
adamc@822
|
1257 pat : patS (patS)
|
adamc@822
|
1258 | cpath pterm (PCon (#1 cpath, #2 cpath, SOME pterm), s (cpathleft, ptermright))
|
adamc@170
|
1259
|
adamc@170
|
1260 pterm : SYMBOL (PVar SYMBOL, s (SYMBOLleft, SYMBOLright))
|
adamc@170
|
1261 | cpath (PCon (#1 cpath, #2 cpath, NONE), s (cpathleft, cpathright))
|
adamc@170
|
1262 | UNDER (PWild, s (UNDERleft, UNDERright))
|
adamc@173
|
1263 | INT (PPrim (Prim.Int INT), s (INTleft, INTright))
|
adamc@173
|
1264 | STRING (PPrim (Prim.String STRING), s (STRINGleft, STRINGright))
|
adamc@821
|
1265 | CHAR (PPrim (Prim.Char CHAR), s (CHARleft, CHARright))
|
adamc@170
|
1266 | LPAREN pat RPAREN (pat)
|
adamc@174
|
1267 | LBRACE RBRACE (PRecord ([], false), s (LBRACEleft, RBRACEright))
|
adamc@174
|
1268 | UNIT (PRecord ([], false), s (UNITleft, UNITright))
|
adamc@174
|
1269 | LBRACE rpat RBRACE (PRecord rpat, s (LBRACEleft, RBRACEright))
|
adamc@195
|
1270 | LPAREN ptuple RPAREN (PRecord (ListUtil.mapi (fn (i, p) => (Int.toString (i + 1), p)) ptuple,
|
adamc@195
|
1271 false),
|
adamc@195
|
1272 s (LPARENleft, RPARENright))
|
adamc@762
|
1273 | LBRACK RBRACK (PCon (["Basis"], "Nil", NONE), s (LBRACKleft, RBRACKright))
|
adamc@174
|
1274
|
adamc@175
|
1275 rpat : CSYMBOL EQ pat ([(CSYMBOL, pat)], false)
|
adamc@243
|
1276 | INT EQ pat ([(Int64.toString INT, pat)], false)
|
adamc@174
|
1277 | DOTDOTDOT ([], true)
|
adamc@175
|
1278 | CSYMBOL EQ pat COMMA rpat ((CSYMBOL, pat) :: #1 rpat, #2 rpat)
|
adamc@243
|
1279 | INT EQ pat COMMA rpat ((Int64.toString INT, pat) :: #1 rpat, #2 rpat)
|
adamc@170
|
1280
|
adamc@195
|
1281 ptuple : pat COMMA pat ([pat1, pat2])
|
adamc@195
|
1282 | pat COMMA ptuple (pat :: ptuple)
|
adamc@195
|
1283
|
adamc@12
|
1284 rexp : ([])
|
adamc@12
|
1285 | ident EQ eexp ([(ident, eexp)])
|
adamc@12
|
1286 | ident EQ eexp COMMA rexp ((ident, eexp) :: rexp)
|
adamc@91
|
1287
|
adamc@141
|
1288 xml : xmlOne xml (let
|
adamc@141
|
1289 val pos = s (xmlOneleft, xmlright)
|
adamc@141
|
1290 in
|
adamc@720
|
1291 (EApp ((EApp (
|
adamc@720
|
1292 (EVar (["Basis"], "join", Infer), pos),
|
adamc@720
|
1293 xmlOne), pos),
|
adamc@720
|
1294 xml), pos)
|
adamc@141
|
1295 end)
|
adamc@141
|
1296 | xmlOne (xmlOne)
|
adamc@91
|
1297
|
adamc@1045
|
1298 xmlOpt : xml (xml)
|
adamc@1045
|
1299 | (EApp ((EVar (["Basis"], "cdata", Infer), dummy),
|
adamc@1045
|
1300 (EPrim (Prim.String ""), dummy)),
|
adamc@1045
|
1301 dummy)
|
adamc@1045
|
1302
|
adamc@403
|
1303 xmlOne : NOTAGS (EApp ((EVar (["Basis"], "cdata", Infer), s (NOTAGSleft, NOTAGSright)),
|
adamc@141
|
1304 (EPrim (Prim.String NOTAGS), s (NOTAGSleft, NOTAGSright))),
|
adamc@141
|
1305 s (NOTAGSleft, NOTAGSright))
|
adamc@141
|
1306 | tag DIVIDE GT (let
|
adamc@141
|
1307 val pos = s (tagleft, GTright)
|
adamc@710
|
1308
|
adamc@710
|
1309 val cdata =
|
adamc@756
|
1310 if #1 (#1 tag) = "submit" orelse #1 (#1 tag) = "dyn" then
|
adamc@710
|
1311 let
|
adamc@710
|
1312 val e = (EVar (["Basis"], "cdata", DontInfer), pos)
|
adamc@710
|
1313 val e = (ECApp (e, (CWild (KWild, pos), pos)), pos)
|
adamc@710
|
1314 in
|
adamc@710
|
1315 (ECApp (e, (CRecord [], pos)), pos)
|
adamc@710
|
1316 end
|
adamc@710
|
1317 else
|
adamc@710
|
1318 (EVar (["Basis"], "cdata", Infer), pos)
|
adamc@710
|
1319
|
adamc@710
|
1320 val cdata = (EApp (cdata,
|
adamc@710
|
1321 (EPrim (Prim.String ""), pos)),
|
adamc@710
|
1322 pos)
|
adamc@141
|
1323 in
|
adamc@710
|
1324 (EApp (#2 tag, cdata), pos)
|
adamc@141
|
1325 end)
|
adamc@141
|
1326
|
adamc@1045
|
1327 | tag GT xmlOpt END_TAG (let
|
adamc@141
|
1328 val pos = s (tagleft, GTright)
|
adamc@325
|
1329 val et = tagIn END_TAG
|
adamc@141
|
1330 in
|
adamc@756
|
1331 if #1 (#1 tag) = et then
|
adamc@361
|
1332 if et = "form" then
|
adamc@403
|
1333 (EApp ((EVar (["Basis"], "form", Infer), pos),
|
adamc@1045
|
1334 xmlOpt), pos)
|
adamc@1093
|
1335 else if et = "subform" orelse et = "subforms" then
|
adamc@1093
|
1336 (EApp (#2 (#1 tag),
|
adamc@1045
|
1337 xmlOpt), pos)
|
adamc@758
|
1338 else if et = "entry" then
|
adamc@758
|
1339 (EApp ((EVar (["Basis"], "entry", Infer), pos),
|
adamc@1045
|
1340 xmlOpt), pos)
|
adamc@141
|
1341 else
|
adamc@1045
|
1342 (EApp (#2 tag, xmlOpt), pos)
|
adamc@141
|
1343 else
|
adamc@325
|
1344 (if ErrorMsg.anyErrors () then
|
adamc@325
|
1345 ()
|
adamc@325
|
1346 else
|
adamc@1189
|
1347 ErrorMsg.errorAt pos ("Begin tag <"
|
adamc@1189
|
1348 ^ #1 (#1 tag)
|
adamc@1189
|
1349 ^ "> and end tag </"
|
adamc@1189
|
1350 ^ et
|
adamc@1189
|
1351 ^ "> don't match.");
|
adamc@623
|
1352 (EWild, pos))
|
adamc@141
|
1353 end)
|
adamc@141
|
1354 | LBRACE eexp RBRACE (eexp)
|
adamc@391
|
1355 | LBRACE LBRACK eexp RBRACK RBRACE (let
|
adamc@391
|
1356 val loc = s (LBRACEleft, RBRACEright)
|
adamc@403
|
1357 val e = (EVar (["Top"], "txt", Infer), loc)
|
adamc@391
|
1358 in
|
adamc@391
|
1359 (EApp (e, eexp), loc)
|
adamc@391
|
1360 end)
|
adamc@92
|
1361
|
adamc@141
|
1362 tag : tagHead attrs (let
|
adamc@141
|
1363 val pos = s (tagHeadleft, attrsright)
|
adamc@721
|
1364
|
adamc@721
|
1365 val e = (EVar (["Basis"], "tag", Infer), pos)
|
adamc@721
|
1366 val eo = case #1 attrs of
|
adamc@721
|
1367 NONE => (EVar (["Basis"], "None", Infer), pos)
|
adamc@721
|
1368 | SOME e => (EApp ((EVar (["Basis"], "Some", Infer), pos),
|
adamc@721
|
1369 e), pos)
|
adamc@721
|
1370 val e = (EApp (e, eo), pos)
|
adamc@721
|
1371 val e = (EApp (e, (ERecord (#2 attrs), pos)), pos)
|
adamc@721
|
1372 val e = (EApp (e, (EApp (#2 tagHead,
|
adamc@721
|
1373 (ERecord [], pos)), pos)), pos)
|
adamc@141
|
1374 in
|
adamc@756
|
1375 (tagHead, e)
|
adamc@141
|
1376 end)
|
adamc@141
|
1377
|
adamc@141
|
1378 tagHead: BEGIN_TAG (let
|
adamc@325
|
1379 val bt = tagIn BEGIN_TAG
|
adamc@141
|
1380 val pos = s (BEGIN_TAGleft, BEGIN_TAGright)
|
adamc@141
|
1381 in
|
adamc@325
|
1382 (bt,
|
adamc@473
|
1383 (EVar (["Basis"], bt, Infer), pos))
|
adamc@141
|
1384 end)
|
adamc@141
|
1385 | tagHead LBRACE cexp RBRACE (#1 tagHead, (ECApp (#2 tagHead, cexp), s (tagHeadleft, RBRACEright)))
|
adamc@92
|
1386
|
adamc@721
|
1387 attrs : (NONE, [])
|
adamc@721
|
1388 | attr attrs (let
|
adamc@721
|
1389 val loc = s (attrleft, attrsright)
|
adamc@721
|
1390 in
|
adamc@721
|
1391 case attr of
|
adamc@721
|
1392 Class e =>
|
adamc@721
|
1393 (case #1 attrs of
|
adamc@721
|
1394 NONE => ()
|
adamc@721
|
1395 | SOME _ => ErrorMsg.errorAt loc "Multiple classes specified for tag";
|
adamc@721
|
1396 (SOME e, #2 attrs))
|
adamc@721
|
1397 | Normal xe =>
|
adamc@721
|
1398 (#1 attrs, xe :: #2 attrs)
|
adamc@721
|
1399 end)
|
adamc@104
|
1400
|
adamc@721
|
1401 attr : SYMBOL EQ attrv (if SYMBOL = "class" then
|
adamc@721
|
1402 Class attrv
|
adamc@717
|
1403 else
|
adamc@724
|
1404 let
|
adamc@724
|
1405 val sym =
|
adamc@724
|
1406 case SYMBOL of
|
adamc@724
|
1407 "type" => "Typ"
|
adamc@724
|
1408 | x => capitalize x
|
adamc@724
|
1409 in
|
adamc@724
|
1410 Normal ((CName sym, s (SYMBOLleft, SYMBOLright)),
|
adamc@724
|
1411 if (sym = "Href" orelse sym = "Src")
|
adamc@724
|
1412 andalso (case #1 attrv of
|
adamc@724
|
1413 EPrim _ => true
|
adamc@724
|
1414 | _ => false) then
|
adamc@724
|
1415 let
|
adamc@724
|
1416 val loc = s (attrvleft, attrvright)
|
adamc@724
|
1417 in
|
adamc@724
|
1418 (EApp ((EVar (["Basis"], "bless", Infer), loc),
|
adamc@724
|
1419 attrv), loc)
|
adamc@724
|
1420 end
|
adamc@724
|
1421 else
|
adamc@724
|
1422 attrv)
|
adamc@724
|
1423 end)
|
adamc@204
|
1424
|
adamc@104
|
1425 attrv : INT (EPrim (Prim.Int INT), s (INTleft, INTright))
|
adamc@104
|
1426 | FLOAT (EPrim (Prim.Float FLOAT), s (FLOATleft, FLOATright))
|
adamc@104
|
1427 | STRING (EPrim (Prim.String STRING), s (STRINGleft, STRINGright))
|
adamc@110
|
1428 | LBRACE eexp RBRACE (eexp)
|
adamc@226
|
1429
|
adamc@232
|
1430 query : query1 obopt lopt ofopt (let
|
adamc@229
|
1431 val loc = s (query1left, query1right)
|
adamc@230
|
1432
|
adamc@230
|
1433 val re = (ERecord [((CName "Rows", loc),
|
adamc@230
|
1434 query1),
|
adamc@230
|
1435 ((CName "OrderBy", loc),
|
adamc@231
|
1436 obopt),
|
adamc@231
|
1437 ((CName "Limit", loc),
|
adamc@232
|
1438 lopt),
|
adamc@232
|
1439 ((CName "Offset", loc),
|
adamc@232
|
1440 ofopt)], loc)
|
adamc@229
|
1441 in
|
adamc@403
|
1442 (EApp ((EVar (["Basis"], "sql_query", Infer), loc), re), loc)
|
adamc@229
|
1443 end)
|
adamc@993
|
1444
|
adamc@993
|
1445 dopt : (EVar (["Basis"], "False", Infer), dummy)
|
adamc@993
|
1446 | DISTINCT (EVar (["Basis"], "True", Infer),
|
adamc@993
|
1447 s (DISTINCTleft, DISTINCTright))
|
adamc@993
|
1448
|
adamc@993
|
1449 query1 : SELECT dopt select FROM tables wopt gopt hopt
|
adamc@209
|
1450 (let
|
adamc@204
|
1451 val loc = s (SELECTleft, tablesright)
|
adamc@207
|
1452
|
adamc@1070
|
1453 val (empties, sel, exps) =
|
adamc@207
|
1454 case select of
|
adamc@1070
|
1455 Star => ([],
|
adamc@1070
|
1456 map (fn nm =>
|
adamc@233
|
1457 (nm, (CTuple [(CWild (KRecord (KType, loc), loc),
|
adamc@233
|
1458 loc),
|
adamc@233
|
1459 (CRecord [], loc)],
|
adamc@748
|
1460 loc))) (#1 tables),
|
adamc@233
|
1461 [])
|
adamc@207
|
1462 | Items sis =>
|
adamc@207
|
1463 let
|
adamc@748
|
1464 val tabs = map (fn nm => (nm, (CRecord [], loc))) (#1 tables)
|
adamc@1194
|
1465 val (_, tabs, exps) = foldl (amend_select loc)
|
adamc@1194
|
1466 (1, tabs, []) sis
|
adamc@1070
|
1467 val empties = List.mapPartial (fn (nm, (CRecord [], _)) =>
|
adamc@1070
|
1468 SOME nm
|
adamc@1070
|
1469 | _ => NONE) tabs
|
adamc@207
|
1470 in
|
adamc@1070
|
1471 (empties,
|
adamc@1070
|
1472 map (fn (nm, c) => (nm,
|
adamc@233
|
1473 (CTuple [c,
|
adamc@233
|
1474 (CWild (KRecord (KType, loc), loc),
|
adamc@233
|
1475 loc)], loc))) tabs,
|
adamc@233
|
1476 exps)
|
adamc@207
|
1477 end
|
adamc@207
|
1478
|
adamc@207
|
1479 val sel = (CRecord sel, loc)
|
adamc@207
|
1480
|
adamc@226
|
1481 val grp = case gopt of
|
adamc@403
|
1482 NONE => (ECApp ((EVar (["Basis"], "sql_subset_all",
|
adamc@403
|
1483 Infer), loc),
|
adamc@226
|
1484 (CWild (KRecord (KRecord (KType, loc), loc),
|
adamc@226
|
1485 loc), loc)), loc)
|
adamc@226
|
1486 | SOME gis =>
|
adamc@226
|
1487 let
|
adamc@748
|
1488 val tabs = map (fn nm =>
|
adamc@748
|
1489 (nm, (CRecord [], loc))) (#1 tables)
|
adamc@226
|
1490 val tabs = foldl (amend_group loc) tabs gis
|
adamc@226
|
1491
|
adamc@226
|
1492 val tabs = map (fn (nm, c) =>
|
adamc@226
|
1493 (nm,
|
adamc@226
|
1494 (CTuple [c,
|
adamc@226
|
1495 (CWild (KRecord (KType, loc),
|
adamc@226
|
1496 loc),
|
adamc@226
|
1497 loc)], loc))) tabs
|
adamc@226
|
1498 in
|
adamc@403
|
1499 (ECApp ((EVar (["Basis"], "sql_subset", Infer), loc),
|
adamc@226
|
1500 (CRecord tabs, loc)), loc)
|
adamc@226
|
1501 end
|
adamc@226
|
1502
|
adamc@403
|
1503 val e = (EVar (["Basis"], "sql_query1", Infer), loc)
|
adamc@1070
|
1504 val e = (ECApp (e, (CRecord (map (fn nm => (nm, (CUnit, loc))) empties),
|
adamc@1070
|
1505 loc)), loc)
|
adamc@993
|
1506 val re = (ERecord [((CName "Distinct", loc),
|
adamc@993
|
1507 dopt),
|
adamc@993
|
1508 ((CName "From", loc),
|
adamc@748
|
1509 #2 tables),
|
adamc@209
|
1510 ((CName "Where", loc),
|
adamc@223
|
1511 wopt),
|
adamc@224
|
1512 ((CName "GroupBy", loc),
|
adamc@226
|
1513 grp),
|
adamc@224
|
1514 ((CName "Having", loc),
|
adamc@224
|
1515 hopt),
|
adamc@223
|
1516 ((CName "SelectFields", loc),
|
adamc@403
|
1517 (ECApp ((EVar (["Basis"], "sql_subset", Infer), loc),
|
adamc@233
|
1518 sel), loc)),
|
adamc@233
|
1519 ((CName "SelectExps", loc),
|
adamc@233
|
1520 (ERecord exps, loc))], loc)
|
adamc@223
|
1521
|
adamc@209
|
1522 val e = (EApp (e, re), loc)
|
adamc@204
|
1523 in
|
adamc@207
|
1524 e
|
adamc@204
|
1525 end)
|
adamc@229
|
1526 | query1 UNION query1 (sql_relop ("union", query11, query12, s (query11left, query12right)))
|
adamc@229
|
1527 | query1 INTERSECT query1 (sql_relop ("intersect", query11, query12, s (query11left, query12right)))
|
adamc@229
|
1528 | query1 EXCEPT query1 (sql_relop ("except", query11, query12, s (query11left, query12right)))
|
adamc@1070
|
1529 | LBRACE LBRACE LBRACE eexp RBRACE RBRACE RBRACE (eexp)
|
adamc@204
|
1530
|
adamc@749
|
1531 tables : fitem (fitem)
|
adamc@749
|
1532 | fitem COMMA tables (let
|
adamc@749
|
1533 val loc = s (fitemleft, tablesright)
|
adamc@748
|
1534
|
adamc@748
|
1535 val e = (EVar (["Basis"], "sql_from_comma", Infer), loc)
|
adamc@749
|
1536 val e = (EApp (e, #2 fitem), loc)
|
adamc@748
|
1537 in
|
adamc@749
|
1538 (#1 fitem @ #1 tables,
|
adamc@748
|
1539 (EApp (e, #2 tables), loc))
|
adamc@748
|
1540 end)
|
adamc@204
|
1541
|
adamc@749
|
1542 fitem : table' ([#1 table'], #2 table')
|
adamc@1071
|
1543 | LBRACE LBRACE eexp RBRACE RBRACE ([], eexp)
|
adamc@749
|
1544 | fitem JOIN fitem ON sqlexp (let
|
adamc@749
|
1545 val loc = s (fitem1left, sqlexpright)
|
adamc@749
|
1546
|
adamc@749
|
1547 val e = (EVar (["Basis"], "sql_inner_join", Infer), loc)
|
adamc@749
|
1548 val e = (EApp (e, #2 fitem1), loc)
|
adamc@749
|
1549 val e = (EApp (e, #2 fitem2), loc)
|
adamc@749
|
1550 in
|
adamc@749
|
1551 (#1 fitem1 @ #1 fitem2,
|
adamc@749
|
1552 (EApp (e, sqlexp), loc))
|
adamc@749
|
1553 end)
|
adamc@749
|
1554 | fitem INNER JOIN fitem ON sqlexp (let
|
adamc@749
|
1555 val loc = s (fitem1left, sqlexpright)
|
adamc@749
|
1556
|
adamc@749
|
1557 val e = (EVar (["Basis"], "sql_inner_join", Infer), loc)
|
adamc@749
|
1558 val e = (EApp (e, #2 fitem1), loc)
|
adamc@749
|
1559 val e = (EApp (e, #2 fitem2), loc)
|
adamc@749
|
1560 in
|
adamc@749
|
1561 (#1 fitem1 @ #1 fitem2,
|
adamc@749
|
1562 (EApp (e, sqlexp), loc))
|
adamc@749
|
1563 end)
|
adamc@749
|
1564 | fitem CROSS JOIN fitem (let
|
adamc@749
|
1565 val loc = s (fitem1left, fitem2right)
|
adamc@749
|
1566
|
adamc@749
|
1567 val e = (EVar (["Basis"], "sql_inner_join", Infer), loc)
|
adamc@749
|
1568 val e = (EApp (e, #2 fitem1), loc)
|
adamc@749
|
1569 val e = (EApp (e, #2 fitem2), loc)
|
adamc@749
|
1570 val tru = sql_inject (EVar (["Basis"], "True", Infer), loc)
|
adamc@749
|
1571 in
|
adamc@749
|
1572 (#1 fitem1 @ #1 fitem2,
|
adamc@749
|
1573 (EApp (e, tru), loc))
|
adamc@749
|
1574 end)
|
adamc@750
|
1575 | fitem LEFT JOIN fitem ON sqlexp (let
|
adamc@750
|
1576 val loc = s (fitem1left, sqlexpright)
|
adamc@750
|
1577
|
adamc@750
|
1578 val e = (EVar (["Basis"], "sql_left_join", Infer), loc)
|
adamc@750
|
1579 val e = (EApp (e, #2 fitem1), loc)
|
adamc@750
|
1580 val e = (EApp (e, #2 fitem2), loc)
|
adamc@750
|
1581 in
|
adamc@750
|
1582 (#1 fitem1 @ #1 fitem2,
|
adamc@750
|
1583 (EApp (e, sqlexp), loc))
|
adamc@750
|
1584 end)
|
adamc@751
|
1585 | fitem LEFT OUTER JOIN fitem ON sqlexp (let
|
adamc@751
|
1586 val loc = s (fitem1left, sqlexpright)
|
adamc@751
|
1587
|
adamc@751
|
1588 val e = (EVar (["Basis"], "sql_left_join", Infer), loc)
|
adamc@751
|
1589 val e = (EApp (e, #2 fitem1), loc)
|
adamc@751
|
1590 val e = (EApp (e, #2 fitem2), loc)
|
adamc@751
|
1591 in
|
adamc@751
|
1592 (#1 fitem1 @ #1 fitem2,
|
adamc@751
|
1593 (EApp (e, sqlexp), loc))
|
adamc@751
|
1594 end)
|
adamc@751
|
1595 | fitem RIGHT JOIN fitem ON sqlexp (let
|
adamc@751
|
1596 val loc = s (fitem1left, sqlexpright)
|
adamc@751
|
1597
|
adamc@751
|
1598 val e = (EVar (["Basis"], "sql_right_join", Infer), loc)
|
adamc@751
|
1599 val e = (EApp (e, #2 fitem1), loc)
|
adamc@751
|
1600 val e = (EApp (e, #2 fitem2), loc)
|
adamc@751
|
1601 in
|
adamc@751
|
1602 (#1 fitem1 @ #1 fitem2,
|
adamc@751
|
1603 (EApp (e, sqlexp), loc))
|
adamc@751
|
1604 end)
|
adamc@751
|
1605 | fitem RIGHT OUTER JOIN fitem ON sqlexp (let
|
adamc@751
|
1606 val loc = s (fitem1left, sqlexpright)
|
adamc@751
|
1607
|
adamc@751
|
1608 val e = (EVar (["Basis"], "sql_right_join", Infer), loc)
|
adamc@751
|
1609 val e = (EApp (e, #2 fitem1), loc)
|
adamc@751
|
1610 val e = (EApp (e, #2 fitem2), loc)
|
adamc@751
|
1611 in
|
adamc@751
|
1612 (#1 fitem1 @ #1 fitem2,
|
adamc@751
|
1613 (EApp (e, sqlexp), loc))
|
adamc@751
|
1614 end)
|
adamc@751
|
1615 | fitem FULL JOIN fitem ON sqlexp (let
|
adamc@751
|
1616 val loc = s (fitem1left, sqlexpright)
|
adamc@751
|
1617
|
adamc@751
|
1618 val e = (EVar (["Basis"], "sql_full_join", Infer), loc)
|
adamc@751
|
1619 val e = (EApp (e, #2 fitem1), loc)
|
adamc@751
|
1620 val e = (EApp (e, #2 fitem2), loc)
|
adamc@751
|
1621 in
|
adamc@751
|
1622 (#1 fitem1 @ #1 fitem2,
|
adamc@751
|
1623 (EApp (e, sqlexp), loc))
|
adamc@751
|
1624 end)
|
adamc@751
|
1625 | fitem FULL OUTER JOIN fitem ON sqlexp (let
|
adamc@751
|
1626 val loc = s (fitem1left, sqlexpright)
|
adamc@751
|
1627
|
adamc@751
|
1628 val e = (EVar (["Basis"], "sql_full_join", Infer), loc)
|
adamc@751
|
1629 val e = (EApp (e, #2 fitem1), loc)
|
adamc@751
|
1630 val e = (EApp (e, #2 fitem2), loc)
|
adamc@751
|
1631 in
|
adamc@751
|
1632 (#1 fitem1 @ #1 fitem2,
|
adamc@751
|
1633 (EApp (e, sqlexp), loc))
|
adamc@751
|
1634 end)
|
adamc@1192
|
1635 | LPAREN query RPAREN AS tname (let
|
adamc@1192
|
1636 val loc = s (LPARENleft, RPARENright)
|
adamc@1192
|
1637
|
adamc@1192
|
1638 val e = (EVar (["Basis"], "sql_from_query", Infer), loc)
|
adamc@1192
|
1639 val e = (ECApp (e, tname), loc)
|
adamc@1192
|
1640 in
|
adamc@1192
|
1641 ([tname], (EApp (e, query), loc))
|
adamc@1192
|
1642 end)
|
adamc@749
|
1643
|
adamc@204
|
1644 tname : CSYMBOL (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright))
|
adamc@204
|
1645 | LBRACE cexp RBRACE (cexp)
|
adamc@204
|
1646
|
adamc@243
|
1647 table : SYMBOL ((CName (capitalize SYMBOL), s (SYMBOLleft, SYMBOLright)),
|
adamc@403
|
1648 (EVar ([], SYMBOL, Infer), s (SYMBOLleft, SYMBOLright)))
|
adamc@403
|
1649 | SYMBOL AS tname (tname, (EVar ([], SYMBOL, Infer), s (SYMBOLleft, SYMBOLright)))
|
adamc@221
|
1650 | LBRACE LBRACE eexp RBRACE RBRACE AS tname (tname, eexp)
|
adamc@207
|
1651
|
adamc@748
|
1652 table' : table (let
|
adamc@748
|
1653 val loc = s (tableleft, tableright)
|
adamc@748
|
1654 val e = (EVar (["Basis"], "sql_from_table", Infer), loc)
|
adamc@748
|
1655 val e = (ECApp (e, #1 table), loc)
|
adamc@748
|
1656 in
|
adamc@748
|
1657 (#1 table, (EApp (e, #2 table), loc))
|
adamc@748
|
1658 end)
|
adamc@748
|
1659
|
adamc@243
|
1660 tident : SYMBOL (CName (capitalize SYMBOL), s (SYMBOLleft, SYMBOLright))
|
adamc@207
|
1661 | CSYMBOL (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright))
|
adamc@221
|
1662 | LBRACE LBRACE cexp RBRACE RBRACE (cexp)
|
adamc@207
|
1663
|
adamc@207
|
1664 fident : CSYMBOL (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright))
|
adamc@207
|
1665 | LBRACE cexp RBRACE (cexp)
|
adamc@207
|
1666
|
adamc@207
|
1667 seli : tident DOT fident (Field (tident, fident))
|
adamc@1194
|
1668 | sqlexp (Exp (NONE, sqlexp))
|
adamc@1194
|
1669 | sqlexp AS fident (Exp (SOME fident, sqlexp))
|
adamc@341
|
1670 | tident DOT LBRACE LBRACE cexp RBRACE RBRACE (Fields (tident, cexp))
|
adamc@207
|
1671
|
adamc@207
|
1672 selis : seli ([seli])
|
adamc@207
|
1673 | seli COMMA selis (seli :: selis)
|
adamc@207
|
1674
|
adamc@207
|
1675 select : STAR (Star)
|
adamc@207
|
1676 | selis (Items selis)
|
adamc@209
|
1677
|
adamc@403
|
1678 sqlexp : TRUE (sql_inject (EVar (["Basis"], "True", Infer),
|
adamc@209
|
1679 s (TRUEleft, TRUEright)))
|
adamc@403
|
1680 | FALSE (sql_inject (EVar (["Basis"], "False", Infer),
|
adamc@209
|
1681 s (FALSEleft, FALSEright)))
|
adamc@209
|
1682
|
adamc@222
|
1683 | INT (sql_inject (EPrim (Prim.Int INT),
|
adamc@222
|
1684 s (INTleft, INTright)))
|
adamc@222
|
1685 | FLOAT (sql_inject (EPrim (Prim.Float FLOAT),
|
adamc@222
|
1686 s (FLOATleft, FLOATright)))
|
adamc@229
|
1687 | STRING (sql_inject (EPrim (Prim.String STRING),
|
adamc@229
|
1688 s (STRINGleft, STRINGright)))
|
adamc@441
|
1689 | CURRENT_TIMESTAMP (sql_nfunc ("current_timestamp",
|
adamc@441
|
1690 s (CURRENT_TIMESTAMPleft, CURRENT_TIMESTAMPright)))
|
adamc@222
|
1691
|
adamc@221
|
1692 | tident DOT fident (let
|
adamc@221
|
1693 val loc = s (tidentleft, fidentright)
|
adamc@403
|
1694 val e = (EVar (["Basis"], "sql_field", Infer), loc)
|
adamc@221
|
1695 val e = (ECApp (e, tident), loc)
|
adamc@221
|
1696 in
|
adamc@221
|
1697 (ECApp (e, fident), loc)
|
adamc@221
|
1698 end)
|
adamc@234
|
1699 | CSYMBOL (let
|
adamc@234
|
1700 val loc = s (CSYMBOLleft, CSYMBOLright)
|
adamc@310
|
1701 in
|
adamc@310
|
1702 if !inDml then
|
adamc@310
|
1703 let
|
adamc@403
|
1704 val e = (EVar (["Basis"], "sql_field", Infer), loc)
|
adamc@310
|
1705 val e = (ECApp (e, (CName "T", loc)), loc)
|
adamc@310
|
1706 in
|
adamc@310
|
1707 (ECApp (e, (CName CSYMBOL, loc)), loc)
|
adamc@310
|
1708 end
|
adamc@310
|
1709 else
|
adamc@310
|
1710 let
|
adamc@403
|
1711 val e = (EVar (["Basis"], "sql_exp", Infer), loc)
|
adamc@310
|
1712 in
|
adamc@310
|
1713 (ECApp (e, (CName CSYMBOL, loc)), loc)
|
adamc@310
|
1714 end
|
adamc@310
|
1715 end)
|
adamc@221
|
1716
|
adamc@471
|
1717 | LBRACE eexp RBRACE (eexp)
|
adamc@470
|
1718
|
adamc@559
|
1719 | sqlexp EQ sqlexp (sql_binary ("eq", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
|
adamc@559
|
1720 | sqlexp NE sqlexp (sql_binary ("ne", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
|
adamc@559
|
1721 | sqlexp LT sqlexp (sql_binary ("lt", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
|
adamc@559
|
1722 | sqlexp LE sqlexp (sql_binary ("le", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
|
adamc@559
|
1723 | sqlexp GT sqlexp (sql_binary ("gt", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
|
adamc@559
|
1724 | sqlexp GE sqlexp (sql_binary ("ge", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
|
adamc@559
|
1725
|
adamc@559
|
1726 | sqlexp PLUS sqlexp (sql_binary ("plus", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
|
adamc@559
|
1727 | sqlexp MINUS sqlexp (sql_binary ("minus", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
|
adamc@559
|
1728 | sqlexp STAR sqlexp (sql_binary ("times", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
|
adamc@559
|
1729 | sqlexp DIVIDE sqlexp (sql_binary ("div", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
|
adamc@559
|
1730 | sqlexp MOD sqlexp (sql_binary ("mod", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
|
adamc@219
|
1731
|
adamc@220
|
1732 | sqlexp CAND sqlexp (sql_binary ("and", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
|
adamc@220
|
1733 | sqlexp OR sqlexp (sql_binary ("or", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
|
adamc@559
|
1734
|
adamc@220
|
1735 | NOT sqlexp (sql_unary ("not", sqlexp, s (NOTleft, sqlexpright)))
|
adamc@559
|
1736 | MINUS sqlexp (sql_unary ("neg", sqlexp, s (MINUSleft, sqlexpright)))
|
adamc@220
|
1737
|
adamc@470
|
1738 | sqlexp IS NULL (let
|
adamc@470
|
1739 val loc = s (sqlexpleft, NULLright)
|
adamc@470
|
1740 in
|
adamc@470
|
1741 (EApp ((EVar (["Basis"], "sql_is_null", Infer), loc),
|
adamc@470
|
1742 sqlexp), loc)
|
adamc@470
|
1743 end)
|
adamc@470
|
1744
|
adamc@471
|
1745 | LBRACE LBRACK eexp RBRACK RBRACE (sql_inject (#1 eexp,
|
adamc@471
|
1746 s (LBRACEleft, RBRACEright)))
|
adamc@220
|
1747 | LPAREN sqlexp RPAREN (sqlexp)
|
adamc@210
|
1748
|
adamc@467
|
1749 | NULL (sql_inject ((EVar (["Basis"], "None", Infer),
|
adamc@467
|
1750 s (NULLleft, NULLright))))
|
adamc@467
|
1751
|
adamc@235
|
1752 | COUNT LPAREN STAR RPAREN (let
|
adamc@235
|
1753 val loc = s (COUNTleft, RPARENright)
|
adamc@235
|
1754 in
|
adamc@544
|
1755 (EVar (["Basis"], "sql_count", Infer), loc)
|
adamc@235
|
1756 end)
|
adamc@1187
|
1757 | COUNT LPAREN sqlexp RPAREN (let
|
adamc@1187
|
1758 val loc = s (COUNTleft, RPARENright)
|
adamc@1187
|
1759
|
adamc@1187
|
1760 val e = (EVar (["Basis"], "sql_count_col", Infer), loc)
|
adamc@1187
|
1761 val e = (EApp ((EVar (["Basis"], "sql_aggregate", Infer), loc),
|
adamc@1187
|
1762 e), loc)
|
adamc@1187
|
1763 in
|
adamc@1187
|
1764 (EApp (e, sqlexp), loc)
|
adamc@1187
|
1765 end)
|
adamc@236
|
1766 | sqlagg LPAREN sqlexp RPAREN (let
|
adamc@236
|
1767 val loc = s (sqlaggleft, RPARENright)
|
adamc@236
|
1768
|
adamc@403
|
1769 val e = (EVar (["Basis"], "sql_" ^ sqlagg, Infer), loc)
|
adamc@403
|
1770 val e = (EApp ((EVar (["Basis"], "sql_aggregate", Infer), loc),
|
adamc@236
|
1771 e), loc)
|
adamc@236
|
1772 in
|
adamc@236
|
1773 (EApp (e, sqlexp), loc)
|
adamc@236
|
1774 end)
|
adamc@746
|
1775 | fname LPAREN sqlexp RPAREN (let
|
adamc@746
|
1776 val loc = s (fnameleft, RPARENright)
|
adamc@746
|
1777
|
adamc@746
|
1778 val e = (EVar (["Basis"], "sql_ufunc", Infer), loc)
|
adamc@746
|
1779 val e = (EApp (e, fname), loc)
|
adamc@746
|
1780 in
|
adamc@746
|
1781 (EApp (e, sqlexp), loc)
|
adamc@746
|
1782 end)
|
adamc@1191
|
1783 | LPAREN query RPAREN (let
|
adamc@1191
|
1784 val loc = s (LPARENleft, RPARENright)
|
adamc@1191
|
1785
|
adamc@1191
|
1786 val e = (EVar (["Basis"], "sql_subquery", Infer), loc)
|
adamc@1191
|
1787 in
|
adamc@1191
|
1788 (EApp (e, query), loc)
|
adamc@1191
|
1789 end)
|
adamc@746
|
1790
|
adamc@746
|
1791 fname : SYMBOL (EVar (["Basis"], "sql_" ^ SYMBOL, Infer), s (SYMBOLleft, SYMBOLright))
|
adamc@746
|
1792 | LBRACE eexp RBRACE (eexp)
|
adamc@235
|
1793
|
adamc@403
|
1794 wopt : (sql_inject (EVar (["Basis"], "True", Infer),
|
adamc@230
|
1795 dummy))
|
adamc@209
|
1796 | CWHERE sqlexp (sqlexp)
|
adamc@226
|
1797
|
adamc@226
|
1798 groupi : tident DOT fident (GField (tident, fident))
|
adamc@226
|
1799
|
adamc@226
|
1800 groupis: groupi ([groupi])
|
adamc@226
|
1801 | groupi COMMA groupis (groupi :: groupis)
|
adamc@226
|
1802
|
adamc@226
|
1803 gopt : (NONE)
|
adamc@226
|
1804 | GROUP BY groupis (SOME groupis)
|
adamc@227
|
1805
|
adamc@403
|
1806 hopt : (sql_inject (EVar (["Basis"], "True", Infer),
|
adamc@230
|
1807 dummy))
|
adamc@227
|
1808 | HAVING sqlexp (sqlexp)
|
adamc@230
|
1809
|
adamc@403
|
1810 obopt : (ECApp ((EVar (["Basis"], "sql_order_by_Nil", Infer), dummy),
|
adamc@234
|
1811 (CWild (KRecord (KType, dummy), dummy), dummy)),
|
adamc@230
|
1812 dummy)
|
adamc@230
|
1813 | ORDER BY obexps (obexps)
|
adamc@230
|
1814
|
adamc@268
|
1815 obitem : sqlexp diropt (sqlexp, diropt)
|
adamc@268
|
1816
|
adamc@268
|
1817 obexps : obitem (let
|
adamc@268
|
1818 val loc = s (obitemleft, obitemright)
|
adamc@230
|
1819
|
adamc@403
|
1820 val e' = (ECApp ((EVar (["Basis"], "sql_order_by_Nil", Infer), loc),
|
adamc@234
|
1821 (CWild (KRecord (KType, loc), loc), loc)),
|
adamc@230
|
1822 loc)
|
adamc@403
|
1823 val e = (EApp ((EVar (["Basis"], "sql_order_by_Cons", Infer), loc),
|
adamc@268
|
1824 #1 obitem), loc)
|
adamc@268
|
1825 val e = (EApp (e, #2 obitem), loc)
|
adamc@230
|
1826 in
|
adamc@230
|
1827 (EApp (e, e'), loc)
|
adamc@230
|
1828 end)
|
adamc@268
|
1829 | obitem COMMA obexps (let
|
adamc@268
|
1830 val loc = s (obitemleft, obexpsright)
|
adamc@230
|
1831
|
adamc@403
|
1832 val e = (EApp ((EVar (["Basis"], "sql_order_by_Cons", Infer), loc),
|
adamc@268
|
1833 #1 obitem), loc)
|
adamc@268
|
1834 val e = (EApp (e, #2 obitem), loc)
|
adamc@230
|
1835 in
|
adamc@230
|
1836 (EApp (e, obexps), loc)
|
adamc@230
|
1837 end)
|
adamc@231
|
1838
|
adamc@403
|
1839 diropt : (EVar (["Basis"], "sql_asc", Infer), dummy)
|
adamc@403
|
1840 | ASC (EVar (["Basis"], "sql_asc", Infer), s (ASCleft, ASCright))
|
adamc@403
|
1841 | DESC (EVar (["Basis"], "sql_desc", Infer), s (DESCleft, DESCright))
|
adamc@268
|
1842
|
adamc@403
|
1843 lopt : (EVar (["Basis"], "sql_no_limit", Infer), dummy)
|
adamc@403
|
1844 | LIMIT ALL (EVar (["Basis"], "sql_no_limit", Infer), dummy)
|
adamc@231
|
1845 | LIMIT sqlint (let
|
adamc@231
|
1846 val loc = s (LIMITleft, sqlintright)
|
adamc@231
|
1847 in
|
adamc@403
|
1848 (EApp ((EVar (["Basis"], "sql_limit", Infer), loc), sqlint), loc)
|
adamc@231
|
1849 end)
|
adamc@231
|
1850
|
adamc@403
|
1851 ofopt : (EVar (["Basis"], "sql_no_offset", Infer), dummy)
|
adamc@232
|
1852 | OFFSET sqlint (let
|
adamc@232
|
1853 val loc = s (OFFSETleft, sqlintright)
|
adamc@232
|
1854 in
|
adamc@403
|
1855 (EApp ((EVar (["Basis"], "sql_offset", Infer), loc), sqlint), loc)
|
adamc@232
|
1856 end)
|
adamc@232
|
1857
|
adamc@231
|
1858 sqlint : INT (EPrim (Prim.Int INT), s (INTleft, INTright))
|
adamc@231
|
1859 | LBRACE eexp RBRACE (eexp)
|
adamc@236
|
1860
|
adamc@236
|
1861 sqlagg : AVG ("avg")
|
adamc@236
|
1862 | SUM ("sum")
|
adamc@236
|
1863 | MIN ("min")
|
adamc@236
|
1864 | MAX ("max")
|