Mercurial > urweb

annotate src/urweb.grm @ 1634:f4cb4eebf7ae

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