Mercurial > urweb

annotate src/urweb.grm @ 709:0406e9cccb72

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
FOREIGN KEY, without ability to link NULL to NOT NULL (and with some lingering problems in row inference)
author Adam Chlipala <adamc@hcoop.net>
date Tue, 07 Apr 2009 18:47:47 -0400
parents d8217b4cb617
children 71409a4ccb67
rev   line source
adamc@695 1 (* Copyright (c) 2008-2009, 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@233 45 | Exp of con * 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@233 61 fun amend_select loc (si, (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@233 79 (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@341 95 (tabs, exps)
adamc@341 96 end
adamc@233 97 | Exp (c, e) => (tabs, (c, e) :: exps)
adamc@207 98
adamc@226 99 fun amend_group loc (gi, tabs) =
adamc@226 100 let
adamc@226 101 val (tx, c) = case gi of
adamc@226 102 GField (tx, fx) => (tx, (CRecord ([(fx, (CWild (KType, loc), loc))]), loc))
adamc@226 103
adamc@226 104 val (tabs, found) = ListUtil.foldlMap (fn ((tx', c'), found) =>
adamc@226 105 if eqTnames (tx, tx') then
adamc@226 106 ((tx', (CConcat (c, c'), loc)), true)
adamc@226 107 else
adamc@226 108 ((tx', c'), found))
adamc@226 109 false tabs
adamc@226 110 in
adamc@226 111 if found then
adamc@226 112 ()
adamc@226 113 else
adamc@226 114 ErrorMsg.errorAt loc "Select of field from unbound table";
adamc@226 115
adamc@226 116 tabs
adamc@226 117 end
adamc@226 118
adamc@403 119 fun sql_inject (v, loc) =
adamc@403 120 (EApp ((EVar (["Basis"], "sql_inject", Infer), loc), (v, loc)), loc)
adamc@209 121
adamc@220 122 fun sql_binary (oper, sqlexp1, sqlexp2, loc) =
adamc@220 123 let
adamc@403 124 val e = (EVar (["Basis"], "sql_binary", Infer), loc)
adamc@403 125 val e = (EApp (e, (EVar (["Basis"], "sql_" ^ oper, Infer), loc)), loc)
adamc@220 126 val e = (EApp (e, sqlexp1), loc)
adamc@220 127 in
adamc@220 128 (EApp (e, sqlexp2), loc)
adamc@220 129 end
adamc@220 130
adamc@220 131 fun sql_unary (oper, sqlexp, loc) =
adamc@220 132 let
adamc@403 133 val e = (EVar (["Basis"], "sql_unary", Infer), loc)
adamc@403 134 val e = (EApp (e, (EVar (["Basis"], "sql_" ^ oper, Infer), loc)), loc)
adamc@220 135 in
adamc@220 136 (EApp (e, sqlexp), loc)
adamc@219 137 end
adamc@219 138
adamc@229 139 fun sql_relop (oper, sqlexp1, sqlexp2, loc) =
adamc@229 140 let
adamc@403 141 val e = (EVar (["Basis"], "sql_relop", Infer), loc)
adamc@403 142 val e = (EApp (e, (EVar (["Basis"], "sql_" ^ oper, Infer), loc)), loc)
adamc@229 143 val e = (EApp (e, sqlexp1), loc)
adamc@229 144 in
adamc@229 145 (EApp (e, sqlexp2), loc)
adamc@229 146 end
adamc@229 147
adamc@441 148 fun sql_nfunc (oper, loc) =
adamc@441 149 let
adamc@441 150 val e = (EVar (["Basis"], "sql_nfunc", Infer), loc)
adamc@441 151 in
adamc@441 152 (EApp (e, (EVar (["Basis"], "sql_" ^ oper, Infer), loc)), loc)
adamc@441 153 end
adamc@441 154
adamc@389 155 fun native_unop (oper, e1, loc) =
adamc@389 156 let
adamc@403 157 val e = (EVar (["Basis"], oper, Infer), loc)
adamc@389 158 in
adamc@389 159 (EApp (e, e1), loc)
adamc@389 160 end
adamc@389 161
adamc@256 162 fun native_op (oper, e1, e2, loc) =
adamc@256 163 let
adamc@403 164 val e = (EVar (["Basis"], oper, Infer), loc)
adamc@256 165 val e = (EApp (e, e1), loc)
adamc@256 166 in
adamc@256 167 (EApp (e, e2), loc)
adamc@256 168 end
adamc@256 169
adamc@310 170 val inDml = ref false
adamc@310 171
adamc@325 172 fun tagIn bt =
adamc@325 173 case bt of
adamc@325 174 "table" => "tabl"
adamc@325 175 | _ => bt
adamc@325 176
adamc@709 177 datatype prop_kind = Delete | Update
adamc@709 178
adamc@1 179 %%
adamc@244 180 %header (functor UrwebLrValsFn(structure Token : TOKEN))
adamc@1 181
adamc@1 182 %term
adamc@1 183 EOF
adamc@14 184 | STRING of string | INT of Int64.int | FLOAT of Real64.real
adamc@1 185 | SYMBOL of string | CSYMBOL of string
adamc@1 186 | LPAREN | RPAREN | LBRACK | RBRACK | LBRACE | RBRACE
adamc@156 187 | EQ | COMMA | COLON | DCOLON | TCOLON | DOT | HASH | UNDER | UNDERUNDER | BAR
adamc@403 188 | PLUS | MINUS | DIVIDE | DOTDOTDOT | MOD | AT
adamc@623 189 | CON | LTYPE | VAL | REC | AND | FUN | MAP | UNIT | KUNIT | CLASS
adamc@156 190 | DATATYPE | OF
adamc@7 191 | TYPE | NAME
adamc@629 192 | ARROW | LARROW | DARROW | STAR | SEMI | KARROW | DKARROW | BANG
adamc@674 193 | FN | PLUSPLUS | MINUSMINUS | MINUSMINUSMINUS | DOLLAR | TWIDDLE | CARET
adamc@446 194 | LET | IN
adamc@445 195 | STRUCTURE | SIGNATURE | STRUCT | SIG | END | FUNCTOR | WHERE | EXTERN | SQL
adamc@338 196 | INCLUDE | OPEN | CONSTRAINT | CONSTRAINTS | EXPORT | TABLE | SEQUENCE
adamc@459 197 | COOKIE
adamc@190 198 | CASE | IF | THEN | ELSE
adamc@1 199
adamc@360 200 | XML_BEGIN of string | XML_END | XML_BEGIN_END of string
adamc@91 201 | NOTAGS of string
adamc@91 202 | BEGIN_TAG of string | END_TAG of string
adamc@91 203
adamc@230 204 | SELECT | FROM | AS | CWHERE | GROUP | ORDER | BY | HAVING
adamc@229 205 | UNION | INTERSECT | EXCEPT
adamc@232 206 | LIMIT | OFFSET | ALL
adamc@220 207 | TRUE | FALSE | CAND | OR | NOT
adamc@236 208 | COUNT | AVG | SUM | MIN | MAX
adamc@268 209 | ASC | DESC
adamc@470 210 | INSERT | INTO | VALUES | UPDATE | SET | DELETE | NULL | IS
adamc@441 211 | CURRENT_TIMESTAMP
adamc@219 212 | NE | LT | LE | GT | GE
adamc@709 213 | CCONSTRAINT | UNIQUE | PRIMARY | FOREIGN | KEY | ON | NO | ACTION | RESTRICT | CASCADE | REFERENCES
adamc@204 214
adamc@30 215 %nonterm
adamc@1 216 file of decl list
adamc@1 217 | decls of decl list
adamc@325 218 | decl of decl list
adamc@123 219 | vali of string * con option * exp
adamc@123 220 | valis of (string * con option * exp) list
adamc@242 221 | copt of con option
adamc@1 222
adamc@191 223 | dargs of string list
adamc@156 224 | barOpt of unit
adamc@156 225 | dcons of (string * con option) list
adamc@156 226 | dcon of string * con option
adamc@156 227
adamc@707 228 | pkopt of exp
adamc@707 229 | commaOpt of unit
adamc@707 230
adamc@704 231 | cst of exp
adamc@704 232 | csts of exp
adamc@704 233 | cstopt of exp
adamc@704 234
adamc@709 235 | pmode of prop_kind * exp
adamc@709 236 | pkind of prop_kind
adamc@709 237 | prule of exp
adamc@709 238 | pmodes of (prop_kind * exp) list
adamc@709 239
adamc@30 240 | sgn of sgn
adamc@42 241 | sgntm of sgn
adamc@30 242 | sgi of sgn_item
adamc@30 243 | sgis of sgn_item list
adamc@30 244
adamc@30 245 | str of str
adamc@30 246
adamc@1 247 | kind of kind
adamc@207 248 | ktuple of kind list
adamc@1 249 | kcolon of explicitness
adamc@240 250 | kopt of kind option
adamc@1 251
adamc@34 252 | path of string list * string
adamc@156 253 | cpath of string list * string
adamc@34 254 | spath of str
adamc@59 255 | mpath of string list
adamc@34 256
adamc@1 257 | cexp of con
adamc@1 258 | capps of con
adamc@1 259 | cterm of con
adamc@195 260 | ctuple of con list
adamc@207 261 | ctuplev of con list
adamc@1 262 | ident of con
adamc@200 263 | idents of con list
adamc@1 264 | rcon of (con * con) list
adamc@83 265 | rconn of (con * con) list
adamc@1 266 | rcone of (con * con) list
adamc@239 267 | cargs of con * kind -> con * kind
adamc@239 268 | cargl of con * kind -> con * kind
adamc@240 269 | cargl2 of con * kind -> con * kind
adamc@239 270 | carg of con * kind -> con * kind
adamc@239 271 | cargp of con * kind -> con * kind
adamc@1 272
adamc@8 273 | eexp of exp
adamc@8 274 | eapps of exp
adamc@8 275 | eterm of exp
adamc@195 276 | etuple of exp list
adamc@12 277 | rexp of (con * exp) list
adamc@91 278 | xml of exp
adamc@91 279 | xmlOne of exp
adamc@141 280 | tag of string * exp
adamc@141 281 | tagHead of string * exp
adamc@434 282 | bind of string * con option * exp
adamc@446 283 | edecl of edecl
adamc@446 284 | edecls of edecl list
adamc@8 285
adamc@241 286 | earg of exp * con -> exp * con
adamc@241 287 | eargp of exp * con -> exp * con
adamc@241 288 | eargs of exp * con -> exp * con
adamc@241 289 | eargl of exp * con -> exp * con
adamc@242 290 | eargl2 of exp * con -> exp * con
adamc@241 291
adamc@170 292 | branch of pat * exp
adamc@170 293 | branchs of (pat * exp) list
adamc@170 294 | pat of pat
adamc@170 295 | pterm of pat
adamc@174 296 | rpat of (string * pat) list * bool
adamc@195 297 | ptuple of pat list
adamc@170 298
adamc@104 299 | attrs of (con * exp) list
adamc@104 300 | attr of con * exp
adamc@104 301 | attrv of exp
adamc@104 302
adamc@204 303 | query of exp
adamc@226 304 | query1 of exp
adamc@204 305 | tables of (con * exp) list
adamc@204 306 | tname of con
adamc@705 307 | tnameW of con * con
adamc@705 308 | tnames of (con * con) * (con * con) list
adamc@705 309 | tnames' of (con * con) * (con * con) list
adamc@204 310 | table of con * exp
adamc@207 311 | tident of con
adamc@207 312 | fident of con
adamc@207 313 | seli of select_item
adamc@207 314 | selis of select_item list
adamc@207 315 | select of select
adamc@209 316 | sqlexp of exp
adamc@209 317 | wopt of exp
adamc@226 318 | groupi of group_item
adamc@226 319 | groupis of group_item list
adamc@226 320 | gopt of group_item list option
adamc@227 321 | hopt of exp
adamc@230 322 | obopt of exp
adamc@268 323 | obitem of exp * exp
adamc@230 324 | obexps of exp
adamc@268 325 | diropt of exp
adamc@231 326 | lopt of exp
adamc@232 327 | ofopt of exp
adamc@231 328 | sqlint of exp
adamc@236 329 | sqlagg of string
adamc@207 330
adamc@302 331 | texp of exp
adamc@302 332 | fields of con list
adamc@302 333 | sqlexps of exp list
adamc@303 334 | fsets of (con * exp) list
adamc@310 335 | enterDml of unit
adamc@310 336 | leaveDml of unit
adamc@302 337
adamc@204 338
adamc@1 339 %verbose (* print summary of errors *)
adamc@1 340 %pos int (* positions *)
adamc@1 341 %start file
adamc@1 342 %pure
adamc@1 343 %eop EOF
adamc@1 344 %noshift EOF
adamc@1 345
adamc@244 346 %name Urweb
adamc@1 347
adamc@623 348 %right KARROW
adamc@623 349 %nonassoc DKARROW
adamc@243 350 %right SEMI
adamc@243 351 %nonassoc LARROW
adamc@195 352 %nonassoc IF THEN ELSE
adamc@1 353 %nonassoc DARROW
adamc@1 354 %nonassoc COLON
adamc@6 355 %nonassoc DCOLON TCOLON
adamc@229 356 %left UNION INTERSECT EXCEPT
adamc@1 357 %right COMMA
adamc@220 358 %right OR
adamc@220 359 %right CAND
adamc@470 360 %nonassoc EQ NE LT LE GT GE IS
adamc@243 361 %right ARROW
adamc@674 362 %right CARET PLUSPLUS MINUSMINUS MINUSMINUSMINUS
adamc@389 363 %left PLUS MINUS
adamc@389 364 %left STAR DIVIDE MOD
adamc@220 365 %left NOT
adamc@84 366 %nonassoc TWIDDLE
adamc@1 367 %nonassoc DOLLAR
adamc@1 368 %left DOT
adamc@221 369 %nonassoc LBRACE RBRACE
adamc@1 370
adamc@1 371 %%
adamc@1 372
adamc@1 373 file : decls (decls)
adamc@54 374 | SIG sgis ([(DSgn ("?", (SgnConst sgis, s (SIGleft, sgisright))),
adamc@54 375 s (SIGleft, sgisright))])
adamc@1 376
adamc@1 377 decls : ([])
adamc@325 378 | decl decls (decl @ decls)
adamc@1 379
adamc@240 380 decl : CON SYMBOL cargl2 kopt EQ cexp (let
adamc@240 381 val loc = s (CONleft, cexpright)
adamc@240 382
adamc@240 383 val k = Option.getOpt (kopt, (KWild, loc))
adamc@240 384 val (c, k) = cargl2 (cexp, k)
adamc@240 385 in
adamc@325 386 [(DCon (SYMBOL, SOME k, c), loc)]
adamc@240 387 end)
adamc@325 388 | LTYPE SYMBOL EQ cexp ([(DCon (SYMBOL, SOME (KType, s (LTYPEleft, cexpright)), cexp),
adamc@325 389 s (LTYPEleft, cexpright))])
adamc@325 390 | DATATYPE SYMBOL dargs EQ barOpt dcons([(DDatatype (SYMBOL, dargs, dcons), s (DATATYPEleft, dconsright))])
adamc@191 391 | DATATYPE SYMBOL dargs EQ DATATYPE CSYMBOL DOT path
adamc@191 392 (case dargs of
adamc@325 393 [] => [(DDatatypeImp (SYMBOL, CSYMBOL :: #1 path, #2 path), s (DATATYPEleft, pathright))]
adamc@191 394 | _ => raise Fail "Arguments specified for imported datatype")
adamc@325 395 | VAL vali ([(DVal vali, s (VALleft, valiright))])
adamc@325 396 | VAL REC valis ([(DValRec valis, s (VALleft, valisright))])
adamc@325 397 | FUN valis ([(DValRec valis, s (FUNleft, valisright))])
adamc@1 398
adamc@325 399 | SIGNATURE CSYMBOL EQ sgn ([(DSgn (CSYMBOL, sgn), s (SIGNATUREleft, sgnright))])
adamc@325 400 | STRUCTURE CSYMBOL EQ str ([(DStr (CSYMBOL, NONE, str), s (STRUCTUREleft, strright))])
adamc@325 401 | STRUCTURE CSYMBOL COLON sgn EQ str ([(DStr (CSYMBOL, SOME sgn, str), s (STRUCTUREleft, strright))])
adamc@42 402 | FUNCTOR CSYMBOL LPAREN CSYMBOL COLON sgn RPAREN EQ str
adamc@325 403 ([(DStr (CSYMBOL1, NONE,
adamc@325 404 (StrFun (CSYMBOL2, sgn1, NONE, str), s (FUNCTORleft, strright))),
adamc@325 405 s (FUNCTORleft, strright))])
adamc@42 406 | FUNCTOR CSYMBOL LPAREN CSYMBOL COLON sgn RPAREN COLON sgn EQ str
adamc@325 407 ([(DStr (CSYMBOL1, NONE,
adamc@325 408 (StrFun (CSYMBOL2, sgn1, SOME sgn2, str), s (FUNCTORleft, strright))),
adamc@325 409 s (FUNCTORleft, strright))])
adamc@325 410 | EXTERN STRUCTURE CSYMBOL COLON sgn ([(DFfiStr (CSYMBOL, sgn), s (EXTERNleft, sgnright))])
adamc@61 411 | OPEN mpath (case mpath of
adamc@61 412 [] => raise Fail "Impossible mpath parse [1]"
adamc@325 413 | m :: ms => [(DOpen (m, ms), s (OPENleft, mpathright))])
adamc@325 414 | OPEN mpath LPAREN str RPAREN (let
adamc@325 415 val loc = s (OPENleft, RPARENright)
adamc@325 416
adamc@325 417 val m = case mpath of
adamc@325 418 [] => raise Fail "Impossible mpath parse [4]"
adamc@325 419 | m :: ms =>
adamc@325 420 foldl (fn (m, str) => (StrProj (str, m), loc))
adamc@325 421 (StrVar m, loc) ms
adamc@325 422 in
adamc@325 423 [(DStr ("anon", NONE, (StrApp (m, str), loc)), loc),
adamc@325 424 (DOpen ("anon", []), loc)]
adamc@325 425 end)
adamc@88 426 | OPEN CONSTRAINTS mpath (case mpath of
adamc@88 427 [] => raise Fail "Impossible mpath parse [3]"
adamc@325 428 | m :: ms => [(DOpenConstraints (m, ms), s (OPENleft, mpathright))])
adamc@325 429 | CONSTRAINT cterm TWIDDLE cterm ([(DConstraint (cterm1, cterm2), s (CONSTRAINTleft, ctermright))])
adamc@325 430 | EXPORT spath ([(DExport spath, s (EXPORTleft, spathright))])
adamc@707 431 | TABLE SYMBOL COLON cterm pkopt commaOpt cstopt([(DTable (SYMBOL, entable cterm, pkopt, cstopt),
adamc@707 432 s (TABLEleft, cstoptright))])
adamc@338 433 | SEQUENCE SYMBOL ([(DSequence SYMBOL, s (SEQUENCEleft, SYMBOLright))])
adamc@563 434 | CLASS SYMBOL EQ cexp (let
adamc@563 435 val loc = s (CLASSleft, cexpright)
adamc@563 436 in
adamc@563 437 [(DClass (SYMBOL, (KWild, loc), cexp), loc)]
adamc@563 438 end)
adamc@563 439 | CLASS SYMBOL DCOLON kind EQ cexp ([(DClass (SYMBOL, kind, cexp), s (CLASSleft, cexpright))])
adamc@211 440 | CLASS SYMBOL SYMBOL EQ cexp (let
adamc@211 441 val loc = s (CLASSleft, cexpright)
adamc@563 442 val k = (KWild, loc)
adamc@211 443 val c = (CAbs (SYMBOL2, SOME k, cexp), loc)
adamc@211 444 in
adamc@563 445 [(DClass (SYMBOL1, k, c), s (CLASSleft, cexpright))]
adamc@563 446 end)
adamc@563 447 | CLASS SYMBOL LPAREN SYMBOL DCOLON kind RPAREN EQ cexp (let
adamc@563 448 val loc = s (CLASSleft, cexpright)
adamc@563 449 val c = (CAbs (SYMBOL2, SOME kind, cexp), loc)
adamc@563 450 in
adamc@563 451 [(DClass (SYMBOL1, kind, c), s (CLASSleft, cexpright))]
adamc@211 452 end)
adamc@459 453 | COOKIE SYMBOL COLON cexp ([(DCookie (SYMBOL, cexp), s (COOKIEleft, cexpright))])
adamc@30 454
adamc@240 455 kopt : (NONE)
adamc@240 456 | DCOLON kind (SOME kind)
adamc@240 457
adamc@191 458 dargs : ([])
adamc@191 459 | SYMBOL dargs (SYMBOL :: dargs)
adamc@191 460
adamc@156 461 barOpt : ()
adamc@156 462 | BAR ()
adamc@156 463
adamc@156 464 dcons : dcon ([dcon])
adamc@156 465 | dcon BAR dcons (dcon :: dcons)
adamc@156 466
adamc@156 467 dcon : CSYMBOL (CSYMBOL, NONE)
adamc@156 468 | CSYMBOL OF cexp (CSYMBOL, SOME cexp)
adamc@156 469
adamc@242 470 vali : SYMBOL eargl2 copt EQ eexp (let
adamc@242 471 val loc = s (SYMBOLleft, eexpright)
adamc@242 472 val t = Option.getOpt (copt, (CWild (KType, loc), loc))
adamc@242 473
adamc@242 474 val (e, t) = eargl2 (eexp, t)
adamc@242 475 in
adamc@242 476 (SYMBOL, SOME t, e)
adamc@242 477 end)
adamc@242 478
adamc@242 479 copt : (NONE)
adamc@242 480 | COLON cexp (SOME cexp)
adamc@123 481
adamc@704 482 cstopt : (EVar (["Basis"], "no_constraint", Infer), dummy)
adamc@704 483 | csts (csts)
adamc@704 484
adamc@704 485 csts : CCONSTRAINT tname cst (let
adamc@704 486 val loc = s (CCONSTRAINTleft, cstright)
adamc@704 487
adamc@704 488 val e = (EVar (["Basis"], "one_constraint", Infer), loc)
adamc@704 489 val e = (ECApp (e, tname), loc)
adamc@704 490 in
adamc@704 491 (EApp (e, cst), loc)
adamc@704 492 end)
adamc@704 493 | csts COMMA csts (let
adamc@704 494 val loc = s (csts1left, csts2right)
adamc@704 495
adamc@704 496 val e = (EVar (["Basis"], "join_constraints", Infer), loc)
adamc@704 497 val e = (EApp (e, csts1), loc)
adamc@704 498 in
adamc@704 499 (EApp (e, csts2), loc)
adamc@704 500 end)
adamc@704 501 | LBRACE LBRACE eexp RBRACE RBRACE (eexp)
adamc@704 502
adamc@704 503 cst : UNIQUE tnames (let
adamc@704 504 val loc = s (UNIQUEleft, tnamesright)
adamc@704 505
adamc@704 506 val e = (EVar (["Basis"], "unique", Infer), loc)
adamc@705 507 val e = (ECApp (e, #1 (#1 tnames)), loc)
adamc@705 508 val e = (ECApp (e, (CRecord (#2 tnames), loc)), loc)
adamc@705 509 val e = (EDisjointApp e, loc)
adamc@704 510 in
adamc@704 511 (EDisjointApp e, loc)
adamc@704 512 end)
adamc@709 513
adamc@709 514 | FOREIGN KEY tnames REFERENCES texp LPAREN tnames' RPAREN pmodes
adamc@709 515 (let
adamc@709 516 val loc = s (FOREIGNleft, pmodesright)
adamc@709 517
adamc@709 518 val mat = ListPair.foldrEq
adamc@709 519 (fn ((nm1, _), (nm2, _), mat) =>
adamc@709 520 let
adamc@709 521 val e = (EVar (["Basis"], "mat_cons", Infer), loc)
adamc@709 522 val e = (ECApp (e, nm1), loc)
adamc@709 523 val e = (ECApp (e, nm2), loc)
adamc@709 524 val e = (EDisjointApp e, loc)
adamc@709 525 val e = (EDisjointApp e, loc)
adamc@709 526 in
adamc@709 527 (EApp (e, mat), loc)
adamc@709 528 end)
adamc@709 529 (EVar (["Basis"], "mat_nil", Infer), loc)
adamc@709 530 (#1 tnames :: #2 tnames, #1 tnames' :: #2 tnames')
adamc@709 531
adamc@709 532 fun findMode mode =
adamc@709 533 let
adamc@709 534 fun findMode' pmodes =
adamc@709 535 case pmodes of
adamc@709 536 [] => (EVar (["Basis"], "no_action", Infer), loc)
adamc@709 537 | (mode', rule) :: pmodes' =>
adamc@709 538 if mode' = mode then
adamc@709 539 (if List.exists (fn (mode', _) => mode' = mode)
adamc@709 540 pmodes' then
adamc@709 541 ErrorMsg.errorAt loc "Duplicate propagation rule"
adamc@709 542 else
adamc@709 543 ();
adamc@709 544 rule)
adamc@709 545 else
adamc@709 546 findMode' pmodes'
adamc@709 547 in
adamc@709 548 findMode' pmodes
adamc@709 549 end
adamc@709 550
adamc@709 551 val e = (EVar (["Basis"], "foreign_key", Infer), loc)
adamc@709 552 val e = (EApp (e, mat), loc)
adamc@709 553 val e = (EApp (e, texp), loc)
adamc@709 554 in
adamc@709 555 (EApp (e, (ERecord [((CName "OnDelete", loc),
adamc@709 556 findMode Delete),
adamc@709 557 ((CName "OnUpdate", loc),
adamc@709 558 findMode Update)], loc)), loc)
adamc@709 559 end)
adamc@709 560
adamc@704 561 | LBRACE eexp RBRACE (eexp)
adamc@704 562
adamc@704 563 tnameW : tname (let
adamc@704 564 val loc = s (tnameleft, tnameright)
adamc@704 565 in
adamc@704 566 (tname, (CWild (KType, loc), loc))
adamc@704 567 end)
adamc@704 568
adamc@705 569 tnames : tnameW (tnameW, [])
adamc@705 570 | LPAREN tnames' RPAREN (tnames')
adamc@704 571
adamc@705 572 tnames': tnameW (tnameW, [])
adamc@705 573 | tnameW COMMA tnames' (#1 tnames', tnameW :: #2 tnames')
adamc@704 574
adamc@709 575 pmode : ON pkind prule (pkind, prule)
adamc@709 576
adamc@709 577 pkind : DELETE (Delete)
adamc@709 578 | UPDATE (Update)
adamc@709 579
adamc@709 580 prule : NO ACTION (EVar (["Basis"], "no_action", Infer), s (NOleft, ACTIONright))
adamc@709 581 | RESTRICT (EVar (["Basis"], "restrict", Infer), s (RESTRICTleft, RESTRICTright))
adamc@709 582 | CASCADE (EVar (["Basis"], "cascade", Infer), s (CASCADEleft, CASCADEright))
adamc@709 583 | SET NULL (EVar (["Basis"], "set_null", Infer), s (SETleft, NULLright))
adamc@709 584
adamc@709 585 pmodes : ([])
adamc@709 586 | pmode pmodes (pmode :: pmodes)
adamc@709 587
adamc@707 588 commaOpt: ()
adamc@707 589 | COMMA ()
adamc@707 590
adamc@707 591 pkopt : (EVar (["Basis"], "no_primary_key", Infer), ErrorMsg.dummySpan)
adamc@707 592 | PRIMARY KEY tnames (let
adamc@707 593 val loc = s (PRIMARYleft, tnamesright)
adamc@707 594
adamc@707 595 val e = (EVar (["Basis"], "primary_key", Infer), loc)
adamc@707 596 val e = (ECApp (e, #1 (#1 tnames)), loc)
adamc@707 597 val e = (ECApp (e, (CRecord (#2 tnames), loc)), loc)
adamc@707 598 val e = (EDisjointApp e, loc)
adamc@707 599 val e = (EDisjointApp e, loc)
adamc@707 600
adamc@707 601 val witness = map (fn (c, _) =>
adamc@707 602 (c, (EWild, loc)))
adamc@707 603 (#1 tnames :: #2 tnames)
adamc@707 604 val witness = (ERecord witness, loc)
adamc@707 605 in
adamc@707 606 (EApp (e, witness), loc)
adamc@707 607 end)
adamc@707 608
adamc@123 609 valis : vali ([vali])
adamc@123 610 | vali AND valis (vali :: valis)
adamc@123 611
adamc@42 612 sgn : sgntm (sgntm)
adamc@40 613 | FUNCTOR LPAREN CSYMBOL COLON sgn RPAREN COLON sgn
adamc@40 614 (SgnFun (CSYMBOL, sgn1, sgn2), s (FUNCTORleft, sgn2right))
adamc@30 615
adamc@42 616 sgntm : SIG sgis END (SgnConst sgis, s (SIGleft, ENDright))
adamc@59 617 | mpath (case mpath of
adamc@61 618 [] => raise Fail "Impossible mpath parse [2]"
adamc@59 619 | [x] => SgnVar x
adamc@59 620 | m :: ms => SgnProj (m,
adamc@59 621 List.take (ms, length ms - 1),
adamc@59 622 List.nth (ms, length ms - 1)),
adamc@59 623 s (mpathleft, mpathright))
adamc@42 624 | sgntm WHERE CON SYMBOL EQ cexp (SgnWhere (sgntm, SYMBOL, cexp), s (sgntmleft, cexpright))
adamc@42 625 | sgntm WHERE LTYPE SYMBOL EQ cexp(SgnWhere (sgntm, SYMBOL, cexp), s (sgntmleft, cexpright))
adamc@42 626 | LPAREN sgn RPAREN (sgn)
adamc@42 627
adamc@706 628 sgi : CON SYMBOL DCOLON kind ((SgiConAbs (SYMBOL, kind), s (CONleft, kindright)))
adamc@706 629 | LTYPE SYMBOL ((SgiConAbs (SYMBOL, (KType, s (LTYPEleft, SYMBOLright))),
adamc@706 630 s (LTYPEleft, SYMBOLright)))
adamc@706 631 | CON SYMBOL EQ cexp ((SgiCon (SYMBOL, NONE, cexp), s (CONleft, cexpright)))
adamc@706 632 | CON SYMBOL DCOLON kind EQ cexp ((SgiCon (SYMBOL, SOME kind, cexp), s (CONleft, cexpright)))
adamc@706 633 | LTYPE SYMBOL EQ cexp ((SgiCon (SYMBOL, SOME (KType, s (LTYPEleft, cexpright)), cexp),
adamc@706 634 s (LTYPEleft, cexpright)))
adamc@706 635 | DATATYPE SYMBOL dargs EQ barOpt dcons((SgiDatatype (SYMBOL, dargs, dcons), s (DATATYPEleft, dconsright)))
adamc@191 636 | DATATYPE SYMBOL dargs EQ DATATYPE CSYMBOL DOT path
adamc@191 637 (case dargs of
adamc@191 638 [] => (SgiDatatypeImp (SYMBOL, CSYMBOL :: #1 path, #2 path), s (DATATYPEleft, pathright))
adamc@191 639 | _ => raise Fail "Arguments specified for imported datatype")
adamc@706 640 | VAL SYMBOL COLON cexp ((SgiVal (SYMBOL, cexp), s (VALleft, cexpright)))
adamc@30 641
adamc@706 642 | STRUCTURE CSYMBOL COLON sgn ((SgiStr (CSYMBOL, sgn), s (STRUCTUREleft, sgnright)))
adamc@706 643 | SIGNATURE CSYMBOL EQ sgn ((SgiSgn (CSYMBOL, sgn), s (SIGNATUREleft, sgnright)))
adamc@42 644 | FUNCTOR CSYMBOL LPAREN CSYMBOL COLON sgn RPAREN COLON sgn
adamc@706 645 ((SgiStr (CSYMBOL1,
adamc@706 646 (SgnFun (CSYMBOL2, sgn1, sgn2), s (FUNCTORleft, sgn2right))),
adamc@706 647 s (FUNCTORleft, sgn2right)))
adamc@706 648 | INCLUDE sgn ((SgiInclude sgn, s (INCLUDEleft, sgnright)))
adamc@706 649 | CONSTRAINT cterm TWIDDLE cterm ((SgiConstraint (cterm1, cterm2), s (CONSTRAINTleft, ctermright)))
adamc@707 650 | TABLE SYMBOL COLON cterm pkopt commaOpt cstopt (let
adamc@707 651 val loc = s (TABLEleft, ctermright)
adamc@707 652 in
adamc@707 653 (SgiTable (SYMBOL, entable cterm, pkopt, cstopt), loc)
adamc@707 654 end)
adamc@460 655 | SEQUENCE SYMBOL (let
adamc@460 656 val loc = s (SEQUENCEleft, SYMBOLright)
adamc@460 657 val t = (CVar (["Basis"], "sql_sequence"), loc)
adamc@460 658 in
adamc@460 659 (SgiVal (SYMBOL, t), loc)
adamc@460 660 end)
adamc@563 661 | CLASS SYMBOL (let
adamc@563 662 val loc = s (CLASSleft, SYMBOLright)
adamc@563 663 in
adamc@563 664 (SgiClassAbs (SYMBOL, (KWild, loc)), loc)
adamc@563 665 end)
adamc@563 666 | CLASS SYMBOL DCOLON kind (let
adamc@563 667 val loc = s (CLASSleft, kindright)
adamc@563 668 in
adamc@563 669 (SgiClassAbs (SYMBOL, kind), loc)
adamc@563 670 end)
adamc@563 671 | CLASS SYMBOL EQ cexp (let
adamc@563 672 val loc = s (CLASSleft, cexpright)
adamc@563 673 in
adamc@563 674 (SgiClass (SYMBOL, (KWild, loc), cexp), loc)
adamc@563 675 end)
adamc@563 676 | CLASS SYMBOL DCOLON kind EQ cexp (let
adamc@563 677 val loc = s (CLASSleft, cexpright)
adamc@563 678 in
adamc@563 679 (SgiClass (SYMBOL, kind, cexp), loc)
adamc@563 680 end)
adamc@211 681 | CLASS SYMBOL SYMBOL EQ cexp (let
adamc@211 682 val loc = s (CLASSleft, cexpright)
adamc@563 683 val k = (KWild, loc)
adamc@211 684 val c = (CAbs (SYMBOL2, SOME k, cexp), loc)
adamc@211 685 in
adamc@563 686 (SgiClass (SYMBOL1, k, c), s (CLASSleft, cexpright))
adamc@563 687 end)
adamc@563 688 | CLASS SYMBOL LPAREN SYMBOL DCOLON kind RPAREN EQ cexp (let
adamc@563 689 val loc = s (CLASSleft, cexpright)
adamc@563 690 val c = (CAbs (SYMBOL2, SOME kind, cexp), loc)
adamc@563 691 in
adamc@563 692 (SgiClass (SYMBOL1, kind, c), s (CLASSleft, cexpright))
adamc@211 693 end)
adamc@460 694 | COOKIE SYMBOL COLON cexp (let
adamc@460 695 val loc = s (COOKIEleft, cexpright)
adamc@460 696 val t = (CApp ((CVar (["Basis"], "http_cookie"), loc),
adamc@460 697 entable cexp), loc)
adamc@460 698 in
adamc@460 699 (SgiVal (SYMBOL, t), loc)
adamc@460 700 end)
adamc@30 701
adamc@30 702 sgis : ([])
adamc@30 703 | sgi sgis (sgi :: sgis)
adamc@30 704
adamc@30 705 str : STRUCT decls END (StrConst decls, s (STRUCTleft, ENDright))
adamc@34 706 | spath (spath)
adamc@40 707 | FUNCTOR LPAREN CSYMBOL COLON sgn RPAREN DARROW str
adamc@40 708 (StrFun (CSYMBOL, sgn, NONE, str), s (FUNCTORleft, strright))
adamc@40 709 | FUNCTOR LPAREN CSYMBOL COLON sgn RPAREN COLON sgn DARROW str
adamc@40 710 (StrFun (CSYMBOL, sgn1, SOME sgn2, str), s (FUNCTORleft, strright))
adamc@44 711 | spath LPAREN str RPAREN (StrApp (spath, str), s (spathleft, RPARENright))
adamc@34 712
adamc@34 713 spath : CSYMBOL (StrVar CSYMBOL, s (CSYMBOLleft, CSYMBOLright))
adamc@34 714 | spath DOT CSYMBOL (StrProj (spath, CSYMBOL), s (spathleft, CSYMBOLright))
adamc@30 715
adamc@1 716 kind : TYPE (KType, s (TYPEleft, TYPEright))
adamc@1 717 | NAME (KName, s (NAMEleft, NAMEright))
adamc@1 718 | LBRACE kind RBRACE (KRecord kind, s (LBRACEleft, RBRACEright))
adamc@1 719 | kind ARROW kind (KArrow (kind1, kind2), s (kind1left, kind2right))
adamc@1 720 | LPAREN kind RPAREN (#1 kind, s (LPARENleft, RPARENright))
adamc@82 721 | KUNIT (KUnit, s (KUNITleft, KUNITright))
adamc@18 722 | UNDERUNDER (KWild, s (UNDERUNDERleft, UNDERUNDERright))
adamc@207 723 | LPAREN ktuple RPAREN (KTuple ktuple, s (LPARENleft, RPARENright))
adamc@623 724 | CSYMBOL (KVar CSYMBOL, s (CSYMBOLleft, CSYMBOLright))
adamc@623 725 | CSYMBOL KARROW kind (KFun (CSYMBOL, kind), s (CSYMBOLleft, kindright))
adamc@207 726
adamc@207 727 ktuple : kind STAR kind ([kind1, kind2])
adamc@207 728 | kind STAR ktuple (kind :: ktuple)
adamc@1 729
adamc@1 730 capps : cterm (cterm)
adamc@1 731 | capps cterm (CApp (capps, cterm), s (cappsleft, ctermright))
adamc@1 732
adamc@1 733 cexp : capps (capps)
adamc@1 734 | cexp ARROW cexp (TFun (cexp1, cexp2), s (cexp1left, cexp2right))
adamc@15 735 | SYMBOL kcolon kind ARROW cexp (TCFun (kcolon, SYMBOL, kind, cexp), s (SYMBOLleft, cexpright))
adamc@623 736 | CSYMBOL KARROW cexp (TKFun (CSYMBOL, cexp), s (CSYMBOLleft, cexpright))
adamc@1 737
adamc@1 738 | cexp PLUSPLUS cexp (CConcat (cexp1, cexp2), s (cexp1left, cexp1right))
adamc@1 739
adamc@239 740 | FN cargs DARROW cexp (#1 (cargs (cexp, (KWild, s (FNleft, cexpright)))))
adamc@628 741 | LBRACK cexp TWIDDLE cexp RBRACK DARROW cexp (TDisjoint (cexp1, cexp2, cexp3), s (LBRACKleft, cexp3right))
adamc@623 742 | CSYMBOL DKARROW cexp (CKAbs (CSYMBOL, cexp), s (CSYMBOLleft, cexpright))
adamc@1 743
adamc@8 744 | LPAREN cexp RPAREN DCOLON kind (CAnnot (cexp, kind), s (LPARENleft, kindright))
adamc@6 745
adamc@18 746 | UNDER DCOLON kind (CWild kind, s (UNDERleft, UNDERright))
adamc@195 747 | ctuple (let
adamc@195 748 val loc = s (ctupleleft, ctupleright)
adamc@195 749 in
adamc@195 750 (TRecord (CRecord (ListUtil.mapi (fn (i, c) =>
adamc@195 751 ((CName (Int.toString (i + 1)), loc),
adamc@195 752 c)) ctuple),
adamc@195 753 loc), loc)
adamc@195 754 end)
adamc@18 755
adamc@1 756 kcolon : DCOLON (Explicit)
adamc@1 757 | TCOLON (Implicit)
adamc@1 758
adamc@239 759 cargs : carg (carg)
adamc@239 760 | cargl (cargl)
adamc@239 761
adamc@239 762 cargl : cargp cargp (cargp1 o cargp2)
adamc@239 763 | cargp cargl (cargp o cargl)
adamc@239 764
adamc@240 765 cargl2 : (fn x => x)
adamc@240 766 | cargp cargl2 (cargp o cargl2)
adamc@240 767
adamc@241 768 carg : SYMBOL DCOLON kind (fn (c, k) =>
adamc@239 769 let
adamc@239 770 val loc = s (SYMBOLleft, kindright)
adamc@239 771 in
adamc@239 772 ((CAbs (SYMBOL, SOME kind, c), loc),
adamc@239 773 (KArrow (kind, k), loc))
adamc@239 774 end)
adamc@329 775 | UNDER DCOLON kind (fn (c, k) =>
adamc@329 776 let
adamc@329 777 val loc = s (UNDERleft, kindright)
adamc@329 778 in
adamc@329 779 ((CAbs ("_", SOME kind, c), loc),
adamc@329 780 (KArrow (kind, k), loc))
adamc@329 781 end)
adamc@241 782 | cargp (cargp)
adamc@239 783
adamc@239 784 cargp : SYMBOL (fn (c, k) =>
adamc@239 785 let
adamc@239 786 val loc = s (SYMBOLleft, SYMBOLright)
adamc@239 787 in
adamc@239 788 ((CAbs (SYMBOL, NONE, c), loc),
adamc@239 789 (KArrow ((KWild, loc), k), loc))
adamc@239 790 end)
adamc@329 791 | UNDER (fn (c, k) =>
adamc@329 792 let
adamc@329 793 val loc = s (UNDERleft, UNDERright)
adamc@329 794 in
adamc@329 795 ((CAbs ("_", NONE, c), loc),
adamc@329 796 (KArrow ((KWild, loc), k), loc))
adamc@329 797 end)
adamc@239 798 | LPAREN SYMBOL DCOLON kind RPAREN (fn (c, k) =>
adamc@239 799 let
adamc@239 800 val loc = s (LPARENleft, RPARENright)
adamc@239 801 in
adamc@239 802 ((CAbs (SYMBOL, SOME kind, c), loc),
adamc@239 803 (KArrow (kind, k), loc))
adamc@239 804 end)
adamc@628 805
adamc@239 806
adamc@34 807 path : SYMBOL ([], SYMBOL)
adamc@34 808 | CSYMBOL DOT path (let val (ms, x) = path in (CSYMBOL :: ms, x) end)
adamc@34 809
adamc@156 810 cpath : CSYMBOL ([], CSYMBOL)
adamc@156 811 | CSYMBOL DOT cpath (let val (ms, x) = cpath in (CSYMBOL :: ms, x) end)
adamc@156 812
adamc@59 813 mpath : CSYMBOL ([CSYMBOL])
adamc@59 814 | CSYMBOL DOT mpath (CSYMBOL :: mpath)
adamc@59 815
adamc@1 816 cterm : LPAREN cexp RPAREN (#1 cexp, s (LPARENleft, RPARENright))
adamc@1 817 | LBRACK rcon RBRACK (CRecord rcon, s (LBRACKleft, RBRACKright))
adamc@83 818 | LBRACK rconn RBRACK (CRecord rconn, s (LBRACKleft, RBRACKright))
adamc@1 819 | LBRACE rcone RBRACE (TRecord (CRecord rcone, s (LBRACEleft, RBRACEright)),
adamc@1 820 s (LBRACEleft, RBRACEright))
adamc@1 821 | DOLLAR cterm (TRecord cterm, s (DOLLARleft, ctermright))
adamc@1 822 | HASH CSYMBOL (CName CSYMBOL, s (HASHleft, CSYMBOLright))
adamc@195 823 | HASH INT (CName (Int64.toString INT), s (HASHleft, INTright))
adamc@1 824
adamc@34 825 | path (CVar path, s (pathleft, pathright))
adamc@207 826 | path DOT INT (CProj ((CVar path, s (pathleft, pathright)), Int64.toInt INT),
adamc@207 827 s (pathleft, INTright))
adamc@18 828 | UNDER (CWild (KWild, s (UNDERleft, UNDERright)), s (UNDERleft, UNDERright))
adamc@621 829 | MAP (CMap, s (MAPleft, MAPright))
adamc@82 830 | UNIT (CUnit, s (UNITleft, UNITright))
adamc@207 831 | LPAREN ctuplev RPAREN (CTuple ctuplev, s (LPARENleft, RPARENright))
adamc@207 832
adamc@207 833 ctuplev: cexp COMMA cexp ([cexp1, cexp2])
adamc@207 834 | cexp COMMA ctuplev (cexp :: ctuplev)
adamc@1 835
adamc@196 836 ctuple : capps STAR capps ([capps1, capps2])
adamc@196 837 | capps STAR ctuple (capps :: ctuple)
adamc@195 838
adamc@1 839 rcon : ([])
adamc@1 840 | ident EQ cexp ([(ident, cexp)])
adamc@1 841 | ident EQ cexp COMMA rcon ((ident, cexp) :: rcon)
adamc@1 842
adamc@83 843 rconn : ident ([(ident, (CUnit, s (identleft, identright)))])
adamc@83 844 | ident COMMA rconn ((ident, (CUnit, s (identleft, identright))) :: rconn)
adamc@83 845
adamc@1 846 rcone : ([])
adamc@1 847 | ident COLON cexp ([(ident, cexp)])
adamc@1 848 | ident COLON cexp COMMA rcone ((ident, cexp) :: rcone)
adamc@1 849
adamc@1 850 ident : CSYMBOL (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright))
adamc@195 851 | INT (CName (Int64.toString INT), s (INTleft, INTright))
adamc@200 852 | SYMBOL (CVar ([], SYMBOL), s (SYMBOLleft, SYMBOLright))
adamc@8 853
adamc@8 854 eapps : eterm (eterm)
adamc@8 855 | eapps eterm (EApp (eapps, eterm), s (eappsleft, etermright))
adamc@8 856 | eapps LBRACK cexp RBRACK (ECApp (eapps, cexp), s (eappsleft, RBRACKright))
adamc@629 857 | eapps BANG (EDisjointApp eapps, s (eappsleft, BANGright))
adamc@8 858
adamc@8 859 eexp : eapps (eapps)
adamc@241 860 | FN eargs DARROW eexp (let
adamc@93 861 val loc = s (FNleft, eexpright)
adamc@93 862 in
adamc@241 863 #1 (eargs (eexp, (CWild (KType, loc), loc)))
adamc@93 864 end)
adamc@623 865 | CSYMBOL DKARROW eexp (EKAbs (CSYMBOL, eexp), s (CSYMBOLleft, eexpright))
adamc@196 866 | eexp COLON cexp (EAnnot (eexp, cexp), s (eexpleft, cexpright))
adamc@149 867 | eexp MINUSMINUS cexp (ECut (eexp, cexp), s (eexpleft, cexpright))
adamc@493 868 | eexp MINUSMINUSMINUS cexp (ECutMulti (eexp, cexp), s (eexpleft, cexpright))
adamc@170 869 | CASE eexp OF barOpt branch branchs (ECase (eexp, branch :: branchs), s (CASEleft, branchsright))
adamc@190 870 | IF eexp THEN eexp ELSE eexp (let
adamc@190 871 val loc = s (IFleft, eexp3right)
adamc@190 872 in
adamc@190 873 (ECase (eexp1, [((PCon (["Basis"], "True", NONE), loc), eexp2),
adamc@190 874 ((PCon (["Basis"], "False", NONE), loc), eexp3)]), loc)
adamc@190 875 end)
adamc@434 876 | bind SEMI eexp (let
adamc@434 877 val loc = s (bindleft, eexpright)
adamc@434 878 val (v, to, e1) = bind
adamc@403 879 val e = (EVar (["Basis"], "bind", Infer), loc)
adamc@434 880 val e = (EApp (e, e1), loc)
adamc@243 881 in
adamc@434 882 (EApp (e, (EAbs (v, to, eexp), loc)), loc)
adamc@299 883 end)
adamc@256 884 | eexp EQ eexp (native_op ("eq", eexp1, eexp2, s (eexp1left, eexp2right)))
adamc@257 885 | eexp NE eexp (native_op ("ne", eexp1, eexp2, s (eexp1left, eexp2right)))
adamc@389 886 | MINUS eterm (native_unop ("neg", eterm, s (MINUSleft, etermright)))
adamc@389 887 | eexp PLUS eexp (native_op ("plus", eexp1, eexp2, s (eexp1left, eexp2right)))
adamc@389 888 | eexp MINUS eexp (native_op ("minus", eexp1, eexp2, s (eexp1left, eexp2right)))
adamc@389 889 | eterm STAR eexp (native_op ("times", eterm, eexp, s (etermleft, eexpright)))
adamc@389 890 | eexp DIVIDE eexp (native_op ("div", eexp1, eexp2, s (eexp1left, eexp2right)))
adamc@389 891 | eexp MOD eexp (native_op ("mod", eexp1, eexp2, s (eexp1left, eexp2right)))
adamc@391 892
adamc@391 893 | eexp LT eexp (native_op ("lt", eexp1, eexp2, s (eexp1left, eexp2right)))
adamc@391 894 | eexp LE eexp (native_op ("le", eexp1, eexp2, s (eexp1left, eexp2right)))
adamc@391 895 | eexp GT eexp (native_op ("gt", eexp1, eexp2, s (eexp1left, eexp2right)))
adamc@391 896 | eexp GE eexp (native_op ("ge", eexp1, eexp2, s (eexp1left, eexp2right)))
adamc@391 897
adamc@445 898 | eexp PLUSPLUS eexp (EConcat (eexp1, eexp2), s (eexp1left, eexp2right))
adamc@8 899
adamc@674 900 | eexp CARET eexp (native_op ("strcat", eexp1, eexp2, s (eexp1left, eexp2right)))
adamc@674 901
adamc@434 902 bind : SYMBOL LARROW eapps (SYMBOL, NONE, eapps)
adamc@434 903 | UNIT LARROW eapps (let
adamc@434 904 val loc = s (UNITleft, eappsright)
adamc@434 905 in
adamc@434 906 ("_", SOME (TRecord (CRecord [], loc), loc), eapps)
adamc@434 907 end)
adamc@434 908 | eapps (let
adamc@434 909 val loc = s (eappsleft, eappsright)
adamc@434 910 in
adamc@434 911 ("_", SOME (TRecord (CRecord [], loc), loc), eapps)
adamc@434 912 end)
adamc@434 913
adamc@241 914 eargs : earg (earg)
adamc@241 915 | eargl (eargl)
adamc@241 916
adamc@241 917 eargl : eargp eargp (eargp1 o eargp2)
adamc@241 918 | eargp eargl (eargp o eargl)
adamc@241 919
adamc@242 920 eargl2 : (fn x => x)
adamc@242 921 | eargp eargl2 (eargp o eargl2)
adamc@242 922
adamc@241 923 earg : SYMBOL kcolon kind (fn (e, t) =>
adamc@241 924 let
adamc@241 925 val loc = s (SYMBOLleft, kindright)
adamc@241 926 in
adamc@241 927 ((ECAbs (kcolon, SYMBOL, kind, e), loc),
adamc@241 928 (TCFun (kcolon, SYMBOL, kind, t), loc))
adamc@241 929 end)
adamc@241 930 | SYMBOL COLON cexp (fn (e, t) =>
adamc@241 931 let
adamc@241 932 val loc = s (SYMBOLleft, cexpright)
adamc@241 933 in
adamc@241 934 ((EAbs (SYMBOL, SOME cexp, e), loc),
adamc@241 935 (TFun (cexp, t), loc))
adamc@241 936 end)
adamc@241 937 | UNDER COLON cexp (fn (e, t) =>
adamc@241 938 let
adamc@241 939 val loc = s (UNDERleft, cexpright)
adamc@241 940 in
adamc@241 941 ((EAbs ("_", SOME cexp, e), loc),
adamc@241 942 (TFun (cexp, t), loc))
adamc@241 943 end)
adamc@241 944 | eargp (eargp)
adamc@241 945
adamc@241 946 eargp : SYMBOL (fn (e, t) =>
adamc@241 947 let
adamc@241 948 val loc = s (SYMBOLleft, SYMBOLright)
adamc@241 949 in
adamc@241 950 ((EAbs (SYMBOL, NONE, e), loc),
adamc@241 951 (TFun ((CWild (KType, loc), loc), t), loc))
adamc@241 952 end)
adamc@241 953 | UNIT (fn (e, t) =>
adamc@241 954 let
adamc@241 955 val loc = s (UNITleft, UNITright)
adamc@241 956 val t' = (TRecord (CRecord [], loc), loc)
adamc@241 957 in
adamc@241 958 ((EAbs ("_", SOME t', e), loc),
adamc@241 959 (TFun (t', t), loc))
adamc@241 960 end)
adamc@241 961 | UNDER (fn (e, t) =>
adamc@241 962 let
adamc@241 963 val loc = s (UNDERleft, UNDERright)
adamc@241 964 in
adamc@241 965 ((EAbs ("_", NONE, e), loc),
adamc@241 966 (TFun ((CWild (KType, loc), loc), t), loc))
adamc@241 967 end)
adamc@241 968 | LPAREN SYMBOL kcolon kind RPAREN(fn (e, t) =>
adamc@241 969 let
adamc@241 970 val loc = s (LPARENleft, RPARENright)
adamc@241 971 in
adamc@241 972 ((ECAbs (kcolon, SYMBOL, kind, e), loc),
adamc@241 973 (TCFun (kcolon, SYMBOL, kind, t), loc))
adamc@241 974 end)
adamc@241 975 | LPAREN SYMBOL COLON cexp RPAREN (fn (e, t) =>
adamc@241 976 let
adamc@241 977 val loc = s (LPARENleft, RPARENright)
adamc@241 978 in
adamc@241 979 ((EAbs (SYMBOL, SOME cexp, e), loc),
adamc@241 980 (TFun (cexp, t), loc))
adamc@241 981 end)
adamc@241 982 | LPAREN UNDER COLON cexp RPAREN (fn (e, t) =>
adamc@241 983 let
adamc@241 984 val loc = s (LPARENleft, RPARENright)
adamc@241 985 in
adamc@241 986 ((EAbs ("_", SOME cexp, e), loc),
adamc@241 987 (TFun (cexp, t), loc))
adamc@241 988 end)
adamc@478 989 | LPAREN cexp TWIDDLE cexp RPAREN (fn (e, t) =>
adamc@354 990 let
adamc@354 991 val loc = s (LPARENleft, RPARENright)
adamc@354 992 in
adamc@478 993 ((EDisjoint (cexp1, cexp2, e), loc),
adamc@628 994 (TDisjoint (cexp1, cexp2, t), loc))
adamc@354 995 end)
adamc@478 996 | LBRACK cexp TWIDDLE cexp RBRACK(fn (e, t) =>
adamc@356 997 let
adamc@356 998 val loc = s (LBRACKleft, RBRACKright)
adamc@356 999 in
adamc@478 1000 ((EDisjoint (cexp1, cexp2, e), loc),
adamc@628 1001 (TDisjoint (cexp1, cexp2, t), loc))
adamc@356 1002 end)
adamc@623 1003 | CSYMBOL (fn (e, t) =>
adamc@623 1004 let
adamc@623 1005 val loc = s (CSYMBOLleft, CSYMBOLright)
adamc@623 1006 in
adamc@623 1007 ((EKAbs (CSYMBOL, e), loc),
adamc@623 1008 (TKFun (CSYMBOL, t), loc))
adamc@623 1009 end)
adamc@241 1010
adamc@8 1011 eterm : LPAREN eexp RPAREN (#1 eexp, s (LPARENleft, RPARENright))
adamc@195 1012 | LPAREN etuple RPAREN (let
adamc@195 1013 val loc = s (LPARENleft, RPARENright)
adamc@195 1014 in
adamc@195 1015 (ERecord (ListUtil.mapi (fn (i, e) =>
adamc@195 1016 ((CName (Int.toString (i + 1)), loc),
adamc@195 1017 e)) etuple), loc)
adamc@195 1018 end)
adamc@8 1019
adamc@403 1020 | path (EVar (#1 path, #2 path, Infer), s (pathleft, pathright))
adamc@403 1021 | cpath (EVar (#1 cpath, #2 cpath, Infer), s (cpathleft, cpathright))
adamc@403 1022 | AT path (EVar (#1 path, #2 path, TypesOnly), s (ATleft, pathright))
adamc@403 1023 | AT AT path (EVar (#1 path, #2 path, DontInfer), s (AT1left, pathright))
adamc@403 1024 | AT cpath (EVar (#1 cpath, #2 cpath, TypesOnly), s (ATleft, cpathright))
adamc@403 1025 | AT AT cpath (EVar (#1 cpath, #2 cpath, DontInfer), s (AT1left, cpathright))
adamc@12 1026 | LBRACE rexp RBRACE (ERecord rexp, s (LBRACEleft, RBRACEright))
adamc@110 1027 | UNIT (ERecord [], s (UNITleft, UNITright))
adamc@12 1028
adamc@14 1029 | INT (EPrim (Prim.Int INT), s (INTleft, INTright))
adamc@14 1030 | FLOAT (EPrim (Prim.Float FLOAT), s (FLOATleft, FLOATright))
adamc@14 1031 | STRING (EPrim (Prim.String STRING), s (STRINGleft, STRINGright))
adamc@14 1032
adamc@200 1033 | path DOT idents (let
adamc@200 1034 val loc = s (pathleft, identsright)
adamc@200 1035 in
adamc@200 1036 foldl (fn (ident, e) =>
adamc@200 1037 (EField (e, ident), loc))
adamc@403 1038 (EVar (#1 path, #2 path, Infer), s (pathleft, pathright)) idents
adamc@403 1039 end)
adamc@403 1040 | AT path DOT idents (let
adamc@403 1041 val loc = s (ATleft, identsright)
adamc@403 1042 in
adamc@403 1043 foldl (fn (ident, e) =>
adamc@403 1044 (EField (e, ident), loc))
adamc@403 1045 (EVar (#1 path, #2 path, TypesOnly), s (pathleft, pathright)) idents
adamc@403 1046 end)
adamc@403 1047 | AT AT path DOT idents (let
adamc@403 1048 val loc = s (AT1left, identsright)
adamc@403 1049 in
adamc@403 1050 foldl (fn (ident, e) =>
adamc@403 1051 (EField (e, ident), loc))
adamc@403 1052 (EVar (#1 path, #2 path, DontInfer), s (pathleft, pathright)) idents
adamc@200 1053 end)
adamc@71 1054
adamc@360 1055 | XML_BEGIN xml XML_END (let
adamc@360 1056 val loc = s (XML_BEGINleft, XML_ENDright)
adamc@360 1057 in
adamc@360 1058 if XML_BEGIN = "xml" then
adamc@360 1059 ()
adamc@360 1060 else
adamc@360 1061 ErrorMsg.errorAt loc "Initial XML tag pair aren't both tagged \"xml\".";
adamc@360 1062 xml
adamc@360 1063 end)
adamc@360 1064 | XML_BEGIN XML_END (let
adamc@360 1065 val loc = s (XML_BEGINleft, XML_ENDright)
adamc@360 1066 in
adamc@360 1067 if XML_BEGIN = "xml" then
adamc@360 1068 ()
adamc@360 1069 else
adamc@360 1070 ErrorMsg.errorAt loc "Initial XML tag pair aren't both tagged \"xml\".";
adamc@403 1071 (EApp ((EVar (["Basis"], "cdata", Infer), loc),
adamc@360 1072 (EPrim (Prim.String ""), loc)),
adamc@360 1073 loc)
adamc@360 1074 end)
adamc@360 1075 | XML_BEGIN_END (let
adamc@360 1076 val loc = s (XML_BEGIN_ENDleft, XML_BEGIN_ENDright)
adamc@360 1077 in
adamc@360 1078 if XML_BEGIN_END = "xml" then
adamc@360 1079 ()
adamc@360 1080 else
adamc@360 1081 ErrorMsg.errorAt loc "Initial XML tag pair aren't both tagged \"xml\".";
adamc@403 1082 (EApp ((EVar (["Basis"], "cdata", Infer), loc),
adamc@360 1083 (EPrim (Prim.String ""), loc)),
adamc@360 1084 loc)
adamc@360 1085 end)
adamc@302 1086
adamc@204 1087 | LPAREN query RPAREN (query)
adamc@300 1088 | LPAREN CWHERE sqlexp RPAREN (sqlexp)
adamc@339 1089 | LPAREN SQL sqlexp RPAREN (sqlexp)
adamc@302 1090
adamc@302 1091 | LPAREN INSERT INTO texp LPAREN fields RPAREN VALUES LPAREN sqlexps RPAREN RPAREN
adamc@302 1092 (let
adamc@302 1093 val loc = s (LPAREN1left, RPAREN3right)
adamc@302 1094
adamc@403 1095 val e = (EVar (["Basis"], "insert", Infer), loc)
adamc@302 1096 val e = (EApp (e, texp), loc)
adamc@302 1097 in
adamc@302 1098 if length fields <> length sqlexps then
adamc@302 1099 ErrorMsg.errorAt loc "Length mismatch in INSERT field specification"
adamc@302 1100 else
adamc@302 1101 ();
adamc@302 1102 (EApp (e, (ERecord (ListPair.zip (fields, sqlexps)), loc)), loc)
adamc@302 1103 end)
adamc@310 1104 | LPAREN enterDml UPDATE texp SET fsets CWHERE sqlexp leaveDml RPAREN
adamc@303 1105 (let
adamc@303 1106 val loc = s (LPARENleft, RPARENright)
adamc@303 1107
adamc@403 1108 val e = (EVar (["Basis"], "update", Infer), loc)
adamc@342 1109 val e = (ECApp (e, (CWild (KRecord (KType, loc), loc), loc)), loc)
adamc@632 1110 val e = (EDisjointApp e, loc)
adamc@306 1111 val e = (EApp (e, (ERecord fsets, loc)), loc)
adamc@305 1112 val e = (EApp (e, texp), loc)
adamc@303 1113 in
adamc@303 1114 (EApp (e, sqlexp), loc)
adamc@303 1115 end)
adamc@310 1116 | LPAREN enterDml DELETE FROM texp CWHERE sqlexp leaveDml RPAREN
adamc@304 1117 (let
adamc@304 1118 val loc = s (LPARENleft, RPARENright)
adamc@304 1119
adamc@403 1120 val e = (EVar (["Basis"], "delete", Infer), loc)
adamc@304 1121 val e = (EApp (e, texp), loc)
adamc@304 1122 in
adamc@304 1123 (EApp (e, sqlexp), loc)
adamc@304 1124 end)
adamc@302 1125
adamc@211 1126 | UNDER (EWild, s (UNDERleft, UNDERright))
adamc@91 1127
adamc@446 1128 | LET edecls IN eexp END (ELet (edecls, eexp), s (LETleft, ENDright))
adamc@446 1129
adamc@446 1130 edecls : ([])
adamc@446 1131 | edecl edecls (edecl :: edecls)
adamc@446 1132
adamc@446 1133 edecl : VAL vali ((EDVal vali, s (VALleft, valiright)))
adamc@446 1134 | VAL REC valis ((EDValRec valis, s (VALleft, valisright)))
adamc@446 1135 | FUN valis ((EDValRec valis, s (FUNleft, valisright)))
adamc@446 1136
adamc@310 1137 enterDml : (inDml := true)
adamc@310 1138 leaveDml : (inDml := false)
adamc@310 1139
adamc@403 1140 texp : SYMBOL (EVar ([], SYMBOL, Infer), s (SYMBOLleft, SYMBOLright))
adamc@302 1141 | LBRACE LBRACE eexp RBRACE RBRACE (eexp)
adamc@302 1142
adamc@302 1143 fields : fident ([fident])
adamc@302 1144 | fident COMMA fields (fident :: fields)
adamc@302 1145
adamc@302 1146 sqlexps: sqlexp ([sqlexp])
adamc@302 1147 | sqlexp COMMA sqlexps (sqlexp :: sqlexps)
adamc@302 1148
adamc@303 1149 fsets : fident EQ sqlexp ([(fident, sqlexp)])
adamc@303 1150 | fident EQ sqlexp COMMA fsets ((fident, sqlexp) :: fsets)
adamc@303 1151
adamc@200 1152 idents : ident ([ident])
adamc@200 1153 | ident DOT idents (ident :: idents)
adamc@200 1154
adamc@195 1155 etuple : eexp COMMA eexp ([eexp1, eexp2])
adamc@195 1156 | eexp COMMA etuple (eexp :: etuple)
adamc@195 1157
adamc@170 1158 branch : pat DARROW eexp (pat, eexp)
adamc@170 1159
adamc@170 1160 branchs: ([])
adamc@170 1161 | BAR branch branchs (branch :: branchs)
adamc@170 1162
adamc@170 1163 pat : pterm (pterm)
adamc@170 1164 | cpath pterm (PCon (#1 cpath, #2 cpath, SOME pterm), s (cpathleft, ptermright))
adamc@170 1165
adamc@170 1166 pterm : SYMBOL (PVar SYMBOL, s (SYMBOLleft, SYMBOLright))
adamc@170 1167 | cpath (PCon (#1 cpath, #2 cpath, NONE), s (cpathleft, cpathright))
adamc@170 1168 | UNDER (PWild, s (UNDERleft, UNDERright))
adamc@173 1169 | INT (PPrim (Prim.Int INT), s (INTleft, INTright))
adamc@173 1170 | STRING (PPrim (Prim.String STRING), s (STRINGleft, STRINGright))
adamc@170 1171 | LPAREN pat RPAREN (pat)
adamc@174 1172 | LBRACE RBRACE (PRecord ([], false), s (LBRACEleft, RBRACEright))
adamc@174 1173 | UNIT (PRecord ([], false), s (UNITleft, UNITright))
adamc@174 1174 | LBRACE rpat RBRACE (PRecord rpat, s (LBRACEleft, RBRACEright))
adamc@195 1175 | LPAREN ptuple RPAREN (PRecord (ListUtil.mapi (fn (i, p) => (Int.toString (i + 1), p)) ptuple,
adamc@195 1176 false),
adamc@195 1177 s (LPARENleft, RPARENright))
adamc@174 1178
adamc@175 1179 rpat : CSYMBOL EQ pat ([(CSYMBOL, pat)], false)
adamc@243 1180 | INT EQ pat ([(Int64.toString INT, pat)], false)
adamc@174 1181 | DOTDOTDOT ([], true)
adamc@175 1182 | CSYMBOL EQ pat COMMA rpat ((CSYMBOL, pat) :: #1 rpat, #2 rpat)
adamc@243 1183 | INT EQ pat COMMA rpat ((Int64.toString INT, pat) :: #1 rpat, #2 rpat)
adamc@170 1184
adamc@195 1185 ptuple : pat COMMA pat ([pat1, pat2])
adamc@195 1186 | pat COMMA ptuple (pat :: ptuple)
adamc@195 1187
adamc@12 1188 rexp : ([])
adamc@12 1189 | ident EQ eexp ([(ident, eexp)])
adamc@12 1190 | ident EQ eexp COMMA rexp ((ident, eexp) :: rexp)
adamc@91 1191
adamc@141 1192 xml : xmlOne xml (let
adamc@141 1193 val pos = s (xmlOneleft, xmlright)
adamc@141 1194 in
adamc@141 1195 (EApp ((EApp (
adamc@403 1196 (EVar (["Basis"], "join", Infer), pos),
adamc@91 1197 xmlOne), pos),
adamc@141 1198 xml), pos)
adamc@141 1199 end)
adamc@141 1200 | xmlOne (xmlOne)
adamc@91 1201
adamc@403 1202 xmlOne : NOTAGS (EApp ((EVar (["Basis"], "cdata", Infer), s (NOTAGSleft, NOTAGSright)),
adamc@141 1203 (EPrim (Prim.String NOTAGS), s (NOTAGSleft, NOTAGSright))),
adamc@141 1204 s (NOTAGSleft, NOTAGSright))
adamc@141 1205 | tag DIVIDE GT (let
adamc@141 1206 val pos = s (tagleft, GTright)
adamc@141 1207 in
adamc@141 1208 (EApp (#2 tag,
adamc@403 1209 (EApp ((EVar (["Basis"], "cdata", Infer), pos),
adamc@141 1210 (EPrim (Prim.String ""), pos)),
adamc@141 1211 pos)), pos)
adamc@141 1212 end)
adamc@141 1213
adamc@141 1214 | tag GT xml END_TAG (let
adamc@141 1215 val pos = s (tagleft, GTright)
adamc@325 1216 val et = tagIn END_TAG
adamc@141 1217 in
adamc@325 1218 if #1 tag = et then
adamc@361 1219 if et = "form" then
adamc@403 1220 (EApp ((EVar (["Basis"], "form", Infer), pos),
adamc@141 1221 xml), pos)
adamc@141 1222 else
adamc@141 1223 (EApp (#2 tag, xml), pos)
adamc@141 1224 else
adamc@325 1225 (if ErrorMsg.anyErrors () then
adamc@325 1226 ()
adamc@325 1227 else
adamc@325 1228 ErrorMsg.errorAt pos "Begin and end tags don't match.";
adamc@623 1229 (EWild, pos))
adamc@141 1230 end)
adamc@141 1231 | LBRACE eexp RBRACE (eexp)
adamc@391 1232 | LBRACE LBRACK eexp RBRACK RBRACE (let
adamc@391 1233 val loc = s (LBRACEleft, RBRACEright)
adamc@403 1234 val e = (EVar (["Top"], "txt", Infer), loc)
adamc@391 1235 in
adamc@391 1236 (EApp (e, eexp), loc)
adamc@391 1237 end)
adamc@92 1238
adamc@141 1239 tag : tagHead attrs (let
adamc@141 1240 val pos = s (tagHeadleft, attrsright)
adamc@141 1241 in
adamc@141 1242 (#1 tagHead,
adamc@403 1243 (EApp ((EApp ((EVar (["Basis"], "tag", Infer), pos),
adamc@141 1244 (ERecord attrs, pos)), pos),
adamc@141 1245 (EApp (#2 tagHead,
adamc@141 1246 (ERecord [], pos)), pos)),
adamc@141 1247 pos))
adamc@141 1248 end)
adamc@141 1249
adamc@141 1250 tagHead: BEGIN_TAG (let
adamc@325 1251 val bt = tagIn BEGIN_TAG
adamc@141 1252 val pos = s (BEGIN_TAGleft, BEGIN_TAGright)
adamc@141 1253 in
adamc@325 1254 (bt,
adamc@473 1255 (EVar (["Basis"], bt, Infer), pos))
adamc@141 1256 end)
adamc@141 1257 | tagHead LBRACE cexp RBRACE (#1 tagHead, (ECApp (#2 tagHead, cexp), s (tagHeadleft, RBRACEright)))
adamc@92 1258
adamc@104 1259 attrs : ([])
adamc@104 1260 | attr attrs (attr :: attrs)
adamc@104 1261
adamc@204 1262 attr : SYMBOL EQ attrv ((CName (capitalize SYMBOL), s (SYMBOLleft, SYMBOLright)), attrv)
adamc@204 1263
adamc@104 1264 attrv : INT (EPrim (Prim.Int INT), s (INTleft, INTright))
adamc@104 1265 | FLOAT (EPrim (Prim.Float FLOAT), s (FLOATleft, FLOATright))
adamc@104 1266 | STRING (EPrim (Prim.String STRING), s (STRINGleft, STRINGright))
adamc@110 1267 | LBRACE eexp RBRACE (eexp)
adamc@226 1268
adamc@232 1269 query : query1 obopt lopt ofopt (let
adamc@229 1270 val loc = s (query1left, query1right)
adamc@230 1271
adamc@230 1272 val re = (ERecord [((CName "Rows", loc),
adamc@230 1273 query1),
adamc@230 1274 ((CName "OrderBy", loc),
adamc@231 1275 obopt),
adamc@231 1276 ((CName "Limit", loc),
adamc@232 1277 lopt),
adamc@232 1278 ((CName "Offset", loc),
adamc@232 1279 ofopt)], loc)
adamc@229 1280 in
adamc@403 1281 (EApp ((EVar (["Basis"], "sql_query", Infer), loc), re), loc)
adamc@229 1282 end)
adamc@204 1283
adamc@227 1284 query1 : SELECT select FROM tables wopt gopt hopt
adamc@209 1285 (let
adamc@204 1286 val loc = s (SELECTleft, tablesright)
adamc@207 1287
adamc@233 1288 val (sel, exps) =
adamc@207 1289 case select of
adamc@233 1290 Star => (map (fn (nm, _) =>
adamc@233 1291 (nm, (CTuple [(CWild (KRecord (KType, loc), loc),
adamc@233 1292 loc),
adamc@233 1293 (CRecord [], loc)],
adamc@233 1294 loc))) tables,
adamc@233 1295 [])
adamc@207 1296 | Items sis =>
adamc@207 1297 let
adamc@207 1298 val tabs = map (fn (nm, _) => (nm, (CRecord [], loc))) tables
adamc@233 1299 val (tabs, exps) = foldl (amend_select loc) (tabs, []) sis
adamc@207 1300 in
adamc@233 1301 (map (fn (nm, c) => (nm,
adamc@233 1302 (CTuple [c,
adamc@233 1303 (CWild (KRecord (KType, loc), loc),
adamc@233 1304 loc)], loc))) tabs,
adamc@233 1305 exps)
adamc@207 1306 end
adamc@207 1307
adamc@207 1308 val sel = (CRecord sel, loc)
adamc@207 1309
adamc@226 1310 val grp = case gopt of
adamc@403 1311 NONE => (ECApp ((EVar (["Basis"], "sql_subset_all",
adamc@403 1312 Infer), loc),
adamc@226 1313 (CWild (KRecord (KRecord (KType, loc), loc),
adamc@226 1314 loc), loc)), loc)
adamc@226 1315 | SOME gis =>
adamc@226 1316 let
adamc@226 1317 val tabs = map (fn (nm, _) =>
adamc@226 1318 (nm, (CRecord [], loc))) tables
adamc@226 1319 val tabs = foldl (amend_group loc) tabs gis
adamc@226 1320
adamc@226 1321 val tabs = map (fn (nm, c) =>
adamc@226 1322 (nm,
adamc@226 1323 (CTuple [c,
adamc@226 1324 (CWild (KRecord (KType, loc),
adamc@226 1325 loc),
adamc@226 1326 loc)], loc))) tabs
adamc@226 1327 in
adamc@403 1328 (ECApp ((EVar (["Basis"], "sql_subset", Infer), loc),
adamc@226 1329 (CRecord tabs, loc)), loc)
adamc@226 1330 end
adamc@226 1331
adamc@403 1332 val e = (EVar (["Basis"], "sql_query1", Infer), loc)
adamc@209 1333 val re = (ERecord [((CName "From", loc),
adamc@209 1334 (ERecord tables, loc)),
adamc@209 1335 ((CName "Where", loc),
adamc@223 1336 wopt),
adamc@224 1337 ((CName "GroupBy", loc),
adamc@226 1338 grp),
adamc@224 1339 ((CName "Having", loc),
adamc@224 1340 hopt),
adamc@223 1341 ((CName "SelectFields", loc),
adamc@403 1342 (ECApp ((EVar (["Basis"], "sql_subset", Infer), loc),
adamc@233 1343 sel), loc)),
adamc@233 1344 ((CName "SelectExps", loc),
adamc@233 1345 (ERecord exps, loc))], loc)
adamc@223 1346
adamc@209 1347 val e = (EApp (e, re), loc)
adamc@204 1348 in
adamc@207 1349 e
adamc@204 1350 end)
adamc@229 1351 | query1 UNION query1 (sql_relop ("union", query11, query12, s (query11left, query12right)))
adamc@229 1352 | query1 INTERSECT query1 (sql_relop ("intersect", query11, query12, s (query11left, query12right)))
adamc@229 1353 | query1 EXCEPT query1 (sql_relop ("except", query11, query12, s (query11left, query12right)))
adamc@204 1354
adamc@204 1355 tables : table ([table])
adamc@204 1356 | table COMMA tables (table :: tables)
adamc@204 1357
adamc@204 1358 tname : CSYMBOL (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright))
adamc@204 1359 | LBRACE cexp RBRACE (cexp)
adamc@204 1360
adamc@243 1361 table : SYMBOL ((CName (capitalize SYMBOL), s (SYMBOLleft, SYMBOLright)),
adamc@403 1362 (EVar ([], SYMBOL, Infer), s (SYMBOLleft, SYMBOLright)))
adamc@403 1363 | SYMBOL AS tname (tname, (EVar ([], SYMBOL, Infer), s (SYMBOLleft, SYMBOLright)))
adamc@221 1364 | LBRACE LBRACE eexp RBRACE RBRACE AS tname (tname, eexp)
adamc@207 1365
adamc@243 1366 tident : SYMBOL (CName (capitalize SYMBOL), s (SYMBOLleft, SYMBOLright))
adamc@207 1367 | CSYMBOL (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright))
adamc@221 1368 | LBRACE LBRACE cexp RBRACE RBRACE (cexp)
adamc@207 1369
adamc@207 1370 fident : CSYMBOL (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright))
adamc@207 1371 | LBRACE cexp RBRACE (cexp)
adamc@207 1372
adamc@207 1373 seli : tident DOT fident (Field (tident, fident))
adamc@233 1374 | sqlexp AS fident (Exp (fident, sqlexp))
adamc@341 1375 | tident DOT LBRACE LBRACE cexp RBRACE RBRACE (Fields (tident, cexp))
adamc@207 1376
adamc@207 1377 selis : seli ([seli])
adamc@207 1378 | seli COMMA selis (seli :: selis)
adamc@207 1379
adamc@207 1380 select : STAR (Star)
adamc@207 1381 | selis (Items selis)
adamc@209 1382
adamc@403 1383 sqlexp : TRUE (sql_inject (EVar (["Basis"], "True", Infer),
adamc@209 1384 s (TRUEleft, TRUEright)))
adamc@403 1385 | FALSE (sql_inject (EVar (["Basis"], "False", Infer),
adamc@209 1386 s (FALSEleft, FALSEright)))
adamc@209 1387
adamc@222 1388 | INT (sql_inject (EPrim (Prim.Int INT),
adamc@222 1389 s (INTleft, INTright)))
adamc@222 1390 | FLOAT (sql_inject (EPrim (Prim.Float FLOAT),
adamc@222 1391 s (FLOATleft, FLOATright)))
adamc@229 1392 | STRING (sql_inject (EPrim (Prim.String STRING),
adamc@229 1393 s (STRINGleft, STRINGright)))
adamc@441 1394 | CURRENT_TIMESTAMP (sql_nfunc ("current_timestamp",
adamc@441 1395 s (CURRENT_TIMESTAMPleft, CURRENT_TIMESTAMPright)))
adamc@222 1396
adamc@221 1397 | tident DOT fident (let
adamc@221 1398 val loc = s (tidentleft, fidentright)
adamc@403 1399 val e = (EVar (["Basis"], "sql_field", Infer), loc)
adamc@221 1400 val e = (ECApp (e, tident), loc)
adamc@221 1401 in
adamc@221 1402 (ECApp (e, fident), loc)
adamc@221 1403 end)
adamc@234 1404 | CSYMBOL (let
adamc@234 1405 val loc = s (CSYMBOLleft, CSYMBOLright)
adamc@310 1406 in
adamc@310 1407 if !inDml then
adamc@310 1408 let
adamc@403 1409 val e = (EVar (["Basis"], "sql_field", Infer), loc)
adamc@310 1410 val e = (ECApp (e, (CName "T", loc)), loc)
adamc@310 1411 in
adamc@310 1412 (ECApp (e, (CName CSYMBOL, loc)), loc)
adamc@310 1413 end
adamc@310 1414 else
adamc@310 1415 let
adamc@403 1416 val e = (EVar (["Basis"], "sql_exp", Infer), loc)
adamc@310 1417 in
adamc@310 1418 (ECApp (e, (CName CSYMBOL, loc)), loc)
adamc@310 1419 end
adamc@310 1420 end)
adamc@221 1421
adamc@471 1422 | LBRACE eexp RBRACE (eexp)
adamc@470 1423
adamc@559 1424 | sqlexp EQ sqlexp (sql_binary ("eq", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
adamc@559 1425 | sqlexp NE sqlexp (sql_binary ("ne", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
adamc@559 1426 | sqlexp LT sqlexp (sql_binary ("lt", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
adamc@559 1427 | sqlexp LE sqlexp (sql_binary ("le", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
adamc@559 1428 | sqlexp GT sqlexp (sql_binary ("gt", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
adamc@559 1429 | sqlexp GE sqlexp (sql_binary ("ge", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
adamc@559 1430
adamc@559 1431 | sqlexp PLUS sqlexp (sql_binary ("plus", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
adamc@559 1432 | sqlexp MINUS sqlexp (sql_binary ("minus", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
adamc@559 1433 | sqlexp STAR sqlexp (sql_binary ("times", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
adamc@559 1434 | sqlexp DIVIDE sqlexp (sql_binary ("div", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
adamc@559 1435 | sqlexp MOD sqlexp (sql_binary ("mod", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
adamc@219 1436
adamc@220 1437 | sqlexp CAND sqlexp (sql_binary ("and", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
adamc@220 1438 | sqlexp OR sqlexp (sql_binary ("or", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
adamc@559 1439
adamc@220 1440 | NOT sqlexp (sql_unary ("not", sqlexp, s (NOTleft, sqlexpright)))
adamc@559 1441 | MINUS sqlexp (sql_unary ("neg", sqlexp, s (MINUSleft, sqlexpright)))
adamc@220 1442
adamc@470 1443 | sqlexp IS NULL (let
adamc@470 1444 val loc = s (sqlexpleft, NULLright)
adamc@470 1445 in
adamc@470 1446 (EApp ((EVar (["Basis"], "sql_is_null", Infer), loc),
adamc@470 1447 sqlexp), loc)
adamc@470 1448 end)
adamc@470 1449
adamc@471 1450 | LBRACE LBRACK eexp RBRACK RBRACE (sql_inject (#1 eexp,
adamc@471 1451 s (LBRACEleft, RBRACEright)))
adamc@220 1452 | LPAREN sqlexp RPAREN (sqlexp)
adamc@210 1453
adamc@467 1454 | NULL (sql_inject ((EVar (["Basis"], "None", Infer),
adamc@467 1455 s (NULLleft, NULLright))))
adamc@467 1456
adamc@235 1457 | COUNT LPAREN STAR RPAREN (let
adamc@235 1458 val loc = s (COUNTleft, RPARENright)
adamc@235 1459 in
adamc@544 1460 (EVar (["Basis"], "sql_count", Infer), loc)
adamc@235 1461 end)
adamc@236 1462 | sqlagg LPAREN sqlexp RPAREN (let
adamc@236 1463 val loc = s (sqlaggleft, RPARENright)
adamc@236 1464
adamc@403 1465 val e = (EVar (["Basis"], "sql_" ^ sqlagg, Infer), loc)
adamc@403 1466 val e = (EApp ((EVar (["Basis"], "sql_aggregate", Infer), loc),
adamc@236 1467 e), loc)
adamc@236 1468 in
adamc@236 1469 (EApp (e, sqlexp), loc)
adamc@236 1470 end)
adamc@235 1471
adamc@403 1472 wopt : (sql_inject (EVar (["Basis"], "True", Infer),
adamc@230 1473 dummy))
adamc@209 1474 | CWHERE sqlexp (sqlexp)
adamc@226 1475
adamc@226 1476 groupi : tident DOT fident (GField (tident, fident))
adamc@226 1477
adamc@226 1478 groupis: groupi ([groupi])
adamc@226 1479 | groupi COMMA groupis (groupi :: groupis)
adamc@226 1480
adamc@226 1481 gopt : (NONE)
adamc@226 1482 | GROUP BY groupis (SOME groupis)
adamc@227 1483
adamc@403 1484 hopt : (sql_inject (EVar (["Basis"], "True", Infer),
adamc@230 1485 dummy))
adamc@227 1486 | HAVING sqlexp (sqlexp)
adamc@230 1487
adamc@403 1488 obopt : (ECApp ((EVar (["Basis"], "sql_order_by_Nil", Infer), dummy),
adamc@234 1489 (CWild (KRecord (KType, dummy), dummy), dummy)),
adamc@230 1490 dummy)
adamc@230 1491 | ORDER BY obexps (obexps)
adamc@230 1492
adamc@268 1493 obitem : sqlexp diropt (sqlexp, diropt)
adamc@268 1494
adamc@268 1495 obexps : obitem (let
adamc@268 1496 val loc = s (obitemleft, obitemright)
adamc@230 1497
adamc@403 1498 val e' = (ECApp ((EVar (["Basis"], "sql_order_by_Nil", Infer), loc),
adamc@234 1499 (CWild (KRecord (KType, loc), loc), loc)),
adamc@230 1500 loc)
adamc@403 1501 val e = (EApp ((EVar (["Basis"], "sql_order_by_Cons", Infer), loc),
adamc@268 1502 #1 obitem), loc)
adamc@268 1503 val e = (EApp (e, #2 obitem), loc)
adamc@230 1504 in
adamc@230 1505 (EApp (e, e'), loc)
adamc@230 1506 end)
adamc@268 1507 | obitem COMMA obexps (let
adamc@268 1508 val loc = s (obitemleft, obexpsright)
adamc@230 1509
adamc@403 1510 val e = (EApp ((EVar (["Basis"], "sql_order_by_Cons", Infer), loc),
adamc@268 1511 #1 obitem), loc)
adamc@268 1512 val e = (EApp (e, #2 obitem), loc)
adamc@230 1513 in
adamc@230 1514 (EApp (e, obexps), loc)
adamc@230 1515 end)
adamc@231 1516
adamc@403 1517 diropt : (EVar (["Basis"], "sql_asc", Infer), dummy)
adamc@403 1518 | ASC (EVar (["Basis"], "sql_asc", Infer), s (ASCleft, ASCright))
adamc@403 1519 | DESC (EVar (["Basis"], "sql_desc", Infer), s (DESCleft, DESCright))
adamc@268 1520
adamc@403 1521 lopt : (EVar (["Basis"], "sql_no_limit", Infer), dummy)
adamc@403 1522 | LIMIT ALL (EVar (["Basis"], "sql_no_limit", Infer), dummy)
adamc@231 1523 | LIMIT sqlint (let
adamc@231 1524 val loc = s (LIMITleft, sqlintright)
adamc@231 1525 in
adamc@403 1526 (EApp ((EVar (["Basis"], "sql_limit", Infer), loc), sqlint), loc)
adamc@231 1527 end)
adamc@231 1528
adamc@403 1529 ofopt : (EVar (["Basis"], "sql_no_offset", Infer), dummy)
adamc@232 1530 | OFFSET sqlint (let
adamc@232 1531 val loc = s (OFFSETleft, sqlintright)
adamc@232 1532 in
adamc@403 1533 (EApp ((EVar (["Basis"], "sql_offset", Infer), loc), sqlint), loc)
adamc@232 1534 end)
adamc@232 1535
adamc@231 1536 sqlint : INT (EPrim (Prim.Int INT), s (INTleft, INTright))
adamc@231 1537 | LBRACE eexp RBRACE (eexp)
adamc@236 1538
adamc@236 1539 sqlagg : AVG ("avg")
adamc@236 1540 | SUM ("sum")
adamc@236 1541 | MIN ("min")
adamc@236 1542 | MAX ("max")