Mercurial > urweb

annotate src/urweb.grm @ 1698:aaae710417df

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