Mercurial > urweb

annotate src/urweb.grm @ 305:55eedecb6c50

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Remove need to mention table name in expressions for UPDATE and DELETE
author Adam Chlipala <adamc@hcoop.net>
date Sun, 07 Sep 2008 14:30:32 -0400
parents 148ba06f3e67
children 99e4f39e820d
rev   line source
adamc@1 1 (* Copyright (c) 2008, 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@1 15 * THIS SOFTWARE 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@207 46
adamc@207 47 datatype select =
adamc@207 48 Star
adamc@207 49 | Items of select_item list
adamc@207 50
adamc@226 51 datatype group_item =
adamc@226 52 GField of con * con
adamc@226 53
adamc@207 54 fun eqTnames ((c1, _), (c2, _)) =
adamc@207 55 case (c1, c2) of
adamc@207 56 (CVar (ms1, x1), CVar (ms2, x2)) => ms1 = ms2 andalso x1 = x2
adamc@207 57 | (CName x1, CName x2) => x1 = x2
adamc@207 58 | _ => false
adamc@207 59
adamc@233 60 fun amend_select loc (si, (tabs, exps)) =
adamc@233 61 case si of
adamc@233 62 Field (tx, fx) =>
adamc@233 63 let
adamc@233 64 val c = (CRecord ([(fx, (CWild (KType, loc), loc))]), loc)
adamc@207 65
adamc@233 66 val (tabs, found) = ListUtil.foldlMap (fn ((tx', c'), found) =>
adamc@233 67 if eqTnames (tx, tx') then
adamc@233 68 ((tx', (CConcat (c, c'), loc)), true)
adamc@233 69 else
adamc@233 70 ((tx', c'), found))
adamc@233 71 false tabs
adamc@233 72 in
adamc@233 73 if found then
adamc@233 74 ()
adamc@233 75 else
adamc@233 76 ErrorMsg.errorAt loc "Select of field from unbound table";
adamc@233 77
adamc@233 78 (tabs, exps)
adamc@233 79 end
adamc@233 80 | Exp (c, e) => (tabs, (c, e) :: exps)
adamc@207 81
adamc@226 82 fun amend_group loc (gi, tabs) =
adamc@226 83 let
adamc@226 84 val (tx, c) = case gi of
adamc@226 85 GField (tx, fx) => (tx, (CRecord ([(fx, (CWild (KType, loc), loc))]), loc))
adamc@226 86
adamc@226 87 val (tabs, found) = ListUtil.foldlMap (fn ((tx', c'), found) =>
adamc@226 88 if eqTnames (tx, tx') then
adamc@226 89 ((tx', (CConcat (c, c'), loc)), true)
adamc@226 90 else
adamc@226 91 ((tx', c'), found))
adamc@226 92 false tabs
adamc@226 93 in
adamc@226 94 if found then
adamc@226 95 ()
adamc@226 96 else
adamc@226 97 ErrorMsg.errorAt loc "Select of field from unbound table";
adamc@226 98
adamc@226 99 tabs
adamc@226 100 end
adamc@226 101
adamc@209 102 fun sql_inject (v, t, loc) =
adamc@209 103 let
adamc@234 104 val e = (EApp ((EVar (["Basis"], "sql_inject"), loc), (t, loc)), loc)
adamc@209 105 in
adamc@234 106 (EApp (e, (v, loc)), loc)
adamc@209 107 end
adamc@209 108
adamc@219 109 fun sql_compare (oper, sqlexp1, sqlexp2, loc) =
adamc@219 110 let
adamc@219 111 val e = (EVar (["Basis"], "sql_comparison"), loc)
adamc@219 112 val e = (EApp (e, (EVar (["Basis"], "sql_" ^ oper), loc)), loc)
adamc@219 113 val e = (EApp (e, sqlexp1), loc)
adamc@219 114 in
adamc@234 115 (EApp (e, sqlexp2), loc)
adamc@220 116 end
adamc@220 117
adamc@220 118 fun sql_binary (oper, sqlexp1, sqlexp2, loc) =
adamc@220 119 let
adamc@220 120 val e = (EVar (["Basis"], "sql_binary"), loc)
adamc@220 121 val e = (EApp (e, (EVar (["Basis"], "sql_" ^ oper), loc)), loc)
adamc@220 122 val e = (EApp (e, sqlexp1), loc)
adamc@220 123 in
adamc@220 124 (EApp (e, sqlexp2), loc)
adamc@220 125 end
adamc@220 126
adamc@220 127 fun sql_unary (oper, sqlexp, loc) =
adamc@220 128 let
adamc@220 129 val e = (EVar (["Basis"], "sql_unary"), loc)
adamc@220 130 val e = (EApp (e, (EVar (["Basis"], "sql_" ^ oper), loc)), loc)
adamc@220 131 in
adamc@220 132 (EApp (e, sqlexp), loc)
adamc@219 133 end
adamc@219 134
adamc@229 135 fun sql_relop (oper, sqlexp1, sqlexp2, loc) =
adamc@229 136 let
adamc@229 137 val e = (EVar (["Basis"], "sql_relop"), loc)
adamc@229 138 val e = (EApp (e, (EVar (["Basis"], "sql_" ^ oper), loc)), loc)
adamc@229 139 val e = (EApp (e, sqlexp1), loc)
adamc@229 140 in
adamc@229 141 (EApp (e, sqlexp2), loc)
adamc@229 142 end
adamc@229 143
adamc@256 144 fun native_op (oper, e1, e2, loc) =
adamc@256 145 let
adamc@256 146 val e = (EVar (["Basis"], oper), loc)
adamc@256 147 val e = (EApp (e, (EWild, loc)), loc)
adamc@256 148 val e = (EApp (e, e1), loc)
adamc@256 149 in
adamc@256 150 (EApp (e, e2), loc)
adamc@256 151 end
adamc@256 152
adamc@1 153 %%
adamc@244 154 %header (functor UrwebLrValsFn(structure Token : TOKEN))
adamc@1 155
adamc@1 156 %term
adamc@1 157 EOF
adamc@14 158 | STRING of string | INT of Int64.int | FLOAT of Real64.real
adamc@1 159 | SYMBOL of string | CSYMBOL of string
adamc@1 160 | LPAREN | RPAREN | LBRACK | RBRACK | LBRACE | RBRACE
adamc@156 161 | EQ | COMMA | COLON | DCOLON | TCOLON | DOT | HASH | UNDER | UNDERUNDER | BAR
adamc@219 162 | DIVIDE | DOTDOTDOT
adamc@242 163 | CON | LTYPE | VAL | REC | AND | FUN | FOLD | UNIT | KUNIT | CLASS
adamc@156 164 | DATATYPE | OF
adamc@7 165 | TYPE | NAME
adamc@243 166 | ARROW | LARROW | DARROW | STAR | SEMI
adamc@149 167 | FN | PLUSPLUS | MINUSMINUS | DOLLAR | TWIDDLE
adamc@88 168 | STRUCTURE | SIGNATURE | STRUCT | SIG | END | FUNCTOR | WHERE | EXTERN
adamc@203 169 | INCLUDE | OPEN | CONSTRAINT | CONSTRAINTS | EXPORT | TABLE
adamc@190 170 | CASE | IF | THEN | ELSE
adamc@1 171
adamc@91 172 | XML_BEGIN of string | XML_END
adamc@91 173 | NOTAGS of string
adamc@91 174 | BEGIN_TAG of string | END_TAG of string
adamc@91 175
adamc@230 176 | SELECT | FROM | AS | CWHERE | GROUP | ORDER | BY | HAVING
adamc@229 177 | UNION | INTERSECT | EXCEPT
adamc@232 178 | LIMIT | OFFSET | ALL
adamc@220 179 | TRUE | FALSE | CAND | OR | NOT
adamc@236 180 | COUNT | AVG | SUM | MIN | MAX
adamc@268 181 | ASC | DESC
adamc@302 182 | INSERT | INTO | VALUES | UPDATE | SET | DELETE
adamc@219 183 | NE | LT | LE | GT | GE
adamc@204 184
adamc@30 185 %nonterm
adamc@1 186 file of decl list
adamc@1 187 | decls of decl list
adamc@1 188 | decl of decl
adamc@123 189 | vali of string * con option * exp
adamc@123 190 | valis of (string * con option * exp) list
adamc@242 191 | copt of con option
adamc@1 192
adamc@191 193 | dargs of string list
adamc@156 194 | barOpt of unit
adamc@156 195 | dcons of (string * con option) list
adamc@156 196 | dcon of string * con option
adamc@156 197
adamc@30 198 | sgn of sgn
adamc@42 199 | sgntm of sgn
adamc@30 200 | sgi of sgn_item
adamc@30 201 | sgis of sgn_item list
adamc@30 202
adamc@30 203 | str of str
adamc@30 204
adamc@1 205 | kind of kind
adamc@207 206 | ktuple of kind list
adamc@1 207 | kcolon of explicitness
adamc@240 208 | kopt of kind option
adamc@1 209
adamc@34 210 | path of string list * string
adamc@156 211 | cpath of string list * string
adamc@34 212 | spath of str
adamc@59 213 | mpath of string list
adamc@34 214
adamc@1 215 | cexp of con
adamc@1 216 | capps of con
adamc@1 217 | cterm of con
adamc@195 218 | ctuple of con list
adamc@207 219 | ctuplev of con list
adamc@1 220 | ident of con
adamc@200 221 | idents of con list
adamc@1 222 | rcon of (con * con) list
adamc@83 223 | rconn of (con * con) list
adamc@1 224 | rcone of (con * con) list
adamc@239 225 | cargs of con * kind -> con * kind
adamc@239 226 | cargl of con * kind -> con * kind
adamc@240 227 | cargl2 of con * kind -> con * kind
adamc@239 228 | carg of con * kind -> con * kind
adamc@239 229 | cargp of con * kind -> con * kind
adamc@1 230
adamc@8 231 | eexp of exp
adamc@8 232 | eapps of exp
adamc@8 233 | eterm of exp
adamc@195 234 | etuple of exp list
adamc@12 235 | rexp of (con * exp) list
adamc@91 236 | xml of exp
adamc@91 237 | xmlOne of exp
adamc@141 238 | tag of string * exp
adamc@141 239 | tagHead of string * exp
adamc@8 240
adamc@241 241 | earg of exp * con -> exp * con
adamc@241 242 | eargp of exp * con -> exp * con
adamc@241 243 | eargs of exp * con -> exp * con
adamc@241 244 | eargl of exp * con -> exp * con
adamc@242 245 | eargl2 of exp * con -> exp * con
adamc@241 246
adamc@170 247 | branch of pat * exp
adamc@170 248 | branchs of (pat * exp) list
adamc@170 249 | pat of pat
adamc@170 250 | pterm of pat
adamc@174 251 | rpat of (string * pat) list * bool
adamc@195 252 | ptuple of pat list
adamc@170 253
adamc@104 254 | attrs of (con * exp) list
adamc@104 255 | attr of con * exp
adamc@104 256 | attrv of exp
adamc@104 257
adamc@204 258 | query of exp
adamc@226 259 | query1 of exp
adamc@204 260 | tables of (con * exp) list
adamc@204 261 | tname of con
adamc@204 262 | table of con * exp
adamc@207 263 | tident of con
adamc@207 264 | fident of con
adamc@207 265 | seli of select_item
adamc@207 266 | selis of select_item list
adamc@207 267 | select of select
adamc@209 268 | sqlexp of exp
adamc@209 269 | wopt of exp
adamc@226 270 | groupi of group_item
adamc@226 271 | groupis of group_item list
adamc@226 272 | gopt of group_item list option
adamc@227 273 | hopt of exp
adamc@230 274 | obopt of exp
adamc@268 275 | obitem of exp * exp
adamc@230 276 | obexps of exp
adamc@268 277 | diropt of exp
adamc@231 278 | lopt of exp
adamc@232 279 | ofopt of exp
adamc@231 280 | sqlint of exp
adamc@236 281 | sqlagg of string
adamc@207 282
adamc@302 283 | texp of exp
adamc@302 284 | fields of con list
adamc@302 285 | sqlexps of exp list
adamc@303 286 | fsets of (con * exp) list
adamc@302 287
adamc@204 288
adamc@1 289 %verbose (* print summary of errors *)
adamc@1 290 %pos int (* positions *)
adamc@1 291 %start file
adamc@1 292 %pure
adamc@1 293 %eop EOF
adamc@1 294 %noshift EOF
adamc@1 295
adamc@244 296 %name Urweb
adamc@1 297
adamc@243 298 %right SEMI
adamc@243 299 %nonassoc LARROW
adamc@195 300 %nonassoc IF THEN ELSE
adamc@1 301 %nonassoc DARROW
adamc@1 302 %nonassoc COLON
adamc@6 303 %nonassoc DCOLON TCOLON
adamc@229 304 %left UNION INTERSECT EXCEPT
adamc@1 305 %right COMMA
adamc@220 306 %right OR
adamc@220 307 %right CAND
adamc@219 308 %nonassoc EQ NE LT LE GT GE
adamc@243 309 %right ARROW
adamc@149 310 %right PLUSPLUS MINUSMINUS
adamc@195 311 %right STAR
adamc@220 312 %left NOT
adamc@84 313 %nonassoc TWIDDLE
adamc@1 314 %nonassoc DOLLAR
adamc@1 315 %left DOT
adamc@221 316 %nonassoc LBRACE RBRACE
adamc@1 317
adamc@1 318 %%
adamc@1 319
adamc@1 320 file : decls (decls)
adamc@54 321 | SIG sgis ([(DSgn ("?", (SgnConst sgis, s (SIGleft, sgisright))),
adamc@54 322 s (SIGleft, sgisright))])
adamc@1 323
adamc@1 324 decls : ([])
adamc@1 325 | decl decls (decl :: decls)
adamc@1 326
adamc@240 327 decl : CON SYMBOL cargl2 kopt EQ cexp (let
adamc@240 328 val loc = s (CONleft, cexpright)
adamc@240 329
adamc@240 330 val k = Option.getOpt (kopt, (KWild, loc))
adamc@240 331 val (c, k) = cargl2 (cexp, k)
adamc@240 332 in
adamc@240 333 (DCon (SYMBOL, SOME k, c), loc)
adamc@240 334 end)
adamc@7 335 | LTYPE SYMBOL EQ cexp (DCon (SYMBOL, SOME (KType, s (LTYPEleft, cexpright)), cexp),
adamc@7 336 s (LTYPEleft, cexpright))
adamc@191 337 | DATATYPE SYMBOL dargs EQ barOpt dcons(DDatatype (SYMBOL, dargs, dcons), s (DATATYPEleft, dconsright))
adamc@191 338 | DATATYPE SYMBOL dargs EQ DATATYPE CSYMBOL DOT path
adamc@191 339 (case dargs of
adamc@191 340 [] => (DDatatypeImp (SYMBOL, CSYMBOL :: #1 path, #2 path), s (DATATYPEleft, pathright))
adamc@191 341 | _ => raise Fail "Arguments specified for imported datatype")
adamc@123 342 | VAL vali (DVal vali, s (VALleft, valiright))
adamc@123 343 | VAL REC valis (DValRec valis, s (VALleft, valisright))
adamc@242 344 | FUN valis (DValRec valis, s (FUNleft, valisright))
adamc@1 345
adamc@30 346 | SIGNATURE CSYMBOL EQ sgn (DSgn (CSYMBOL, sgn), s (SIGNATUREleft, sgnright))
adamc@30 347 | STRUCTURE CSYMBOL EQ str (DStr (CSYMBOL, NONE, str), s (STRUCTUREleft, strright))
adamc@30 348 | STRUCTURE CSYMBOL COLON sgn EQ str (DStr (CSYMBOL, SOME sgn, str), s (STRUCTUREleft, strright))
adamc@42 349 | FUNCTOR CSYMBOL LPAREN CSYMBOL COLON sgn RPAREN EQ str
adamc@42 350 (DStr (CSYMBOL1, NONE,
adamc@42 351 (StrFun (CSYMBOL2, sgn1, NONE, str), s (FUNCTORleft, strright))),
adamc@42 352 s (FUNCTORleft, strright))
adamc@42 353 | FUNCTOR CSYMBOL LPAREN CSYMBOL COLON sgn RPAREN COLON sgn EQ str
adamc@42 354 (DStr (CSYMBOL1, NONE,
adamc@42 355 (StrFun (CSYMBOL2, sgn1, SOME sgn2, str), s (FUNCTORleft, strright))),
adamc@42 356 s (FUNCTORleft, strright))
adamc@48 357 | EXTERN STRUCTURE CSYMBOL COLON sgn (DFfiStr (CSYMBOL, sgn), s (EXTERNleft, sgnright))
adamc@61 358 | OPEN mpath (case mpath of
adamc@61 359 [] => raise Fail "Impossible mpath parse [1]"
adamc@61 360 | m :: ms => (DOpen (m, ms), s (OPENleft, mpathright)))
adamc@88 361 | OPEN CONSTRAINTS mpath (case mpath of
adamc@88 362 [] => raise Fail "Impossible mpath parse [3]"
adamc@88 363 | m :: ms => (DOpenConstraints (m, ms), s (OPENleft, mpathright)))
adamc@88 364 | CONSTRAINT cterm TWIDDLE cterm (DConstraint (cterm1, cterm2), s (CONSTRAINTleft, ctermright))
adamc@109 365 | EXPORT spath (DExport spath, s (EXPORTleft, spathright))
adamc@203 366 | TABLE SYMBOL COLON cexp (DTable (SYMBOL, entable cexp), s (TABLEleft, cexpright))
adamc@211 367 | CLASS SYMBOL EQ cexp (DClass (SYMBOL, cexp), s (CLASSleft, cexpright))
adamc@211 368 | CLASS SYMBOL SYMBOL EQ cexp (let
adamc@211 369 val loc = s (CLASSleft, cexpright)
adamc@211 370 val k = (KType, loc)
adamc@211 371 val c = (CAbs (SYMBOL2, SOME k, cexp), loc)
adamc@211 372 in
adamc@211 373 (DClass (SYMBOL1, c), s (CLASSleft, cexpright))
adamc@211 374 end)
adamc@30 375
adamc@240 376 kopt : (NONE)
adamc@240 377 | DCOLON kind (SOME kind)
adamc@240 378
adamc@191 379 dargs : ([])
adamc@191 380 | SYMBOL dargs (SYMBOL :: dargs)
adamc@191 381
adamc@156 382 barOpt : ()
adamc@156 383 | BAR ()
adamc@156 384
adamc@156 385 dcons : dcon ([dcon])
adamc@156 386 | dcon BAR dcons (dcon :: dcons)
adamc@156 387
adamc@156 388 dcon : CSYMBOL (CSYMBOL, NONE)
adamc@156 389 | CSYMBOL OF cexp (CSYMBOL, SOME cexp)
adamc@156 390
adamc@242 391 vali : SYMBOL eargl2 copt EQ eexp (let
adamc@242 392 val loc = s (SYMBOLleft, eexpright)
adamc@242 393 val t = Option.getOpt (copt, (CWild (KType, loc), loc))
adamc@242 394
adamc@242 395 val (e, t) = eargl2 (eexp, t)
adamc@242 396 in
adamc@242 397 (SYMBOL, SOME t, e)
adamc@242 398 end)
adamc@242 399
adamc@242 400 copt : (NONE)
adamc@242 401 | COLON cexp (SOME cexp)
adamc@123 402
adamc@123 403 valis : vali ([vali])
adamc@123 404 | vali AND valis (vali :: valis)
adamc@123 405
adamc@42 406 sgn : sgntm (sgntm)
adamc@40 407 | FUNCTOR LPAREN CSYMBOL COLON sgn RPAREN COLON sgn
adamc@40 408 (SgnFun (CSYMBOL, sgn1, sgn2), s (FUNCTORleft, sgn2right))
adamc@30 409
adamc@42 410 sgntm : SIG sgis END (SgnConst sgis, s (SIGleft, ENDright))
adamc@59 411 | mpath (case mpath of
adamc@61 412 [] => raise Fail "Impossible mpath parse [2]"
adamc@59 413 | [x] => SgnVar x
adamc@59 414 | m :: ms => SgnProj (m,
adamc@59 415 List.take (ms, length ms - 1),
adamc@59 416 List.nth (ms, length ms - 1)),
adamc@59 417 s (mpathleft, mpathright))
adamc@42 418 | sgntm WHERE CON SYMBOL EQ cexp (SgnWhere (sgntm, SYMBOL, cexp), s (sgntmleft, cexpright))
adamc@42 419 | sgntm WHERE LTYPE SYMBOL EQ cexp(SgnWhere (sgntm, SYMBOL, cexp), s (sgntmleft, cexpright))
adamc@42 420 | LPAREN sgn RPAREN (sgn)
adamc@42 421
adamc@30 422 sgi : CON SYMBOL DCOLON kind (SgiConAbs (SYMBOL, kind), s (CONleft, kindright))
adamc@30 423 | LTYPE SYMBOL (SgiConAbs (SYMBOL, (KType, s (LTYPEleft, SYMBOLright))),
adamc@30 424 s (LTYPEleft, SYMBOLright))
adamc@30 425 | CON SYMBOL EQ cexp (SgiCon (SYMBOL, NONE, cexp), s (CONleft, cexpright))
adamc@30 426 | CON SYMBOL DCOLON kind EQ cexp (SgiCon (SYMBOL, SOME kind, cexp), s (CONleft, cexpright))
adamc@30 427 | LTYPE SYMBOL EQ cexp (SgiCon (SYMBOL, SOME (KType, s (LTYPEleft, cexpright)), cexp),
adamc@30 428 s (LTYPEleft, cexpright))
adamc@191 429 | DATATYPE SYMBOL dargs EQ barOpt dcons(SgiDatatype (SYMBOL, dargs, dcons), s (DATATYPEleft, dconsright))
adamc@191 430 | DATATYPE SYMBOL dargs EQ DATATYPE CSYMBOL DOT path
adamc@191 431 (case dargs of
adamc@191 432 [] => (SgiDatatypeImp (SYMBOL, CSYMBOL :: #1 path, #2 path), s (DATATYPEleft, pathright))
adamc@191 433 | _ => raise Fail "Arguments specified for imported datatype")
adamc@30 434 | VAL SYMBOL COLON cexp (SgiVal (SYMBOL, cexp), s (VALleft, cexpright))
adamc@30 435
adamc@30 436 | STRUCTURE CSYMBOL COLON sgn (SgiStr (CSYMBOL, sgn), s (STRUCTUREleft, sgnright))
adamc@59 437 | SIGNATURE CSYMBOL EQ sgn (SgiSgn (CSYMBOL, sgn), s (SIGNATUREleft, sgnright))
adamc@42 438 | FUNCTOR CSYMBOL LPAREN CSYMBOL COLON sgn RPAREN COLON sgn
adamc@42 439 (SgiStr (CSYMBOL1,
adamc@42 440 (SgnFun (CSYMBOL2, sgn1, sgn2), s (FUNCTORleft, sgn2right))),
adamc@42 441 s (FUNCTORleft, sgn2right))
adamc@58 442 | INCLUDE sgn (SgiInclude sgn, s (INCLUDEleft, sgnright))
adamc@88 443 | CONSTRAINT cterm TWIDDLE cterm (SgiConstraint (cterm1, cterm2), s (CONSTRAINTleft, ctermright))
adamc@203 444 | TABLE SYMBOL COLON cexp (SgiTable (SYMBOL, entable cexp), s (TABLEleft, cexpright))
adamc@211 445 | CLASS SYMBOL (SgiClassAbs SYMBOL, s (CLASSleft, SYMBOLright))
adamc@211 446 | CLASS SYMBOL EQ cexp (SgiClass (SYMBOL, cexp), s (CLASSleft, cexpright))
adamc@211 447 | CLASS SYMBOL SYMBOL EQ cexp (let
adamc@211 448 val loc = s (CLASSleft, cexpright)
adamc@211 449 val k = (KType, loc)
adamc@211 450 val c = (CAbs (SYMBOL2, SOME k, cexp), loc)
adamc@211 451 in
adamc@211 452 (SgiClass (SYMBOL1, c), s (CLASSleft, cexpright))
adamc@211 453 end)
adamc@30 454
adamc@30 455 sgis : ([])
adamc@30 456 | sgi sgis (sgi :: sgis)
adamc@30 457
adamc@30 458 str : STRUCT decls END (StrConst decls, s (STRUCTleft, ENDright))
adamc@34 459 | spath (spath)
adamc@40 460 | FUNCTOR LPAREN CSYMBOL COLON sgn RPAREN DARROW str
adamc@40 461 (StrFun (CSYMBOL, sgn, NONE, str), s (FUNCTORleft, strright))
adamc@40 462 | FUNCTOR LPAREN CSYMBOL COLON sgn RPAREN COLON sgn DARROW str
adamc@40 463 (StrFun (CSYMBOL, sgn1, SOME sgn2, str), s (FUNCTORleft, strright))
adamc@44 464 | spath LPAREN str RPAREN (StrApp (spath, str), s (spathleft, RPARENright))
adamc@34 465
adamc@34 466 spath : CSYMBOL (StrVar CSYMBOL, s (CSYMBOLleft, CSYMBOLright))
adamc@34 467 | spath DOT CSYMBOL (StrProj (spath, CSYMBOL), s (spathleft, CSYMBOLright))
adamc@30 468
adamc@1 469 kind : TYPE (KType, s (TYPEleft, TYPEright))
adamc@1 470 | NAME (KName, s (NAMEleft, NAMEright))
adamc@1 471 | LBRACE kind RBRACE (KRecord kind, s (LBRACEleft, RBRACEright))
adamc@1 472 | kind ARROW kind (KArrow (kind1, kind2), s (kind1left, kind2right))
adamc@1 473 | LPAREN kind RPAREN (#1 kind, s (LPARENleft, RPARENright))
adamc@82 474 | KUNIT (KUnit, s (KUNITleft, KUNITright))
adamc@18 475 | UNDERUNDER (KWild, s (UNDERUNDERleft, UNDERUNDERright))
adamc@207 476 | LPAREN ktuple RPAREN (KTuple ktuple, s (LPARENleft, RPARENright))
adamc@207 477
adamc@207 478 ktuple : kind STAR kind ([kind1, kind2])
adamc@207 479 | kind STAR ktuple (kind :: ktuple)
adamc@1 480
adamc@1 481 capps : cterm (cterm)
adamc@1 482 | capps cterm (CApp (capps, cterm), s (cappsleft, ctermright))
adamc@1 483
adamc@1 484 cexp : capps (capps)
adamc@1 485 | cexp ARROW cexp (TFun (cexp1, cexp2), s (cexp1left, cexp2right))
adamc@15 486 | SYMBOL kcolon kind ARROW cexp (TCFun (kcolon, SYMBOL, kind, cexp), s (SYMBOLleft, cexpright))
adamc@1 487
adamc@1 488 | cexp PLUSPLUS cexp (CConcat (cexp1, cexp2), s (cexp1left, cexp1right))
adamc@1 489
adamc@239 490 | FN cargs DARROW cexp (#1 (cargs (cexp, (KWild, s (FNleft, cexpright)))))
adamc@84 491 | cterm TWIDDLE cterm DARROW cexp(CDisjoint (cterm1, cterm2, cexp), s (cterm1left, cexpright))
adamc@85 492 | cterm TWIDDLE cterm ARROW cexp (TDisjoint (cterm1, cterm2, cexp), s (cterm1left, cexpright))
adamc@1 493
adamc@8 494 | LPAREN cexp RPAREN DCOLON kind (CAnnot (cexp, kind), s (LPARENleft, kindright))
adamc@6 495
adamc@18 496 | UNDER DCOLON kind (CWild kind, s (UNDERleft, UNDERright))
adamc@195 497 | ctuple (let
adamc@195 498 val loc = s (ctupleleft, ctupleright)
adamc@195 499 in
adamc@195 500 (TRecord (CRecord (ListUtil.mapi (fn (i, c) =>
adamc@195 501 ((CName (Int.toString (i + 1)), loc),
adamc@195 502 c)) ctuple),
adamc@195 503 loc), loc)
adamc@195 504 end)
adamc@18 505
adamc@1 506 kcolon : DCOLON (Explicit)
adamc@1 507 | TCOLON (Implicit)
adamc@1 508
adamc@239 509 cargs : carg (carg)
adamc@239 510 | cargl (cargl)
adamc@239 511
adamc@239 512 cargl : cargp cargp (cargp1 o cargp2)
adamc@239 513 | cargp cargl (cargp o cargl)
adamc@239 514
adamc@240 515 cargl2 : (fn x => x)
adamc@240 516 | cargp cargl2 (cargp o cargl2)
adamc@240 517
adamc@241 518 carg : SYMBOL DCOLON kind (fn (c, k) =>
adamc@239 519 let
adamc@239 520 val loc = s (SYMBOLleft, kindright)
adamc@239 521 in
adamc@239 522 ((CAbs (SYMBOL, SOME kind, c), loc),
adamc@239 523 (KArrow (kind, k), loc))
adamc@239 524 end)
adamc@241 525 | cargp (cargp)
adamc@239 526
adamc@239 527 cargp : SYMBOL (fn (c, k) =>
adamc@239 528 let
adamc@239 529 val loc = s (SYMBOLleft, SYMBOLright)
adamc@239 530 in
adamc@239 531 ((CAbs (SYMBOL, NONE, c), loc),
adamc@239 532 (KArrow ((KWild, loc), k), loc))
adamc@239 533 end)
adamc@239 534 | LPAREN SYMBOL DCOLON kind RPAREN (fn (c, k) =>
adamc@239 535 let
adamc@239 536 val loc = s (LPARENleft, RPARENright)
adamc@239 537 in
adamc@239 538 ((CAbs (SYMBOL, SOME kind, c), loc),
adamc@239 539 (KArrow (kind, k), loc))
adamc@239 540 end)
adamc@239 541
adamc@34 542 path : SYMBOL ([], SYMBOL)
adamc@34 543 | CSYMBOL DOT path (let val (ms, x) = path in (CSYMBOL :: ms, x) end)
adamc@34 544
adamc@156 545 cpath : CSYMBOL ([], CSYMBOL)
adamc@156 546 | CSYMBOL DOT cpath (let val (ms, x) = cpath in (CSYMBOL :: ms, x) end)
adamc@156 547
adamc@59 548 mpath : CSYMBOL ([CSYMBOL])
adamc@59 549 | CSYMBOL DOT mpath (CSYMBOL :: mpath)
adamc@59 550
adamc@1 551 cterm : LPAREN cexp RPAREN (#1 cexp, s (LPARENleft, RPARENright))
adamc@1 552 | LBRACK rcon RBRACK (CRecord rcon, s (LBRACKleft, RBRACKright))
adamc@83 553 | LBRACK rconn RBRACK (CRecord rconn, s (LBRACKleft, RBRACKright))
adamc@1 554 | LBRACE rcone RBRACE (TRecord (CRecord rcone, s (LBRACEleft, RBRACEright)),
adamc@1 555 s (LBRACEleft, RBRACEright))
adamc@1 556 | DOLLAR cterm (TRecord cterm, s (DOLLARleft, ctermright))
adamc@1 557 | HASH CSYMBOL (CName CSYMBOL, s (HASHleft, CSYMBOLright))
adamc@195 558 | HASH INT (CName (Int64.toString INT), s (HASHleft, INTright))
adamc@1 559
adamc@34 560 | path (CVar path, s (pathleft, pathright))
adamc@207 561 | path DOT INT (CProj ((CVar path, s (pathleft, pathright)), Int64.toInt INT),
adamc@207 562 s (pathleft, INTright))
adamc@18 563 | UNDER (CWild (KWild, s (UNDERleft, UNDERright)), s (UNDERleft, UNDERright))
adamc@67 564 | FOLD (CFold, s (FOLDleft, FOLDright))
adamc@82 565 | UNIT (CUnit, s (UNITleft, UNITright))
adamc@207 566 | LPAREN ctuplev RPAREN (CTuple ctuplev, s (LPARENleft, RPARENright))
adamc@207 567
adamc@207 568 ctuplev: cexp COMMA cexp ([cexp1, cexp2])
adamc@207 569 | cexp COMMA ctuplev (cexp :: ctuplev)
adamc@1 570
adamc@196 571 ctuple : capps STAR capps ([capps1, capps2])
adamc@196 572 | capps STAR ctuple (capps :: ctuple)
adamc@195 573
adamc@1 574 rcon : ([])
adamc@1 575 | ident EQ cexp ([(ident, cexp)])
adamc@1 576 | ident EQ cexp COMMA rcon ((ident, cexp) :: rcon)
adamc@1 577
adamc@83 578 rconn : ident ([(ident, (CUnit, s (identleft, identright)))])
adamc@83 579 | ident COMMA rconn ((ident, (CUnit, s (identleft, identright))) :: rconn)
adamc@83 580
adamc@1 581 rcone : ([])
adamc@1 582 | ident COLON cexp ([(ident, cexp)])
adamc@1 583 | ident COLON cexp COMMA rcone ((ident, cexp) :: rcone)
adamc@1 584
adamc@1 585 ident : CSYMBOL (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright))
adamc@195 586 | INT (CName (Int64.toString INT), s (INTleft, INTright))
adamc@200 587 | SYMBOL (CVar ([], SYMBOL), s (SYMBOLleft, SYMBOLright))
adamc@8 588
adamc@8 589 eapps : eterm (eterm)
adamc@8 590 | eapps eterm (EApp (eapps, eterm), s (eappsleft, etermright))
adamc@8 591 | eapps LBRACK cexp RBRACK (ECApp (eapps, cexp), s (eappsleft, RBRACKright))
adamc@8 592
adamc@8 593 eexp : eapps (eapps)
adamc@241 594 | FN eargs DARROW eexp (let
adamc@93 595 val loc = s (FNleft, eexpright)
adamc@93 596 in
adamc@241 597 #1 (eargs (eexp, (CWild (KType, loc), loc)))
adamc@93 598 end)
adamc@241 599 | LBRACK cterm TWIDDLE cterm RBRACK DARROW eexp(EDisjoint (cterm1, cterm2, eexp), s (LBRACKleft, RBRACKright))
adamc@196 600 | eexp COLON cexp (EAnnot (eexp, cexp), s (eexpleft, cexpright))
adamc@149 601 | eexp MINUSMINUS cexp (ECut (eexp, cexp), s (eexpleft, cexpright))
adamc@170 602 | CASE eexp OF barOpt branch branchs (ECase (eexp, branch :: branchs), s (CASEleft, branchsright))
adamc@190 603 | IF eexp THEN eexp ELSE eexp (let
adamc@190 604 val loc = s (IFleft, eexp3right)
adamc@190 605 in
adamc@190 606 (ECase (eexp1, [((PCon (["Basis"], "True", NONE), loc), eexp2),
adamc@190 607 ((PCon (["Basis"], "False", NONE), loc), eexp3)]), loc)
adamc@190 608 end)
adamc@243 609 | SYMBOL LARROW eexp SEMI eexp (let
adamc@243 610 val loc = s (SYMBOLleft, eexp2right)
adamc@243 611 val e = (EVar (["Basis"], "bind"), loc)
adamc@243 612 val e = (EApp (e, eexp1), loc)
adamc@243 613 in
adamc@243 614 (EApp (e, (EAbs (SYMBOL, NONE, eexp2), loc)), loc)
adamc@243 615 end)
adamc@299 616 | UNIT LARROW eexp SEMI eexp (let
adamc@299 617 val loc = s (UNITleft, eexp2right)
adamc@299 618 val e = (EVar (["Basis"], "bind"), loc)
adamc@299 619 val e = (EApp (e, eexp1), loc)
adamc@299 620 val t = (TRecord (CRecord [], loc), loc)
adamc@299 621 in
adamc@299 622 (EApp (e, (EAbs ("_", SOME t, eexp2), loc)), loc)
adamc@299 623 end)
adamc@256 624 | eexp EQ eexp (native_op ("eq", eexp1, eexp2, s (eexp1left, eexp2right)))
adamc@257 625 | eexp NE eexp (native_op ("ne", eexp1, eexp2, s (eexp1left, eexp2right)))
adamc@8 626
adamc@241 627 eargs : earg (earg)
adamc@241 628 | eargl (eargl)
adamc@241 629
adamc@241 630 eargl : eargp eargp (eargp1 o eargp2)
adamc@241 631 | eargp eargl (eargp o eargl)
adamc@241 632
adamc@242 633 eargl2 : (fn x => x)
adamc@242 634 | eargp eargl2 (eargp o eargl2)
adamc@242 635
adamc@241 636 earg : SYMBOL kcolon kind (fn (e, t) =>
adamc@241 637 let
adamc@241 638 val loc = s (SYMBOLleft, kindright)
adamc@241 639 in
adamc@241 640 ((ECAbs (kcolon, SYMBOL, kind, e), loc),
adamc@241 641 (TCFun (kcolon, SYMBOL, kind, t), loc))
adamc@241 642 end)
adamc@241 643 | SYMBOL COLON cexp (fn (e, t) =>
adamc@241 644 let
adamc@241 645 val loc = s (SYMBOLleft, cexpright)
adamc@241 646 in
adamc@241 647 ((EAbs (SYMBOL, SOME cexp, e), loc),
adamc@241 648 (TFun (cexp, t), loc))
adamc@241 649 end)
adamc@241 650 | UNDER COLON cexp (fn (e, t) =>
adamc@241 651 let
adamc@241 652 val loc = s (UNDERleft, cexpright)
adamc@241 653 in
adamc@241 654 ((EAbs ("_", SOME cexp, e), loc),
adamc@241 655 (TFun (cexp, t), loc))
adamc@241 656 end)
adamc@241 657 | eargp (eargp)
adamc@241 658
adamc@241 659 eargp : SYMBOL (fn (e, t) =>
adamc@241 660 let
adamc@241 661 val loc = s (SYMBOLleft, SYMBOLright)
adamc@241 662 in
adamc@241 663 ((EAbs (SYMBOL, NONE, e), loc),
adamc@241 664 (TFun ((CWild (KType, loc), loc), t), loc))
adamc@241 665 end)
adamc@241 666 | UNIT (fn (e, t) =>
adamc@241 667 let
adamc@241 668 val loc = s (UNITleft, UNITright)
adamc@241 669 val t' = (TRecord (CRecord [], loc), loc)
adamc@241 670 in
adamc@241 671 ((EAbs ("_", SOME t', e), loc),
adamc@241 672 (TFun (t', t), loc))
adamc@241 673 end)
adamc@241 674 | UNDER (fn (e, t) =>
adamc@241 675 let
adamc@241 676 val loc = s (UNDERleft, UNDERright)
adamc@241 677 in
adamc@241 678 ((EAbs ("_", NONE, e), loc),
adamc@241 679 (TFun ((CWild (KType, loc), loc), t), loc))
adamc@241 680 end)
adamc@241 681 | LPAREN SYMBOL kcolon kind RPAREN(fn (e, t) =>
adamc@241 682 let
adamc@241 683 val loc = s (LPARENleft, RPARENright)
adamc@241 684 in
adamc@241 685 ((ECAbs (kcolon, SYMBOL, kind, e), loc),
adamc@241 686 (TCFun (kcolon, SYMBOL, kind, t), loc))
adamc@241 687 end)
adamc@241 688 | LPAREN SYMBOL COLON cexp RPAREN (fn (e, t) =>
adamc@241 689 let
adamc@241 690 val loc = s (LPARENleft, RPARENright)
adamc@241 691 in
adamc@241 692 ((EAbs (SYMBOL, SOME cexp, e), loc),
adamc@241 693 (TFun (cexp, t), loc))
adamc@241 694 end)
adamc@241 695 | LPAREN UNDER COLON cexp RPAREN (fn (e, t) =>
adamc@241 696 let
adamc@241 697 val loc = s (LPARENleft, RPARENright)
adamc@241 698 in
adamc@241 699 ((EAbs ("_", SOME cexp, e), loc),
adamc@241 700 (TFun (cexp, t), loc))
adamc@241 701 end)
adamc@241 702
adamc@8 703 eterm : LPAREN eexp RPAREN (#1 eexp, s (LPARENleft, RPARENright))
adamc@195 704 | LPAREN etuple RPAREN (let
adamc@195 705 val loc = s (LPARENleft, RPARENright)
adamc@195 706 in
adamc@195 707 (ERecord (ListUtil.mapi (fn (i, e) =>
adamc@195 708 ((CName (Int.toString (i + 1)), loc),
adamc@195 709 e)) etuple), loc)
adamc@195 710 end)
adamc@8 711
adamc@34 712 | path (EVar path, s (pathleft, pathright))
adamc@156 713 | cpath (EVar cpath, s (cpathleft, cpathright))
adamc@12 714 | LBRACE rexp RBRACE (ERecord rexp, s (LBRACEleft, RBRACEright))
adamc@110 715 | UNIT (ERecord [], s (UNITleft, UNITright))
adamc@12 716
adamc@14 717 | INT (EPrim (Prim.Int INT), s (INTleft, INTright))
adamc@14 718 | FLOAT (EPrim (Prim.Float FLOAT), s (FLOATleft, FLOATright))
adamc@14 719 | STRING (EPrim (Prim.String STRING), s (STRINGleft, STRINGright))
adamc@14 720
adamc@200 721 | path DOT idents (let
adamc@200 722 val loc = s (pathleft, identsright)
adamc@200 723 in
adamc@200 724 foldl (fn (ident, e) =>
adamc@200 725 (EField (e, ident), loc))
adamc@200 726 (EVar path, s (pathleft, pathright)) idents
adamc@200 727 end)
adamc@71 728 | FOLD (EFold, s (FOLDleft, FOLDright))
adamc@71 729
adamc@91 730 | XML_BEGIN xml XML_END (xml)
adamc@91 731 | XML_BEGIN XML_END (EApp ((EVar (["Basis"], "cdata"), s (XML_BEGINleft, XML_ENDright)),
adamc@91 732 (EPrim (Prim.String ""), s (XML_BEGINleft, XML_ENDright))),
adamc@91 733 s (XML_BEGINleft, XML_ENDright))
adamc@302 734
adamc@204 735 | LPAREN query RPAREN (query)
adamc@300 736 | LPAREN CWHERE sqlexp RPAREN (sqlexp)
adamc@302 737
adamc@302 738 | LPAREN INSERT INTO texp LPAREN fields RPAREN VALUES LPAREN sqlexps RPAREN RPAREN
adamc@302 739 (let
adamc@302 740 val loc = s (LPAREN1left, RPAREN3right)
adamc@302 741
adamc@302 742 val e = (EVar (["Basis"], "insert"), loc)
adamc@302 743 val e = (EApp (e, texp), loc)
adamc@302 744 in
adamc@302 745 if length fields <> length sqlexps then
adamc@302 746 ErrorMsg.errorAt loc "Length mismatch in INSERT field specification"
adamc@302 747 else
adamc@302 748 ();
adamc@302 749 (EApp (e, (ERecord (ListPair.zip (fields, sqlexps)), loc)), loc)
adamc@302 750 end)
adamc@303 751 | LPAREN UPDATE texp SET fsets CWHERE sqlexp RPAREN
adamc@303 752 (let
adamc@303 753 val loc = s (LPARENleft, RPARENright)
adamc@303 754
adamc@303 755 val e = (EVar (["Basis"], "update"), loc)
adamc@305 756 val e = (ECApp (e, (CRecord (map (fn (nm, _) =>
adamc@305 757 (nm,
adamc@305 758 (CWild (KType, loc), loc)))
adamc@305 759 fsets), loc)), loc)
adamc@305 760 val e = (EApp (e, texp), loc)
adamc@303 761 val e = (EApp (e, (ERecord fsets, loc)), loc)
adamc@303 762 in
adamc@303 763 (EApp (e, sqlexp), loc)
adamc@303 764 end)
adamc@304 765 | LPAREN DELETE FROM texp CWHERE sqlexp RPAREN
adamc@304 766 (let
adamc@304 767 val loc = s (LPARENleft, RPARENright)
adamc@304 768
adamc@304 769 val e = (EVar (["Basis"], "delete"), loc)
adamc@304 770 val e = (EApp (e, texp), loc)
adamc@304 771 in
adamc@304 772 (EApp (e, sqlexp), loc)
adamc@304 773 end)
adamc@302 774
adamc@211 775 | UNDER (EWild, s (UNDERleft, UNDERright))
adamc@91 776
adamc@302 777 texp : SYMBOL (EVar ([], SYMBOL), s (SYMBOLleft, SYMBOLright))
adamc@302 778 | LBRACE LBRACE eexp RBRACE RBRACE (eexp)
adamc@302 779
adamc@302 780 fields : fident ([fident])
adamc@302 781 | fident COMMA fields (fident :: fields)
adamc@302 782
adamc@302 783 sqlexps: sqlexp ([sqlexp])
adamc@302 784 | sqlexp COMMA sqlexps (sqlexp :: sqlexps)
adamc@302 785
adamc@303 786 fsets : fident EQ sqlexp ([(fident, sqlexp)])
adamc@303 787 | fident EQ sqlexp COMMA fsets ((fident, sqlexp) :: fsets)
adamc@303 788
adamc@200 789 idents : ident ([ident])
adamc@200 790 | ident DOT idents (ident :: idents)
adamc@200 791
adamc@195 792 etuple : eexp COMMA eexp ([eexp1, eexp2])
adamc@195 793 | eexp COMMA etuple (eexp :: etuple)
adamc@195 794
adamc@170 795 branch : pat DARROW eexp (pat, eexp)
adamc@170 796
adamc@170 797 branchs: ([])
adamc@170 798 | BAR branch branchs (branch :: branchs)
adamc@170 799
adamc@170 800 pat : pterm (pterm)
adamc@170 801 | cpath pterm (PCon (#1 cpath, #2 cpath, SOME pterm), s (cpathleft, ptermright))
adamc@170 802
adamc@170 803 pterm : SYMBOL (PVar SYMBOL, s (SYMBOLleft, SYMBOLright))
adamc@170 804 | cpath (PCon (#1 cpath, #2 cpath, NONE), s (cpathleft, cpathright))
adamc@170 805 | UNDER (PWild, s (UNDERleft, UNDERright))
adamc@173 806 | INT (PPrim (Prim.Int INT), s (INTleft, INTright))
adamc@173 807 | STRING (PPrim (Prim.String STRING), s (STRINGleft, STRINGright))
adamc@170 808 | LPAREN pat RPAREN (pat)
adamc@174 809 | LBRACE RBRACE (PRecord ([], false), s (LBRACEleft, RBRACEright))
adamc@174 810 | UNIT (PRecord ([], false), s (UNITleft, UNITright))
adamc@174 811 | LBRACE rpat RBRACE (PRecord rpat, s (LBRACEleft, RBRACEright))
adamc@195 812 | LPAREN ptuple RPAREN (PRecord (ListUtil.mapi (fn (i, p) => (Int.toString (i + 1), p)) ptuple,
adamc@195 813 false),
adamc@195 814 s (LPARENleft, RPARENright))
adamc@174 815
adamc@175 816 rpat : CSYMBOL EQ pat ([(CSYMBOL, pat)], false)
adamc@243 817 | INT EQ pat ([(Int64.toString INT, pat)], false)
adamc@174 818 | DOTDOTDOT ([], true)
adamc@175 819 | CSYMBOL EQ pat COMMA rpat ((CSYMBOL, pat) :: #1 rpat, #2 rpat)
adamc@243 820 | INT EQ pat COMMA rpat ((Int64.toString INT, pat) :: #1 rpat, #2 rpat)
adamc@170 821
adamc@195 822 ptuple : pat COMMA pat ([pat1, pat2])
adamc@195 823 | pat COMMA ptuple (pat :: ptuple)
adamc@195 824
adamc@12 825 rexp : ([])
adamc@12 826 | ident EQ eexp ([(ident, eexp)])
adamc@12 827 | ident EQ eexp COMMA rexp ((ident, eexp) :: rexp)
adamc@91 828
adamc@141 829 xml : xmlOne xml (let
adamc@141 830 val pos = s (xmlOneleft, xmlright)
adamc@141 831 in
adamc@141 832 (EApp ((EApp (
adamc@141 833 (EVar (["Basis"], "join"), pos),
adamc@91 834 xmlOne), pos),
adamc@141 835 xml), pos)
adamc@141 836 end)
adamc@141 837 | xmlOne (xmlOne)
adamc@91 838
adamc@141 839 xmlOne : NOTAGS (EApp ((EVar (["Basis"], "cdata"), s (NOTAGSleft, NOTAGSright)),
adamc@141 840 (EPrim (Prim.String NOTAGS), s (NOTAGSleft, NOTAGSright))),
adamc@141 841 s (NOTAGSleft, NOTAGSright))
adamc@141 842 | tag DIVIDE GT (let
adamc@141 843 val pos = s (tagleft, GTright)
adamc@141 844 in
adamc@141 845 (EApp (#2 tag,
adamc@141 846 (EApp ((EVar (["Basis"], "cdata"), pos),
adamc@141 847 (EPrim (Prim.String ""), pos)),
adamc@141 848 pos)), pos)
adamc@141 849 end)
adamc@141 850
adamc@141 851 | tag GT xml END_TAG (let
adamc@141 852 val pos = s (tagleft, GTright)
adamc@141 853 in
adamc@141 854 if #1 tag = END_TAG then
adamc@141 855 if END_TAG = "lform" then
adamc@141 856 (EApp ((EVar (["Basis"], "lform"), pos),
adamc@141 857 xml), pos)
adamc@141 858 else
adamc@141 859 (EApp (#2 tag, xml), pos)
adamc@141 860 else
adamc@141 861 (ErrorMsg.errorAt pos "Begin and end tags don't match.";
adamc@141 862 (EFold, pos))
adamc@141 863 end)
adamc@141 864 | LBRACE eexp RBRACE (eexp)
adamc@92 865
adamc@141 866 tag : tagHead attrs (let
adamc@141 867 val pos = s (tagHeadleft, attrsright)
adamc@141 868 in
adamc@141 869 (#1 tagHead,
adamc@141 870 (EApp ((EApp ((EVar (["Basis"], "tag"), pos),
adamc@141 871 (ERecord attrs, pos)), pos),
adamc@141 872 (EApp (#2 tagHead,
adamc@141 873 (ERecord [], pos)), pos)),
adamc@141 874 pos))
adamc@141 875 end)
adamc@141 876
adamc@141 877 tagHead: BEGIN_TAG (let
adamc@141 878 val pos = s (BEGIN_TAGleft, BEGIN_TAGright)
adamc@141 879 in
adamc@141 880 (BEGIN_TAG,
adamc@141 881 (EVar ([], BEGIN_TAG), pos))
adamc@141 882 end)
adamc@141 883 | tagHead LBRACE cexp RBRACE (#1 tagHead, (ECApp (#2 tagHead, cexp), s (tagHeadleft, RBRACEright)))
adamc@92 884
adamc@104 885 attrs : ([])
adamc@104 886 | attr attrs (attr :: attrs)
adamc@104 887
adamc@204 888 attr : SYMBOL EQ attrv ((CName (capitalize SYMBOL), s (SYMBOLleft, SYMBOLright)), attrv)
adamc@204 889
adamc@104 890 attrv : INT (EPrim (Prim.Int INT), s (INTleft, INTright))
adamc@104 891 | FLOAT (EPrim (Prim.Float FLOAT), s (FLOATleft, FLOATright))
adamc@104 892 | STRING (EPrim (Prim.String STRING), s (STRINGleft, STRINGright))
adamc@110 893 | LBRACE eexp RBRACE (eexp)
adamc@226 894
adamc@232 895 query : query1 obopt lopt ofopt (let
adamc@229 896 val loc = s (query1left, query1right)
adamc@230 897
adamc@230 898 val re = (ERecord [((CName "Rows", loc),
adamc@230 899 query1),
adamc@230 900 ((CName "OrderBy", loc),
adamc@231 901 obopt),
adamc@231 902 ((CName "Limit", loc),
adamc@232 903 lopt),
adamc@232 904 ((CName "Offset", loc),
adamc@232 905 ofopt)], loc)
adamc@229 906 in
adamc@230 907 (EApp ((EVar (["Basis"], "sql_query"), loc), re), loc)
adamc@229 908 end)
adamc@204 909
adamc@227 910 query1 : SELECT select FROM tables wopt gopt hopt
adamc@209 911 (let
adamc@204 912 val loc = s (SELECTleft, tablesright)
adamc@207 913
adamc@233 914 val (sel, exps) =
adamc@207 915 case select of
adamc@233 916 Star => (map (fn (nm, _) =>
adamc@233 917 (nm, (CTuple [(CWild (KRecord (KType, loc), loc),
adamc@233 918 loc),
adamc@233 919 (CRecord [], loc)],
adamc@233 920 loc))) tables,
adamc@233 921 [])
adamc@207 922 | Items sis =>
adamc@207 923 let
adamc@207 924 val tabs = map (fn (nm, _) => (nm, (CRecord [], loc))) tables
adamc@233 925 val (tabs, exps) = foldl (amend_select loc) (tabs, []) sis
adamc@207 926 in
adamc@233 927 (map (fn (nm, c) => (nm,
adamc@233 928 (CTuple [c,
adamc@233 929 (CWild (KRecord (KType, loc), loc),
adamc@233 930 loc)], loc))) tabs,
adamc@233 931 exps)
adamc@207 932 end
adamc@207 933
adamc@207 934 val sel = (CRecord sel, loc)
adamc@207 935
adamc@226 936 val grp = case gopt of
adamc@226 937 NONE => (ECApp ((EVar (["Basis"], "sql_subset_all"), loc),
adamc@226 938 (CWild (KRecord (KRecord (KType, loc), loc),
adamc@226 939 loc), loc)), loc)
adamc@226 940 | SOME gis =>
adamc@226 941 let
adamc@226 942 val tabs = map (fn (nm, _) =>
adamc@226 943 (nm, (CRecord [], loc))) tables
adamc@226 944 val tabs = foldl (amend_group loc) tabs gis
adamc@226 945
adamc@226 946 val tabs = map (fn (nm, c) =>
adamc@226 947 (nm,
adamc@226 948 (CTuple [c,
adamc@226 949 (CWild (KRecord (KType, loc),
adamc@226 950 loc),
adamc@226 951 loc)], loc))) tabs
adamc@226 952 in
adamc@226 953 (ECApp ((EVar (["Basis"], "sql_subset"), loc),
adamc@226 954 (CRecord tabs, loc)), loc)
adamc@226 955 end
adamc@226 956
adamc@229 957 val e = (EVar (["Basis"], "sql_query1"), loc)
adamc@209 958 val re = (ERecord [((CName "From", loc),
adamc@209 959 (ERecord tables, loc)),
adamc@209 960 ((CName "Where", loc),
adamc@223 961 wopt),
adamc@224 962 ((CName "GroupBy", loc),
adamc@226 963 grp),
adamc@224 964 ((CName "Having", loc),
adamc@224 965 hopt),
adamc@223 966 ((CName "SelectFields", loc),
adamc@223 967 (ECApp ((EVar (["Basis"], "sql_subset"), loc),
adamc@233 968 sel), loc)),
adamc@233 969 ((CName "SelectExps", loc),
adamc@233 970 (ERecord exps, loc))], loc)
adamc@223 971
adamc@209 972 val e = (EApp (e, re), loc)
adamc@204 973 in
adamc@207 974 e
adamc@204 975 end)
adamc@229 976 | query1 UNION query1 (sql_relop ("union", query11, query12, s (query11left, query12right)))
adamc@229 977 | query1 INTERSECT query1 (sql_relop ("intersect", query11, query12, s (query11left, query12right)))
adamc@229 978 | query1 EXCEPT query1 (sql_relop ("except", query11, query12, s (query11left, query12right)))
adamc@204 979
adamc@204 980 tables : table ([table])
adamc@204 981 | table COMMA tables (table :: tables)
adamc@204 982
adamc@204 983 tname : CSYMBOL (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright))
adamc@204 984 | LBRACE cexp RBRACE (cexp)
adamc@204 985
adamc@243 986 table : SYMBOL ((CName (capitalize SYMBOL), s (SYMBOLleft, SYMBOLright)),
adamc@204 987 (EVar ([], SYMBOL), s (SYMBOLleft, SYMBOLright)))
adamc@204 988 | SYMBOL AS tname (tname, (EVar ([], SYMBOL), s (SYMBOLleft, SYMBOLright)))
adamc@221 989 | LBRACE LBRACE eexp RBRACE RBRACE AS tname (tname, eexp)
adamc@207 990
adamc@243 991 tident : SYMBOL (CName (capitalize SYMBOL), s (SYMBOLleft, SYMBOLright))
adamc@207 992 | CSYMBOL (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright))
adamc@221 993 | LBRACE LBRACE cexp RBRACE RBRACE (cexp)
adamc@207 994
adamc@207 995 fident : CSYMBOL (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright))
adamc@207 996 | LBRACE cexp RBRACE (cexp)
adamc@207 997
adamc@207 998 seli : tident DOT fident (Field (tident, fident))
adamc@233 999 | sqlexp AS fident (Exp (fident, sqlexp))
adamc@207 1000
adamc@207 1001 selis : seli ([seli])
adamc@207 1002 | seli COMMA selis (seli :: selis)
adamc@207 1003
adamc@207 1004 select : STAR (Star)
adamc@207 1005 | selis (Items selis)
adamc@209 1006
adamc@209 1007 sqlexp : TRUE (sql_inject (EVar (["Basis"], "True"),
adamc@209 1008 EVar (["Basis"], "sql_bool"),
adamc@209 1009 s (TRUEleft, TRUEright)))
adamc@209 1010 | FALSE (sql_inject (EVar (["Basis"], "False"),
adamc@209 1011 EVar (["Basis"], "sql_bool"),
adamc@209 1012 s (FALSEleft, FALSEright)))
adamc@209 1013
adamc@222 1014 | INT (sql_inject (EPrim (Prim.Int INT),
adamc@222 1015 EVar (["Basis"], "sql_int"),
adamc@222 1016 s (INTleft, INTright)))
adamc@222 1017 | FLOAT (sql_inject (EPrim (Prim.Float FLOAT),
adamc@222 1018 EVar (["Basis"], "sql_float"),
adamc@222 1019 s (FLOATleft, FLOATright)))
adamc@229 1020 | STRING (sql_inject (EPrim (Prim.String STRING),
adamc@229 1021 EVar (["Basis"], "sql_string"),
adamc@229 1022 s (STRINGleft, STRINGright)))
adamc@222 1023
adamc@221 1024 | tident DOT fident (let
adamc@221 1025 val loc = s (tidentleft, fidentright)
adamc@221 1026 val e = (EVar (["Basis"], "sql_field"), loc)
adamc@221 1027 val e = (ECApp (e, tident), loc)
adamc@221 1028 in
adamc@221 1029 (ECApp (e, fident), loc)
adamc@221 1030 end)
adamc@234 1031 | CSYMBOL (let
adamc@234 1032 val loc = s (CSYMBOLleft, CSYMBOLright)
adamc@234 1033 val e = (EVar (["Basis"], "sql_exp"), loc)
adamc@234 1034 in
adamc@234 1035 (ECApp (e, (CName CSYMBOL, loc)), loc)
adamc@234 1036 end)
adamc@221 1037
adamc@219 1038 | sqlexp EQ sqlexp (sql_compare ("eq", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
adamc@219 1039 | sqlexp NE sqlexp (sql_compare ("ne", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
adamc@219 1040 | sqlexp LT sqlexp (sql_compare ("lt", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
adamc@219 1041 | sqlexp LE sqlexp (sql_compare ("le", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
adamc@219 1042 | sqlexp GT sqlexp (sql_compare ("gt", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
adamc@219 1043 | sqlexp GE sqlexp (sql_compare ("ge", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
adamc@219 1044
adamc@220 1045 | sqlexp CAND sqlexp (sql_binary ("and", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
adamc@220 1046 | sqlexp OR sqlexp (sql_binary ("or", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
adamc@220 1047 | NOT sqlexp (sql_unary ("not", sqlexp, s (NOTleft, sqlexpright)))
adamc@220 1048
adamc@210 1049 | LBRACE eexp RBRACE (sql_inject (#1 eexp,
adamc@211 1050 EWild,
adamc@210 1051 s (LBRACEleft, RBRACEright)))
adamc@220 1052 | LPAREN sqlexp RPAREN (sqlexp)
adamc@210 1053
adamc@235 1054 | COUNT LPAREN STAR RPAREN (let
adamc@235 1055 val loc = s (COUNTleft, RPARENright)
adamc@235 1056 in
adamc@235 1057 (EApp ((EVar (["Basis"], "sql_count"), loc),
adamc@235 1058 (ERecord [], loc)), loc)
adamc@235 1059 end)
adamc@236 1060 | sqlagg LPAREN sqlexp RPAREN (let
adamc@236 1061 val loc = s (sqlaggleft, RPARENright)
adamc@236 1062
adamc@236 1063 val e = (EApp ((EVar (["Basis"], "sql_" ^ sqlagg), loc),
adamc@236 1064 (EWild, loc)), loc)
adamc@236 1065 val e = (EApp ((EVar (["Basis"], "sql_aggregate"), loc),
adamc@236 1066 e), loc)
adamc@236 1067 in
adamc@236 1068 (EApp (e, sqlexp), loc)
adamc@236 1069 end)
adamc@235 1070
adamc@209 1071 wopt : (sql_inject (EVar (["Basis"], "True"),
adamc@209 1072 EVar (["Basis"], "sql_bool"),
adamc@230 1073 dummy))
adamc@209 1074 | CWHERE sqlexp (sqlexp)
adamc@226 1075
adamc@226 1076 groupi : tident DOT fident (GField (tident, fident))
adamc@226 1077
adamc@226 1078 groupis: groupi ([groupi])
adamc@226 1079 | groupi COMMA groupis (groupi :: groupis)
adamc@226 1080
adamc@226 1081 gopt : (NONE)
adamc@226 1082 | GROUP BY groupis (SOME groupis)
adamc@227 1083
adamc@227 1084 hopt : (sql_inject (EVar (["Basis"], "True"),
adamc@227 1085 EVar (["Basis"], "sql_bool"),
adamc@230 1086 dummy))
adamc@227 1087 | HAVING sqlexp (sqlexp)
adamc@230 1088
adamc@230 1089 obopt : (ECApp ((EVar (["Basis"], "sql_order_by_Nil"), dummy),
adamc@234 1090 (CWild (KRecord (KType, dummy), dummy), dummy)),
adamc@230 1091 dummy)
adamc@230 1092 | ORDER BY obexps (obexps)
adamc@230 1093
adamc@268 1094 obitem : sqlexp diropt (sqlexp, diropt)
adamc@268 1095
adamc@268 1096 obexps : obitem (let
adamc@268 1097 val loc = s (obitemleft, obitemright)
adamc@230 1098
adamc@230 1099 val e' = (ECApp ((EVar (["Basis"], "sql_order_by_Nil"), loc),
adamc@234 1100 (CWild (KRecord (KType, loc), loc), loc)),
adamc@230 1101 loc)
adamc@230 1102 val e = (EApp ((EVar (["Basis"], "sql_order_by_Cons"), loc),
adamc@268 1103 #1 obitem), loc)
adamc@268 1104 val e = (EApp (e, #2 obitem), loc)
adamc@230 1105 in
adamc@230 1106 (EApp (e, e'), loc)
adamc@230 1107 end)
adamc@268 1108 | obitem COMMA obexps (let
adamc@268 1109 val loc = s (obitemleft, obexpsright)
adamc@230 1110
adamc@230 1111 val e = (EApp ((EVar (["Basis"], "sql_order_by_Cons"), loc),
adamc@268 1112 #1 obitem), loc)
adamc@268 1113 val e = (EApp (e, #2 obitem), loc)
adamc@230 1114 in
adamc@230 1115 (EApp (e, obexps), loc)
adamc@230 1116 end)
adamc@231 1117
adamc@268 1118 diropt : (EVar (["Basis"], "sql_asc"), dummy)
adamc@268 1119 | ASC (EVar (["Basis"], "sql_asc"), s (ASCleft, ASCright))
adamc@268 1120 | DESC (EVar (["Basis"], "sql_desc"), s (DESCleft, DESCright))
adamc@268 1121
adamc@231 1122 lopt : (EVar (["Basis"], "sql_no_limit"), dummy)
adamc@232 1123 | LIMIT ALL (EVar (["Basis"], "sql_no_limit"), dummy)
adamc@231 1124 | LIMIT sqlint (let
adamc@231 1125 val loc = s (LIMITleft, sqlintright)
adamc@231 1126 in
adamc@231 1127 (EApp ((EVar (["Basis"], "sql_limit"), loc), sqlint), loc)
adamc@231 1128 end)
adamc@231 1129
adamc@232 1130 ofopt : (EVar (["Basis"], "sql_no_offset"), dummy)
adamc@232 1131 | OFFSET sqlint (let
adamc@232 1132 val loc = s (OFFSETleft, sqlintright)
adamc@232 1133 in
adamc@232 1134 (EApp ((EVar (["Basis"], "sql_offset"), loc), sqlint), loc)
adamc@232 1135 end)
adamc@232 1136
adamc@231 1137 sqlint : INT (EPrim (Prim.Int INT), s (INTleft, INTright))
adamc@231 1138 | LBRACE eexp RBRACE (eexp)
adamc@236 1139
adamc@236 1140 sqlagg : AVG ("avg")
adamc@236 1141 | SUM ("sum")
adamc@236 1142 | MIN ("min")
adamc@236 1143 | MAX ("max")