Mercurial > urweb

annotate src/urweb.grm @ 1726:4df4521fbd3b

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