Mercurial > urweb

annotate src/urweb.grm @ 1651:dfc854e478bb

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Error messages about applying 'dynClass' to tags that don't like it
author Adam Chlipala <adam@chlipala.net>
date Sat, 31 Dec 2011 13:31:00 -0500
parents ca3b73a7b4d0
children 570636457047
rev   line source
adam@1643 1 (* Copyright (c) 2008-2011, Adam Chlipala
adamc@1 2 * All rights reserved.
adamc@1 3 *
adamc@1 4 * Redistribution and use in source and binary forms, with or without
adamc@1 5 * modification, are permitted provided that the following conditions are met:
adamc@1 6 *
adamc@1 7 * - Redistributions of source code must retain the above copyright notice,
adamc@1 8 * this list of conditions and the following disclaimer.
adamc@1 9 * - Redistributions in binary form must reproduce the above copyright notice,
adamc@1 10 * this list of conditions and the following disclaimer in the documentation
adamc@1 11 * and/or other materials provided with the distribution.
adamc@1 12 * - The names of contributors may not be used to endorse or promote products
adamc@1 13 * derived from this software without specific prior written permission.
adamc@1 14 *
adamc@339 15 * THIS SOFTARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@1 16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@1 17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@1 18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@1 19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
adamc@1 20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@1 21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@1 22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@1 23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@1 24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@1 25 * POSSIBILITY OF SUCH DAMAGE.
adamc@1 26 *)
adamc@1 27
adamc@244 28 (* Grammar for Ur/Web programs *)
adamc@1 29
adamc@4 30 open Source
adamc@1 31
adamc@1 32 val s = ErrorMsg.spanOf
adamc@230 33 val dummy = ErrorMsg.dummySpan
adamc@1 34
adamc@204 35 fun capitalize "" = ""
adamc@204 36 | capitalize s = str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
adamc@104 37
adamc@203 38 fun entable t =
adamc@203 39 case #1 t of
adamc@203 40 TRecord c => c
adamc@203 41 | _ => t
adamc@203 42
adamc@207 43 datatype select_item =
adamc@207 44 Field of con * con
adamc@1194 45 | Exp of con option * exp
adamc@341 46 | Fields of con * con
adam@1627 47 | StarFields of con
adamc@207 48
adamc@207 49 datatype select =
adamc@207 50 Star
adamc@207 51 | Items of select_item list
adamc@207 52
adamc@226 53 datatype group_item =
adamc@226 54 GField of con * con
adam@1425 55 | GFields of con * con
adamc@226 56
adamc@207 57 fun eqTnames ((c1, _), (c2, _)) =
adamc@207 58 case (c1, c2) of
adamc@207 59 (CVar (ms1, x1), CVar (ms2, x2)) => ms1 = ms2 andalso x1 = x2
adamc@207 60 | (CName x1, CName x2) => x1 = x2
adamc@207 61 | _ => false
adamc@207 62
adam@1424 63 fun nameString (c, _) =
adam@1424 64 case c of
adam@1424 65 CName s => s
adam@1424 66 | CVar (_, x) => x
adam@1424 67 | _ => "?"
adam@1424 68
adam@1627 69 datatype tableMode =
adam@1627 70 Unknown
adam@1627 71 | Everything
adam@1627 72 | Selective of con
adam@1627 73
adamc@1194 74 fun amend_select loc (si, (count, tabs, exps)) =
adamc@233 75 case si of
adamc@233 76 Field (tx, fx) =>
adamc@233 77 let
adamc@233 78 val c = (CRecord ([(fx, (CWild (KType, loc), loc))]), loc)
adamc@207 79
adamc@233 80 val (tabs, found) = ListUtil.foldlMap (fn ((tx', c'), found) =>
adamc@233 81 if eqTnames (tx, tx') then
adam@1627 82 case c' of
adam@1627 83 Everything =>
adam@1627 84 (ErrorMsg.errorAt loc
adam@1627 85 "Mixing specific-field and '*' selection of fields from same table";
adam@1627 86 ((tx', c'), found))
adam@1627 87 | Unknown =>
adam@1627 88 ((tx', Selective c), true)
adam@1627 89 | Selective c' =>
adam@1627 90 ((tx', Selective (CConcat (c, c'), loc)), true)
adamc@233 91 else
adamc@233 92 ((tx', c'), found))
adamc@233 93 false tabs
adamc@233 94 in
adamc@233 95 if found then
adamc@233 96 ()
adamc@233 97 else
adam@1424 98 ErrorMsg.errorAt loc ("Select of field " ^ nameString fx ^ " from unbound table " ^ nameString tx);
adamc@233 99
adamc@1194 100 (count, tabs, exps)
adamc@233 101 end
adamc@341 102 | Fields (tx, fs) =>
adamc@341 103 let
adamc@341 104 val (tabs, found) = ListUtil.foldlMap (fn ((tx', c'), found) =>
adamc@341 105 if eqTnames (tx, tx') then
adam@1627 106 case c' of
adam@1627 107 Everything =>
adam@1627 108 (ErrorMsg.errorAt loc
adam@1627 109 "Mixing specific-field and '*' selection of fields from same table";
adam@1627 110 ((tx', c'), found))
adam@1627 111 | Selective c' =>
adam@1627 112 ((tx', Selective (CConcat (fs, c'), loc)), true)
adam@1627 113 | Unknown =>
adam@1627 114 ((tx', Selective fs), true)
adamc@341 115 else
adamc@341 116 ((tx', c'), found))
adamc@341 117 false tabs
adamc@341 118 in
adamc@341 119 if found then
adamc@341 120 ()
adamc@341 121 else
adamc@341 122 ErrorMsg.errorAt loc "Select of field from unbound table";
adamc@341 123
adamc@1194 124 (count, tabs, exps)
adamc@341 125 end
adam@1627 126 | StarFields tx =>
adam@1627 127 if List.exists (fn (tx', c') => eqTnames (tx, tx') andalso case c' of
adam@1627 128 Unknown => false
adam@1627 129 | _ => true) tabs then
adam@1627 130 (ErrorMsg.errorAt loc "Selection with '*' from table already mentioned in same SELECT clause";
adam@1627 131 (count, tabs, exps))
adam@1627 132 else if List.all (fn (tx', c') => not (eqTnames (tx, tx'))) tabs then
adam@1627 133 (ErrorMsg.errorAt loc "Select of all fields from unbound table";
adam@1627 134 (count, tabs, exps))
adam@1627 135 else
adam@1627 136 (count, map (fn (tx', c') => (tx', if eqTnames (tx, tx') then Everything else c')) tabs, exps)
adamc@1194 137 | Exp (SOME c, e) => (count, tabs, (c, e) :: exps)
adamc@1194 138 | Exp (NONE, e) => (count+1, tabs, ((CName (Int.toString count), loc), e) :: exps)
adamc@207 139
adamc@226 140 fun amend_group loc (gi, tabs) =
adamc@226 141 let
adamc@226 142 val (tx, c) = case gi of
adamc@226 143 GField (tx, fx) => (tx, (CRecord ([(fx, (CWild (KType, loc), loc))]), loc))
adam@1425 144 | GFields (tx, fxs) => (tx, fxs)
adamc@226 145
adamc@226 146 val (tabs, found) = ListUtil.foldlMap (fn ((tx', c'), found) =>
adamc@226 147 if eqTnames (tx, tx') then
adamc@226 148 ((tx', (CConcat (c, c'), loc)), true)
adamc@226 149 else
adamc@226 150 ((tx', c'), found))
adam@1425 151 false tabs
adamc@226 152 in
adamc@226 153 if found then
adamc@226 154 ()
adamc@226 155 else
adamc@226 156 ErrorMsg.errorAt loc "Select of field from unbound table";
adamc@226 157
adamc@226 158 tabs
adamc@226 159 end
adamc@226 160
adamc@403 161 fun sql_inject (v, loc) =
adamc@403 162 (EApp ((EVar (["Basis"], "sql_inject", Infer), loc), (v, loc)), loc)
adamc@209 163
adamc@220 164 fun sql_binary (oper, sqlexp1, sqlexp2, loc) =
adamc@220 165 let
adamc@403 166 val e = (EVar (["Basis"], "sql_binary", Infer), loc)
adamc@403 167 val e = (EApp (e, (EVar (["Basis"], "sql_" ^ oper, Infer), loc)), loc)
adamc@220 168 val e = (EApp (e, sqlexp1), loc)
adamc@220 169 in
adamc@220 170 (EApp (e, sqlexp2), loc)
adamc@220 171 end
adamc@220 172
adamc@220 173 fun sql_unary (oper, sqlexp, loc) =
adamc@220 174 let
adamc@403 175 val e = (EVar (["Basis"], "sql_unary", Infer), loc)
adamc@403 176 val e = (EApp (e, (EVar (["Basis"], "sql_" ^ oper, Infer), loc)), loc)
adamc@220 177 in
adamc@220 178 (EApp (e, sqlexp), loc)
adamc@219 179 end
adamc@219 180
adam@1427 181 fun sql_relop (oper, all, sqlexp1, sqlexp2, loc) =
adamc@229 182 let
adamc@403 183 val e = (EVar (["Basis"], "sql_relop", Infer), loc)
adamc@403 184 val e = (EApp (e, (EVar (["Basis"], "sql_" ^ oper, Infer), loc)), loc)
adam@1427 185 val e = (EApp (e, (EVar (["Basis"], if all then "True" else "False", Infer), loc)), loc)
adamc@229 186 val e = (EApp (e, sqlexp1), loc)
adamc@229 187 in
adamc@229 188 (EApp (e, sqlexp2), loc)
adamc@229 189 end
adamc@229 190
adamc@441 191 fun sql_nfunc (oper, loc) =
adamc@441 192 let
adamc@441 193 val e = (EVar (["Basis"], "sql_nfunc", Infer), loc)
adamc@441 194 in
adamc@441 195 (EApp (e, (EVar (["Basis"], "sql_" ^ oper, Infer), loc)), loc)
adamc@441 196 end
adamc@441 197
adamc@389 198 fun native_unop (oper, e1, loc) =
adamc@389 199 let
adamc@403 200 val e = (EVar (["Basis"], oper, Infer), loc)
adamc@389 201 in
adamc@389 202 (EApp (e, e1), loc)
adamc@389 203 end
adamc@389 204
adamc@256 205 fun native_op (oper, e1, e2, loc) =
adamc@256 206 let
adamc@403 207 val e = (EVar (["Basis"], oper, Infer), loc)
adamc@256 208 val e = (EApp (e, e1), loc)
adamc@256 209 in
adamc@256 210 (EApp (e, e2), loc)
adamc@256 211 end
adamc@256 212
adamc@310 213 val inDml = ref false
adamc@310 214
adamc@325 215 fun tagIn bt =
adamc@325 216 case bt of
adamc@325 217 "table" => "tabl"
adamc@325 218 | _ => bt
adamc@325 219
adamc@709 220 datatype prop_kind = Delete | Update
adamc@709 221
adam@1643 222 datatype attr = Class of exp | DynClass of exp | Normal of con * exp
adamc@721 223
adamc@822 224 fun patType loc (p : pat) =
adamc@822 225 case #1 p of
adamc@822 226 PAnnot (_, t) => t
adamc@822 227 | _ => (CWild (KType, loc), loc)
adamc@822 228
adamc@1265 229 fun tnamesOf (e, _) =
adamc@1265 230 case e of
adamc@1265 231 EApp (e1, e2) => tnamesOf e1 @ tnamesOf e2
adamc@1265 232 | ECApp (e, c as (CName _, _)) =>
adamc@1265 233 let
adamc@1265 234 fun isFt (e, _) =
adamc@1265 235 case e of
adamc@1265 236 EVar (["Basis"], "sql_from_table", _) => true
adamc@1265 237 | EVar ([], "sql_from_table", _) => true
adamc@1265 238 | ECApp (e, _) => isFt e
adamc@1265 239 | EApp (e, _) => isFt e
adamc@1265 240 | EDisjointApp e => isFt e
adamc@1265 241 | _ => false
adamc@1265 242 in
adamc@1265 243 (if isFt e then [c] else []) @ tnamesOf e
adamc@1265 244 end
adamc@1265 245 | ECApp (e, _) => tnamesOf e
adamc@1265 246 | EDisjointApp e => tnamesOf e
adamc@1265 247 | _ => []
adamc@1265 248
adamc@1 249 %%
adamc@244 250 %header (functor UrwebLrValsFn(structure Token : TOKEN))
adamc@1 251
adamc@1 252 %term
adamc@1 253 EOF
adamc@821 254 | STRING of string | INT of Int64.int | FLOAT of Real64.real | CHAR of char
adamc@1 255 | SYMBOL of string | CSYMBOL of string
adamc@1 256 | LPAREN | RPAREN | LBRACK | RBRACK | LBRACE | RBRACE
adam@1306 257 | EQ | COMMA | COLON | DCOLON | DCOLONWILD | TCOLON | TCOLONWILD | DOT | HASH | UNDER | UNDERUNDER | BAR
adamc@403 258 | PLUS | MINUS | DIVIDE | DOTDOTDOT | MOD | AT
adamc@623 259 | CON | LTYPE | VAL | REC | AND | FUN | MAP | UNIT | KUNIT | CLASS
adamc@156 260 | DATATYPE | OF
adamc@7 261 | TYPE | NAME
adamc@629 262 | ARROW | LARROW | DARROW | STAR | SEMI | KARROW | DKARROW | BANG
adamc@674 263 | FN | PLUSPLUS | MINUSMINUS | MINUSMINUSMINUS | DOLLAR | TWIDDLE | CARET
adamc@446 264 | LET | IN
adamc@1071 265 | STRUCTURE | SIGNATURE | STRUCT | SIG | END | FUNCTOR | WHERE | EXTERN | SQL | SELECT1
adamc@754 266 | INCLUDE | OPEN | CONSTRAINT | CONSTRAINTS | EXPORT | TABLE | SEQUENCE | VIEW
adamc@1199 267 | COOKIE | STYLE | TASK | POLICY
adamc@842 268 | CASE | IF | THEN | ELSE | ANDALSO | ORELSE
adamc@1 269
adamc@360 270 | XML_BEGIN of string | XML_END | XML_BEGIN_END of string
adamc@91 271 | NOTAGS of string
adamc@91 272 | BEGIN_TAG of string | END_TAG of string
adamc@91 273
adamc@993 274 | SELECT | DISTINCT | FROM | AS | CWHERE | GROUP | ORDER | BY | HAVING
adamc@229 275 | UNION | INTERSECT | EXCEPT
adamc@232 276 | LIMIT | OFFSET | ALL
adamc@220 277 | TRUE | FALSE | CAND | OR | NOT
adamc@236 278 | COUNT | AVG | SUM | MIN | MAX
adamc@268 279 | ASC | DESC
kkallio@1607 280 | INSERT | INTO | VALUES | UPDATE | SET | DELETE | NULL | IS | COALESCE | LIKE
adamc@441 281 | CURRENT_TIMESTAMP
adamc@219 282 | NE | LT | LE | GT | GE
adamc@714 283 | CCONSTRAINT | UNIQUE | CHECK | PRIMARY | FOREIGN | KEY | ON | NO | ACTION | RESTRICT | CASCADE | REFERENCES
adamc@751 284 | JOIN | INNER | CROSS | OUTER | LEFT | RIGHT | FULL
kkallio@1572 285 | CIF | CTHEN | CELSE
adamc@204 286
adamc@30 287 %nonterm
adamc@1 288 file of decl list
adamc@1 289 | decls of decl list
adamc@325 290 | decl of decl list
adamc@123 291 | vali of string * con option * exp
adamc@123 292 | valis of (string * con option * exp) list
adamc@242 293 | copt of con option
adamc@1 294
adamc@191 295 | dargs of string list
adamc@156 296 | barOpt of unit
adamc@156 297 | dcons of (string * con option) list
adamc@805 298 | dtype of string * string list * (string * con option) list
adamc@805 299 | dtypes of (string * string list * (string * con option) list) list
adamc@156 300 | dcon of string * con option
adamc@156 301
adamc@707 302 | pkopt of exp
adamc@707 303 | commaOpt of unit
adamc@707 304
adamc@704 305 | cst of exp
adamc@704 306 | csts of exp
adamc@704 307 | cstopt of exp
adamc@704 308
adamc@1001 309 | ckl of (string * kind option) list
adamc@1001 310
adamc@709 311 | pmode of prop_kind * exp
adamc@709 312 | pkind of prop_kind
adamc@709 313 | prule of exp
adamc@709 314 | pmodes of (prop_kind * exp) list
adamc@709 315
adamc@30 316 | sgn of sgn
adamc@42 317 | sgntm of sgn
adamc@30 318 | sgi of sgn_item
adamc@30 319 | sgis of sgn_item list
adamc@30 320
adamc@30 321 | str of str
adamc@30 322
adamc@1 323 | kind of kind
adamc@207 324 | ktuple of kind list
adamc@1 325 | kcolon of explicitness
adamc@240 326 | kopt of kind option
adamc@1 327
adamc@34 328 | path of string list * string
adamc@156 329 | cpath of string list * string
adamc@34 330 | spath of str
adamc@59 331 | mpath of string list
adamc@34 332
adamc@1 333 | cexp of con
adam@1577 334 | cexpO of con option
adamc@1 335 | capps of con
adamc@1 336 | cterm of con
adamc@195 337 | ctuple of con list
adamc@207 338 | ctuplev of con list
adamc@1 339 | ident of con
adamc@200 340 | idents of con list
adamc@1 341 | rcon of (con * con) list
adamc@83 342 | rconn of (con * con) list
adamc@1 343 | rcone of (con * con) list
adamc@239 344 | cargs of con * kind -> con * kind
adamc@239 345 | cargl of con * kind -> con * kind
adamc@240 346 | cargl2 of con * kind -> con * kind
adamc@239 347 | carg of con * kind -> con * kind
adamc@239 348 | cargp of con * kind -> con * kind
adamc@1 349
adamc@8 350 | eexp of exp
adamc@8 351 | eapps of exp
adamc@8 352 | eterm of exp
adamc@195 353 | etuple of exp list
adamc@12 354 | rexp of (con * exp) list
adamc@91 355 | xml of exp
adamc@91 356 | xmlOne of exp
adamc@1045 357 | xmlOpt of exp
adam@1643 358 | tag of (string * exp) * exp option * exp option * exp
adamc@141 359 | tagHead of string * exp
adamc@434 360 | bind of string * con option * exp
adamc@446 361 | edecl of edecl
adamc@446 362 | edecls of edecl list
adamc@8 363
adamc@241 364 | earg of exp * con -> exp * con
adamc@241 365 | eargp of exp * con -> exp * con
adamc@822 366 | earga of exp * con -> exp * con
adamc@241 367 | eargs of exp * con -> exp * con
adamc@241 368 | eargl of exp * con -> exp * con
adamc@242 369 | eargl2 of exp * con -> exp * con
adamc@241 370
adamc@170 371 | branch of pat * exp
adamc@170 372 | branchs of (pat * exp) list
adamc@170 373 | pat of pat
adamc@822 374 | patS of pat
adamc@170 375 | pterm of pat
adamc@174 376 | rpat of (string * pat) list * bool
adamc@195 377 | ptuple of pat list
adamc@170 378
adam@1643 379 | attrs of exp option * exp option * (con * exp) list
adamc@721 380 | attr of attr
adamc@104 381 | attrv of exp
adamc@104 382
adamc@204 383 | query of exp
adamc@226 384 | query1 of exp
adamc@993 385 | dopt of exp
adamc@748 386 | tables of con list * exp
adamc@749 387 | fitem of con list * exp
adamc@204 388 | tname of con
adamc@705 389 | tnameW of con * con
adamc@705 390 | tnames of (con * con) * (con * con) list
adamc@705 391 | tnames' of (con * con) * (con * con) list
adamc@204 392 | table of con * exp
adamc@748 393 | table' of con * exp
adamc@207 394 | tident of con
adamc@207 395 | fident of con
adamc@207 396 | seli of select_item
adamc@207 397 | selis of select_item list
adamc@207 398 | select of select
adamc@209 399 | sqlexp of exp
adamc@209 400 | wopt of exp
adamc@226 401 | groupi of group_item
adamc@226 402 | groupis of group_item list
adamc@226 403 | gopt of group_item list option
adamc@227 404 | hopt of exp
adamc@230 405 | obopt of exp
adamc@268 406 | obitem of exp * exp
adamc@230 407 | obexps of exp
adamc@268 408 | diropt of exp
adamc@231 409 | lopt of exp
adamc@232 410 | ofopt of exp
adamc@231 411 | sqlint of exp
adamc@236 412 | sqlagg of string
adamc@746 413 | fname of exp
adamc@207 414
adamc@302 415 | texp of exp
adamc@302 416 | fields of con list
adamc@302 417 | sqlexps of exp list
adamc@303 418 | fsets of (con * exp) list
adamc@310 419 | enterDml of unit
adamc@310 420 | leaveDml of unit
adamc@302 421
adamc@204 422
adamc@1 423 %verbose (* print summary of errors *)
adamc@1 424 %pos int (* positions *)
adamc@1 425 %start file
adamc@1 426 %pure
adamc@1 427 %eop EOF
adamc@1 428 %noshift EOF
adamc@1 429
adamc@244 430 %name Urweb
adamc@1 431
adamc@623 432 %right KARROW
adamc@623 433 %nonassoc DKARROW
adamc@243 434 %right SEMI
adamc@243 435 %nonassoc LARROW
adamc@195 436 %nonassoc IF THEN ELSE
adamc@843 437 %nonassoc DARROW
adamc@842 438 %left ANDALSO
adamc@842 439 %left ORELSE
adamc@1 440 %nonassoc COLON
adam@1306 441 %nonassoc DCOLON TCOLON DCOLONWILD TCOLONWILD
adam@1427 442 %left UNION INTERSECT EXCEPT ALL
adamc@1 443 %right COMMA
adamc@751 444 %right JOIN INNER CROSS OUTER LEFT RIGHT FULL
adamc@220 445 %right OR
adamc@220 446 %right CAND
adamc@470 447 %nonassoc EQ NE LT LE GT GE IS
adamc@243 448 %right ARROW
adamc@837 449 %right CARET PLUSPLUS
adamc@837 450 %left MINUSMINUS MINUSMINUSMINUS
adamc@389 451 %left PLUS MINUS
adamc@389 452 %left STAR DIVIDE MOD
adamc@220 453 %left NOT
adamc@84 454 %nonassoc TWIDDLE
adamc@1 455 %nonassoc DOLLAR
adamc@1 456 %left DOT
adamc@221 457 %nonassoc LBRACE RBRACE
adamc@1 458
adamc@1 459 %%
adamc@1 460
adamc@1 461 file : decls (decls)
adamc@54 462 | SIG sgis ([(DSgn ("?", (SgnConst sgis, s (SIGleft, sgisright))),
adamc@54 463 s (SIGleft, sgisright))])
adamc@1 464
adamc@1 465 decls : ([])
adamc@325 466 | decl decls (decl @ decls)
adamc@1 467
adamc@240 468 decl : CON SYMBOL cargl2 kopt EQ cexp (let
adamc@240 469 val loc = s (CONleft, cexpright)
adamc@240 470
adamc@240 471 val k = Option.getOpt (kopt, (KWild, loc))
adamc@240 472 val (c, k) = cargl2 (cexp, k)
adamc@240 473 in
adamc@325 474 [(DCon (SYMBOL, SOME k, c), loc)]
adamc@240 475 end)
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@1643 1445 (EApp (#4 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@1651 1465 case #3 tag of
adam@1651 1466 NONE => ()
adam@1651 1467 | SOME _ => ErrorMsg.errorAt pos "<form> does not support 'dynClass' attribute";
adam@1412 1468 (EApp (e, xmlOpt), pos)
adam@1412 1469 end
adamc@1093 1470 else if et = "subform" orelse et = "subforms" then
adamc@1093 1471 (EApp (#2 (#1 tag),
adamc@1045 1472 xmlOpt), pos)
adamc@758 1473 else if et = "entry" then
adamc@758 1474 (EApp ((EVar (["Basis"], "entry", Infer), pos),
adamc@1045 1475 xmlOpt), pos)
adamc@141 1476 else
adam@1643 1477 (EApp (#4 tag, xmlOpt), pos)
adamc@141 1478 else
adamc@325 1479 (if ErrorMsg.anyErrors () then
adamc@325 1480 ()
adamc@325 1481 else
adamc@1189 1482 ErrorMsg.errorAt pos ("Begin tag <"
adam@1563 1483 ^ tagOut (#1 (#1 tag))
adamc@1189 1484 ^ "> and end tag </"
adam@1563 1485 ^ tagOut et
adamc@1189 1486 ^ "> don't match.");
adamc@623 1487 (EWild, pos))
adamc@141 1488 end)
adamc@141 1489 | LBRACE eexp RBRACE (eexp)
adamc@391 1490 | LBRACE LBRACK eexp RBRACK RBRACE (let
adamc@391 1491 val loc = s (LBRACEleft, RBRACEright)
adamc@403 1492 val e = (EVar (["Top"], "txt", Infer), loc)
adamc@391 1493 in
adamc@391 1494 (EApp (e, eexp), loc)
adamc@391 1495 end)
adamc@92 1496
adamc@141 1497 tag : tagHead attrs (let
adamc@141 1498 val pos = s (tagHeadleft, attrsright)
adamc@721 1499
adamc@721 1500 val e = (EVar (["Basis"], "tag", Infer), pos)
adamc@721 1501 val eo = case #1 attrs of
adamc@721 1502 NONE => (EVar (["Basis"], "None", Infer), pos)
adamc@721 1503 | SOME e => (EApp ((EVar (["Basis"], "Some", Infer), pos),
adamc@721 1504 e), pos)
adamc@721 1505 val e = (EApp (e, eo), pos)
adam@1643 1506 val eo = case #2 attrs of
adam@1643 1507 NONE => (EVar (["Basis"], "None", Infer), pos)
adam@1643 1508 | SOME e => (EApp ((EVar (["Basis"], "Some", Infer), pos),
adam@1643 1509 e), pos)
adam@1643 1510 val e = (EApp (e, eo), pos)
adam@1643 1511 val e = (EApp (e, (ERecord (#3 attrs), pos)), pos)
adamc@721 1512 val e = (EApp (e, (EApp (#2 tagHead,
adamc@721 1513 (ERecord [], pos)), pos)), pos)
adamc@141 1514 in
adam@1643 1515 (tagHead, #1 attrs, #2 attrs, e)
adamc@141 1516 end)
adamc@141 1517
adamc@141 1518 tagHead: BEGIN_TAG (let
adamc@325 1519 val bt = tagIn BEGIN_TAG
adamc@141 1520 val pos = s (BEGIN_TAGleft, BEGIN_TAGright)
adamc@141 1521 in
adamc@325 1522 (bt,
adamc@473 1523 (EVar (["Basis"], bt, Infer), pos))
adamc@141 1524 end)
adamc@141 1525 | tagHead LBRACE cexp RBRACE (#1 tagHead, (ECApp (#2 tagHead, cexp), s (tagHeadleft, RBRACEright)))
adamc@92 1526
adam@1643 1527 attrs : (NONE, NONE, [])
adamc@721 1528 | attr attrs (let
adamc@721 1529 val loc = s (attrleft, attrsright)
adamc@721 1530 in
adamc@721 1531 case attr of
adamc@721 1532 Class e =>
adamc@721 1533 (case #1 attrs of
adamc@721 1534 NONE => ()
adamc@721 1535 | SOME _ => ErrorMsg.errorAt loc "Multiple classes specified for tag";
adam@1643 1536 (SOME e, #2 attrs, #3 attrs))
adam@1643 1537 | DynClass e =>
adam@1643 1538 (case #2 attrs of
adam@1643 1539 NONE => ()
adam@1643 1540 | SOME _ => ErrorMsg.errorAt loc "Multiple dynamic classes specified for tag";
adam@1643 1541 (#1 attrs, SOME e, #3 attrs))
adamc@721 1542 | Normal xe =>
adam@1643 1543 (#1 attrs, #2 attrs, xe :: #3 attrs)
adamc@721 1544 end)
adamc@104 1545
adam@1643 1546 attr : SYMBOL EQ attrv (case SYMBOL of
adam@1643 1547 "class" => Class attrv
adam@1643 1548 | "dynClass" => DynClass attrv
adam@1643 1549 | _ =>
adamc@724 1550 let
adamc@724 1551 val sym =
adamc@724 1552 case SYMBOL of
adamc@724 1553 "type" => "Typ"
adamc@724 1554 | x => capitalize x
adamc@724 1555 in
adamc@724 1556 Normal ((CName sym, s (SYMBOLleft, SYMBOLright)),
adamc@724 1557 if (sym = "Href" orelse sym = "Src")
adamc@724 1558 andalso (case #1 attrv of
adamc@724 1559 EPrim _ => true
adamc@724 1560 | _ => false) then
adamc@724 1561 let
adamc@724 1562 val loc = s (attrvleft, attrvright)
adamc@724 1563 in
adamc@724 1564 (EApp ((EVar (["Basis"], "bless", Infer), loc),
adamc@724 1565 attrv), loc)
adamc@724 1566 end
adamc@724 1567 else
adamc@724 1568 attrv)
adamc@724 1569 end)
adamc@204 1570
adamc@104 1571 attrv : INT (EPrim (Prim.Int INT), s (INTleft, INTright))
adamc@104 1572 | FLOAT (EPrim (Prim.Float FLOAT), s (FLOATleft, FLOATright))
adamc@104 1573 | STRING (EPrim (Prim.String STRING), s (STRINGleft, STRINGright))
adamc@110 1574 | LBRACE eexp RBRACE (eexp)
adamc@226 1575
adamc@232 1576 query : query1 obopt lopt ofopt (let
adamc@229 1577 val loc = s (query1left, query1right)
adamc@230 1578
adamc@230 1579 val re = (ERecord [((CName "Rows", loc),
adamc@230 1580 query1),
adamc@230 1581 ((CName "OrderBy", loc),
adamc@231 1582 obopt),
adamc@231 1583 ((CName "Limit", loc),
adamc@232 1584 lopt),
adamc@232 1585 ((CName "Offset", loc),
adamc@232 1586 ofopt)], loc)
adamc@229 1587 in
adamc@403 1588 (EApp ((EVar (["Basis"], "sql_query", Infer), loc), re), loc)
adamc@229 1589 end)
adamc@993 1590
adamc@993 1591 dopt : (EVar (["Basis"], "False", Infer), dummy)
adamc@993 1592 | DISTINCT (EVar (["Basis"], "True", Infer),
adamc@993 1593 s (DISTINCTleft, DISTINCTright))
adamc@993 1594
adamc@993 1595 query1 : SELECT dopt select FROM tables wopt gopt hopt
adamc@209 1596 (let
adamc@204 1597 val loc = s (SELECTleft, tablesright)
adamc@207 1598
adamc@1070 1599 val (empties, sel, exps) =
adamc@207 1600 case select of
adamc@1070 1601 Star => ([],
adamc@1070 1602 map (fn nm =>
adamc@233 1603 (nm, (CTuple [(CWild (KRecord (KType, loc), loc),
adamc@233 1604 loc),
adamc@233 1605 (CRecord [], loc)],
adamc@748 1606 loc))) (#1 tables),
adamc@233 1607 [])
adamc@207 1608 | Items sis =>
adamc@207 1609 let
adam@1627 1610 val tabs = map (fn nm => (nm, Unknown)) (#1 tables)
adamc@1194 1611 val (_, tabs, exps) = foldl (amend_select loc)
adamc@1194 1612 (1, tabs, []) sis
adam@1627 1613 val empties = List.mapPartial (fn (nm, c) =>
adam@1627 1614 case c of
adam@1627 1615 Unknown => SOME nm
adam@1627 1616 | Selective (CRecord [], _) => SOME nm
adam@1627 1617 | _ => NONE) tabs
adamc@207 1618 in
adamc@1070 1619 (empties,
adamc@1070 1620 map (fn (nm, c) => (nm,
adam@1627 1621 case c of
adam@1627 1622 Everything =>
adam@1627 1623 (CTuple [(CWild (KRecord (KType, loc), loc), loc),
adam@1627 1624 (CRecord [], loc)], loc)
adam@1627 1625 | _ =>
adam@1627 1626 let
adam@1627 1627 val c = case c of
adam@1627 1628 Selective c => c
adam@1627 1629 | _ => (CRecord [], loc)
adam@1627 1630 in
adam@1627 1631 (CTuple [c,
adam@1627 1632 (CWild (KRecord (KType, loc), loc),
adam@1627 1633 loc)], loc)
adam@1627 1634 end)) tabs,
adamc@233 1635 exps)
adamc@207 1636 end
adamc@207 1637
adamc@207 1638 val sel = (CRecord sel, loc)
adamc@207 1639
adamc@226 1640 val grp = case gopt of
adamc@403 1641 NONE => (ECApp ((EVar (["Basis"], "sql_subset_all",
adamc@403 1642 Infer), loc),
adamc@226 1643 (CWild (KRecord (KRecord (KType, loc), loc),
adamc@226 1644 loc), loc)), loc)
adamc@226 1645 | SOME gis =>
adamc@226 1646 let
adamc@748 1647 val tabs = map (fn nm =>
adamc@748 1648 (nm, (CRecord [], loc))) (#1 tables)
adamc@226 1649 val tabs = foldl (amend_group loc) tabs gis
adamc@226 1650
adamc@226 1651 val tabs = map (fn (nm, c) =>
adamc@226 1652 (nm,
adamc@226 1653 (CTuple [c,
adamc@226 1654 (CWild (KRecord (KType, loc),
adamc@226 1655 loc),
adamc@226 1656 loc)], loc))) tabs
adamc@226 1657 in
adamc@403 1658 (ECApp ((EVar (["Basis"], "sql_subset", Infer), loc),
adamc@226 1659 (CRecord tabs, loc)), loc)
adamc@226 1660 end
adamc@226 1661
adamc@403 1662 val e = (EVar (["Basis"], "sql_query1", Infer), loc)
adamc@1070 1663 val e = (ECApp (e, (CRecord (map (fn nm => (nm, (CUnit, loc))) empties),
adamc@1070 1664 loc)), loc)
adamc@993 1665 val re = (ERecord [((CName "Distinct", loc),
adamc@993 1666 dopt),
adamc@993 1667 ((CName "From", loc),
adamc@748 1668 #2 tables),
adamc@209 1669 ((CName "Where", loc),
adamc@223 1670 wopt),
adamc@224 1671 ((CName "GroupBy", loc),
adamc@226 1672 grp),
adamc@224 1673 ((CName "Having", loc),
adamc@224 1674 hopt),
adamc@223 1675 ((CName "SelectFields", loc),
adamc@403 1676 (ECApp ((EVar (["Basis"], "sql_subset", Infer), loc),
adamc@233 1677 sel), loc)),
adamc@233 1678 ((CName "SelectExps", loc),
adamc@233 1679 (ERecord exps, loc))], loc)
adamc@223 1680
adamc@209 1681 val e = (EApp (e, re), loc)
adamc@204 1682 in
adamc@207 1683 e
adamc@204 1684 end)
adam@1427 1685 | query1 UNION query1 (sql_relop ("union", false, query11, query12, s (query11left, query12right)))
adam@1427 1686 | query1 INTERSECT query1 (sql_relop ("intersect", false, query11, query12, s (query11left, query12right)))
adam@1427 1687 | query1 EXCEPT query1 (sql_relop ("except", false, query11, query12, s (query11left, query12right)))
adam@1427 1688 | query1 UNION ALL query1 (sql_relop ("union", true, query11, query12, s (query11left, query12right)))
adam@1427 1689 | query1 INTERSECT ALL query1 (sql_relop ("intersect", true, query11, query12, s (query11left, query12right)))
adam@1427 1690 | query1 EXCEPT ALL query1 (sql_relop ("except", true, query11, query12, s (query11left, query12right)))
adamc@1070 1691 | LBRACE LBRACE LBRACE eexp RBRACE RBRACE RBRACE (eexp)
adamc@204 1692
adamc@749 1693 tables : fitem (fitem)
adamc@749 1694 | fitem COMMA tables (let
adamc@749 1695 val loc = s (fitemleft, tablesright)
adamc@748 1696
adamc@748 1697 val e = (EVar (["Basis"], "sql_from_comma", Infer), loc)
adamc@749 1698 val e = (EApp (e, #2 fitem), loc)
adamc@748 1699 in
adamc@749 1700 (#1 fitem @ #1 tables,
adamc@748 1701 (EApp (e, #2 tables), loc))
adamc@748 1702 end)
adamc@204 1703
adamc@749 1704 fitem : table' ([#1 table'], #2 table')
adamc@1265 1705 | LBRACE LBRACE eexp RBRACE RBRACE (tnamesOf eexp, eexp)
adamc@749 1706 | fitem JOIN fitem ON sqlexp (let
adamc@749 1707 val loc = s (fitem1left, sqlexpright)
adamc@749 1708
adamc@749 1709 val e = (EVar (["Basis"], "sql_inner_join", Infer), loc)
adamc@749 1710 val e = (EApp (e, #2 fitem1), loc)
adamc@749 1711 val e = (EApp (e, #2 fitem2), loc)
adamc@749 1712 in
adamc@749 1713 (#1 fitem1 @ #1 fitem2,
adamc@749 1714 (EApp (e, sqlexp), loc))
adamc@749 1715 end)
adamc@749 1716 | fitem INNER JOIN fitem ON sqlexp (let
adamc@749 1717 val loc = s (fitem1left, sqlexpright)
adamc@749 1718
adamc@749 1719 val e = (EVar (["Basis"], "sql_inner_join", Infer), loc)
adamc@749 1720 val e = (EApp (e, #2 fitem1), loc)
adamc@749 1721 val e = (EApp (e, #2 fitem2), loc)
adamc@749 1722 in
adamc@749 1723 (#1 fitem1 @ #1 fitem2,
adamc@749 1724 (EApp (e, sqlexp), loc))
adamc@749 1725 end)
adamc@749 1726 | fitem CROSS JOIN fitem (let
adamc@749 1727 val loc = s (fitem1left, fitem2right)
adamc@749 1728
adamc@749 1729 val e = (EVar (["Basis"], "sql_inner_join", Infer), loc)
adamc@749 1730 val e = (EApp (e, #2 fitem1), loc)
adamc@749 1731 val e = (EApp (e, #2 fitem2), loc)
adamc@749 1732 val tru = sql_inject (EVar (["Basis"], "True", Infer), loc)
adamc@749 1733 in
adamc@749 1734 (#1 fitem1 @ #1 fitem2,
adamc@749 1735 (EApp (e, tru), loc))
adamc@749 1736 end)
adamc@750 1737 | fitem LEFT JOIN fitem ON sqlexp (let
adamc@750 1738 val loc = s (fitem1left, sqlexpright)
adamc@750 1739
adamc@750 1740 val e = (EVar (["Basis"], "sql_left_join", Infer), loc)
adamc@750 1741 val e = (EApp (e, #2 fitem1), loc)
adamc@750 1742 val e = (EApp (e, #2 fitem2), loc)
adamc@750 1743 in
adamc@750 1744 (#1 fitem1 @ #1 fitem2,
adamc@750 1745 (EApp (e, sqlexp), loc))
adamc@750 1746 end)
adamc@751 1747 | fitem LEFT OUTER JOIN fitem ON sqlexp (let
adamc@751 1748 val loc = s (fitem1left, sqlexpright)
adamc@751 1749
adamc@751 1750 val e = (EVar (["Basis"], "sql_left_join", Infer), loc)
adamc@751 1751 val e = (EApp (e, #2 fitem1), loc)
adamc@751 1752 val e = (EApp (e, #2 fitem2), loc)
adamc@751 1753 in
adamc@751 1754 (#1 fitem1 @ #1 fitem2,
adamc@751 1755 (EApp (e, sqlexp), loc))
adamc@751 1756 end)
adamc@751 1757 | fitem RIGHT JOIN fitem ON sqlexp (let
adamc@751 1758 val loc = s (fitem1left, sqlexpright)
adamc@751 1759
adamc@751 1760 val e = (EVar (["Basis"], "sql_right_join", Infer), loc)
adamc@751 1761 val e = (EApp (e, #2 fitem1), loc)
adamc@751 1762 val e = (EApp (e, #2 fitem2), loc)
adamc@751 1763 in
adamc@751 1764 (#1 fitem1 @ #1 fitem2,
adamc@751 1765 (EApp (e, sqlexp), loc))
adamc@751 1766 end)
adamc@751 1767 | fitem RIGHT OUTER JOIN fitem ON sqlexp (let
adamc@751 1768 val loc = s (fitem1left, sqlexpright)
adamc@751 1769
adamc@751 1770 val e = (EVar (["Basis"], "sql_right_join", Infer), loc)
adamc@751 1771 val e = (EApp (e, #2 fitem1), loc)
adamc@751 1772 val e = (EApp (e, #2 fitem2), loc)
adamc@751 1773 in
adamc@751 1774 (#1 fitem1 @ #1 fitem2,
adamc@751 1775 (EApp (e, sqlexp), loc))
adamc@751 1776 end)
adamc@751 1777 | fitem FULL JOIN fitem ON sqlexp (let
adamc@751 1778 val loc = s (fitem1left, sqlexpright)
adamc@751 1779
adamc@751 1780 val e = (EVar (["Basis"], "sql_full_join", Infer), loc)
adamc@751 1781 val e = (EApp (e, #2 fitem1), loc)
adamc@751 1782 val e = (EApp (e, #2 fitem2), loc)
adamc@751 1783 in
adamc@751 1784 (#1 fitem1 @ #1 fitem2,
adamc@751 1785 (EApp (e, sqlexp), loc))
adamc@751 1786 end)
adamc@751 1787 | fitem FULL OUTER JOIN fitem ON sqlexp (let
adamc@751 1788 val loc = s (fitem1left, sqlexpright)
adamc@751 1789
adamc@751 1790 val e = (EVar (["Basis"], "sql_full_join", Infer), loc)
adamc@751 1791 val e = (EApp (e, #2 fitem1), loc)
adamc@751 1792 val e = (EApp (e, #2 fitem2), loc)
adamc@751 1793 in
adamc@751 1794 (#1 fitem1 @ #1 fitem2,
adamc@751 1795 (EApp (e, sqlexp), loc))
adamc@751 1796 end)
adamc@1192 1797 | LPAREN query RPAREN AS tname (let
adamc@1192 1798 val loc = s (LPARENleft, RPARENright)
adamc@1192 1799
adamc@1192 1800 val e = (EVar (["Basis"], "sql_from_query", Infer), loc)
adamc@1192 1801 val e = (ECApp (e, tname), loc)
adamc@1192 1802 in
adamc@1192 1803 ([tname], (EApp (e, query), loc))
adamc@1192 1804 end)
adamc@749 1805
adamc@204 1806 tname : CSYMBOL (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright))
adamc@204 1807 | LBRACE cexp RBRACE (cexp)
adamc@204 1808
adamc@243 1809 table : SYMBOL ((CName (capitalize SYMBOL), s (SYMBOLleft, SYMBOLright)),
adamc@403 1810 (EVar ([], SYMBOL, Infer), s (SYMBOLleft, SYMBOLright)))
adamc@403 1811 | SYMBOL AS tname (tname, (EVar ([], SYMBOL, Infer), s (SYMBOLleft, SYMBOLright)))
adamc@221 1812 | LBRACE LBRACE eexp RBRACE RBRACE AS tname (tname, eexp)
adamc@207 1813
adamc@748 1814 table' : table (let
adamc@748 1815 val loc = s (tableleft, tableright)
adamc@748 1816 val e = (EVar (["Basis"], "sql_from_table", Infer), loc)
adamc@748 1817 val e = (ECApp (e, #1 table), loc)
adamc@748 1818 in
adamc@748 1819 (#1 table, (EApp (e, #2 table), loc))
adamc@748 1820 end)
adamc@748 1821
adamc@243 1822 tident : SYMBOL (CName (capitalize SYMBOL), s (SYMBOLleft, SYMBOLright))
adamc@207 1823 | CSYMBOL (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright))
adamc@221 1824 | LBRACE LBRACE cexp RBRACE RBRACE (cexp)
adamc@207 1825
adamc@207 1826 fident : CSYMBOL (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright))
adamc@207 1827 | LBRACE cexp RBRACE (cexp)
adamc@207 1828
adamc@207 1829 seli : tident DOT fident (Field (tident, fident))
adamc@1194 1830 | sqlexp (Exp (NONE, sqlexp))
adamc@1194 1831 | sqlexp AS fident (Exp (SOME fident, sqlexp))
adamc@341 1832 | tident DOT LBRACE LBRACE cexp RBRACE RBRACE (Fields (tident, cexp))
adam@1627 1833 | tident DOT STAR (StarFields tident)
adamc@207 1834
adamc@207 1835 selis : seli ([seli])
adamc@207 1836 | seli COMMA selis (seli :: selis)
adamc@207 1837
adamc@207 1838 select : STAR (Star)
adamc@207 1839 | selis (Items selis)
adamc@209 1840
adamc@403 1841 sqlexp : TRUE (sql_inject (EVar (["Basis"], "True", Infer),
adamc@209 1842 s (TRUEleft, TRUEright)))
adamc@403 1843 | FALSE (sql_inject (EVar (["Basis"], "False", Infer),
adamc@209 1844 s (FALSEleft, FALSEright)))
adamc@209 1845
adamc@222 1846 | INT (sql_inject (EPrim (Prim.Int INT),
adamc@222 1847 s (INTleft, INTright)))
adamc@222 1848 | FLOAT (sql_inject (EPrim (Prim.Float FLOAT),
adamc@222 1849 s (FLOATleft, FLOATright)))
adamc@229 1850 | STRING (sql_inject (EPrim (Prim.String STRING),
adamc@229 1851 s (STRINGleft, STRINGright)))
adamc@441 1852 | CURRENT_TIMESTAMP (sql_nfunc ("current_timestamp",
adamc@441 1853 s (CURRENT_TIMESTAMPleft, CURRENT_TIMESTAMPright)))
adamc@222 1854
adamc@221 1855 | tident DOT fident (let
adamc@221 1856 val loc = s (tidentleft, fidentright)
adamc@403 1857 val e = (EVar (["Basis"], "sql_field", Infer), loc)
adamc@221 1858 val e = (ECApp (e, tident), loc)
adamc@221 1859 in
adamc@221 1860 (ECApp (e, fident), loc)
adamc@221 1861 end)
adamc@234 1862 | CSYMBOL (let
adamc@234 1863 val loc = s (CSYMBOLleft, CSYMBOLright)
adamc@310 1864 in
adamc@310 1865 if !inDml then
adamc@310 1866 let
adamc@403 1867 val e = (EVar (["Basis"], "sql_field", Infer), loc)
adamc@310 1868 val e = (ECApp (e, (CName "T", loc)), loc)
adamc@310 1869 in
adamc@310 1870 (ECApp (e, (CName CSYMBOL, loc)), loc)
adamc@310 1871 end
adamc@310 1872 else
adamc@310 1873 let
adamc@403 1874 val e = (EVar (["Basis"], "sql_exp", Infer), loc)
adamc@310 1875 in
adamc@310 1876 (ECApp (e, (CName CSYMBOL, loc)), loc)
adamc@310 1877 end
adamc@310 1878 end)
adamc@221 1879
adamc@471 1880 | LBRACE eexp RBRACE (eexp)
adamc@470 1881
adamc@559 1882 | sqlexp EQ sqlexp (sql_binary ("eq", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
adamc@559 1883 | sqlexp NE sqlexp (sql_binary ("ne", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
adamc@559 1884 | sqlexp LT sqlexp (sql_binary ("lt", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
adamc@559 1885 | sqlexp LE sqlexp (sql_binary ("le", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
adamc@559 1886 | sqlexp GT sqlexp (sql_binary ("gt", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
adamc@559 1887 | sqlexp GE sqlexp (sql_binary ("ge", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
adamc@559 1888
adamc@559 1889 | sqlexp PLUS sqlexp (sql_binary ("plus", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
adamc@559 1890 | sqlexp MINUS sqlexp (sql_binary ("minus", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
adamc@559 1891 | sqlexp STAR sqlexp (sql_binary ("times", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
adamc@559 1892 | sqlexp DIVIDE sqlexp (sql_binary ("div", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
adamc@559 1893 | sqlexp MOD sqlexp (sql_binary ("mod", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
adamc@219 1894
adamc@220 1895 | sqlexp CAND sqlexp (sql_binary ("and", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
adamc@220 1896 | sqlexp OR sqlexp (sql_binary ("or", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
adamc@559 1897
kkallio@1607 1898 | sqlexp LIKE sqlexp (sql_binary ("like", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
kkallio@1607 1899
adamc@220 1900 | NOT sqlexp (sql_unary ("not", sqlexp, s (NOTleft, sqlexpright)))
adamc@559 1901 | MINUS sqlexp (sql_unary ("neg", sqlexp, s (MINUSleft, sqlexpright)))
adamc@220 1902
adamc@470 1903 | sqlexp IS NULL (let
adamc@470 1904 val loc = s (sqlexpleft, NULLright)
adamc@470 1905 in
adamc@470 1906 (EApp ((EVar (["Basis"], "sql_is_null", Infer), loc),
adamc@470 1907 sqlexp), loc)
adamc@470 1908 end)
adamc@470 1909
kkallio@1572 1910 | CIF sqlexp CTHEN sqlexp CELSE sqlexp (let
kkallio@1572 1911 val loc = s (CIFleft, sqlexp3right)
kkallio@1572 1912 val e = (EVar (["Basis"], "sql_if_then_else", Infer), loc)
kkallio@1572 1913 in
kkallio@1572 1914 (EApp ((EApp ((EApp (e, sqlexp1), loc), sqlexp2), loc), sqlexp3), loc)
kkallio@1572 1915 end)
kkallio@1572 1916
adamc@471 1917 | LBRACE LBRACK eexp RBRACK RBRACE (sql_inject (#1 eexp,
adamc@471 1918 s (LBRACEleft, RBRACEright)))
adamc@220 1919 | LPAREN sqlexp RPAREN (sqlexp)
adamc@210 1920
adamc@467 1921 | NULL (sql_inject ((EVar (["Basis"], "None", Infer),
adamc@467 1922 s (NULLleft, NULLright))))
adamc@467 1923
adamc@235 1924 | COUNT LPAREN STAR RPAREN (let
adamc@235 1925 val loc = s (COUNTleft, RPARENright)
adamc@235 1926 in
adamc@544 1927 (EVar (["Basis"], "sql_count", Infer), loc)
adamc@235 1928 end)
adamc@1187 1929 | COUNT LPAREN sqlexp RPAREN (let
adamc@1187 1930 val loc = s (COUNTleft, RPARENright)
adamc@1187 1931
adamc@1187 1932 val e = (EVar (["Basis"], "sql_count_col", Infer), loc)
adamc@1187 1933 val e = (EApp ((EVar (["Basis"], "sql_aggregate", Infer), loc),
adamc@1187 1934 e), loc)
adamc@1187 1935 in
adamc@1187 1936 (EApp (e, sqlexp), loc)
adamc@1187 1937 end)
adamc@236 1938 | sqlagg LPAREN sqlexp RPAREN (let
adamc@236 1939 val loc = s (sqlaggleft, RPARENright)
adamc@236 1940
adamc@403 1941 val e = (EVar (["Basis"], "sql_" ^ sqlagg, Infer), loc)
adamc@403 1942 val e = (EApp ((EVar (["Basis"], "sql_aggregate", Infer), loc),
adamc@236 1943 e), loc)
adamc@236 1944 in
adamc@236 1945 (EApp (e, sqlexp), loc)
adamc@236 1946 end)
adam@1602 1947 | COALESCE LPAREN sqlexp COMMA sqlexp RPAREN
adam@1602 1948 (let
adam@1602 1949 val loc = s (COALESCEright, sqlexp2right)
adam@1602 1950 val e = (EVar (["Basis"], "sql_coalesce", Infer), loc)
adam@1602 1951 val e = (EApp (e, sqlexp1), loc)
adam@1602 1952 in
adam@1602 1953 (EApp (e, sqlexp2), loc)
adam@1602 1954 end)
adamc@746 1955 | fname LPAREN sqlexp RPAREN (let
adamc@746 1956 val loc = s (fnameleft, RPARENright)
adamc@746 1957
adamc@746 1958 val e = (EVar (["Basis"], "sql_ufunc", Infer), loc)
adamc@746 1959 val e = (EApp (e, fname), loc)
adamc@746 1960 in
adamc@746 1961 (EApp (e, sqlexp), loc)
adamc@746 1962 end)
adamc@1191 1963 | LPAREN query RPAREN (let
adamc@1191 1964 val loc = s (LPARENleft, RPARENright)
adamc@1191 1965
adamc@1191 1966 val e = (EVar (["Basis"], "sql_subquery", Infer), loc)
adamc@1191 1967 in
adamc@1191 1968 (EApp (e, query), loc)
adamc@1191 1969 end)
adamc@746 1970
adamc@746 1971 fname : SYMBOL (EVar (["Basis"], "sql_" ^ SYMBOL, Infer), s (SYMBOLleft, SYMBOLright))
adamc@746 1972 | LBRACE eexp RBRACE (eexp)
adamc@235 1973
adamc@403 1974 wopt : (sql_inject (EVar (["Basis"], "True", Infer),
adamc@230 1975 dummy))
adamc@209 1976 | CWHERE sqlexp (sqlexp)
adamc@226 1977
adamc@226 1978 groupi : tident DOT fident (GField (tident, fident))
adam@1425 1979 | tident DOT LBRACE LBRACE cexp RBRACE RBRACE (GFields (tident, cexp))
adamc@226 1980
adamc@226 1981 groupis: groupi ([groupi])
adamc@226 1982 | groupi COMMA groupis (groupi :: groupis)
adamc@226 1983
adamc@226 1984 gopt : (NONE)
adamc@226 1985 | GROUP BY groupis (SOME groupis)
adamc@227 1986
adamc@403 1987 hopt : (sql_inject (EVar (["Basis"], "True", Infer),
adamc@230 1988 dummy))
adamc@227 1989 | HAVING sqlexp (sqlexp)
adamc@230 1990
adamc@403 1991 obopt : (ECApp ((EVar (["Basis"], "sql_order_by_Nil", Infer), dummy),
adamc@234 1992 (CWild (KRecord (KType, dummy), dummy), dummy)),
adamc@230 1993 dummy)
adamc@230 1994 | ORDER BY obexps (obexps)
adamc@230 1995
adamc@268 1996 obitem : sqlexp diropt (sqlexp, diropt)
adamc@268 1997
adamc@268 1998 obexps : obitem (let
adamc@268 1999 val loc = s (obitemleft, obitemright)
adamc@230 2000
adamc@403 2001 val e' = (ECApp ((EVar (["Basis"], "sql_order_by_Nil", Infer), loc),
adamc@234 2002 (CWild (KRecord (KType, loc), loc), loc)),
adamc@230 2003 loc)
adamc@403 2004 val e = (EApp ((EVar (["Basis"], "sql_order_by_Cons", Infer), loc),
adamc@268 2005 #1 obitem), loc)
adamc@268 2006 val e = (EApp (e, #2 obitem), loc)
adamc@230 2007 in
adamc@230 2008 (EApp (e, e'), loc)
adamc@230 2009 end)
adamc@268 2010 | obitem COMMA obexps (let
adamc@268 2011 val loc = s (obitemleft, obexpsright)
adamc@230 2012
adamc@403 2013 val e = (EApp ((EVar (["Basis"], "sql_order_by_Cons", Infer), loc),
adamc@268 2014 #1 obitem), loc)
adamc@268 2015 val e = (EApp (e, #2 obitem), loc)
adamc@230 2016 in
adamc@230 2017 (EApp (e, obexps), loc)
adamc@230 2018 end)
adamc@231 2019
adamc@403 2020 diropt : (EVar (["Basis"], "sql_asc", Infer), dummy)
adamc@403 2021 | ASC (EVar (["Basis"], "sql_asc", Infer), s (ASCleft, ASCright))
adamc@403 2022 | DESC (EVar (["Basis"], "sql_desc", Infer), s (DESCleft, DESCright))
adam@1543 2023 | LBRACE eexp RBRACE (eexp)
adamc@268 2024
adamc@403 2025 lopt : (EVar (["Basis"], "sql_no_limit", Infer), dummy)
adamc@403 2026 | LIMIT ALL (EVar (["Basis"], "sql_no_limit", Infer), dummy)
adamc@231 2027 | LIMIT sqlint (let
adamc@231 2028 val loc = s (LIMITleft, sqlintright)
adamc@231 2029 in
adamc@403 2030 (EApp ((EVar (["Basis"], "sql_limit", Infer), loc), sqlint), loc)
adamc@231 2031 end)
adamc@231 2032
adamc@403 2033 ofopt : (EVar (["Basis"], "sql_no_offset", Infer), dummy)
adamc@232 2034 | OFFSET sqlint (let
adamc@232 2035 val loc = s (OFFSETleft, sqlintright)
adamc@232 2036 in
adamc@403 2037 (EApp ((EVar (["Basis"], "sql_offset", Infer), loc), sqlint), loc)
adamc@232 2038 end)
adamc@232 2039
adamc@231 2040 sqlint : INT (EPrim (Prim.Int INT), s (INTleft, INTright))
adamc@231 2041 | LBRACE eexp RBRACE (eexp)
adamc@236 2042
adamc@236 2043 sqlagg : AVG ("avg")
adamc@236 2044 | SUM ("sum")
adamc@236 2045 | MIN ("min")
adamc@236 2046 | MAX ("max")