Mercurial > urweb

annotate src/urweb.grm @ 1665:f9ffe8497742

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