Mercurial > urweb

annotate src/urweb.grm @ 1424:7f6ac9f33d4d

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