Mercurial > urweb

annotate src/urweb.grm @ 1076:dcf98ae3c48d

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