Mercurial > urweb

annotate src/urweb.grm @ 1380:ede95ecb4000

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