adam@1751: (* Copyright (c) 2008-2012, Adam Chlipala adamc@1: * All rights reserved. adamc@1: * adamc@1: * Redistribution and use in source and binary forms, with or without adamc@1: * modification, are permitted provided that the following conditions are met: adamc@1: * adamc@1: * - Redistributions of source code must retain the above copyright notice, adamc@1: * this list of conditions and the following disclaimer. adamc@1: * - Redistributions in binary form must reproduce the above copyright notice, adamc@1: * this list of conditions and the following disclaimer in the documentation adamc@1: * and/or other materials provided with the distribution. adamc@1: * - The names of contributors may not be used to endorse or promote products adamc@1: * derived from this software without specific prior written permission. adamc@1: * adamc@339: * THIS SOFTARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" adamc@1: * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE adamc@1: * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE adamc@1: * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE adamc@1: * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR adamc@1: * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF adamc@1: * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS adamc@1: * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN adamc@1: * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) adamc@1: * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE adamc@1: * POSSIBILITY OF SUCH DAMAGE. adamc@1: *) adamc@1: adamc@244: (* Grammar for Ur/Web programs *) adamc@1: adamc@4: open Source adamc@1: adamc@1: val s = ErrorMsg.spanOf adamc@230: val dummy = ErrorMsg.dummySpan adamc@1: adamc@204: fun capitalize "" = "" adamc@204: | capitalize s = str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE) adamc@104: adamc@203: fun entable t = adamc@203: case #1 t of adamc@203: TRecord c => c adamc@203: | _ => t adamc@203: adamc@207: datatype select_item = adamc@207: Field of con * con adamc@1194: | Exp of con option * exp adamc@341: | Fields of con * con adam@1627: | StarFields of con adamc@207: adamc@207: datatype select = adamc@207: Star adamc@207: | Items of select_item list adamc@207: adamc@226: datatype group_item = adamc@226: GField of con * con adam@1425: | GFields of con * con adamc@226: adamc@207: fun eqTnames ((c1, _), (c2, _)) = adamc@207: case (c1, c2) of adamc@207: (CVar (ms1, x1), CVar (ms2, x2)) => ms1 = ms2 andalso x1 = x2 adamc@207: | (CName x1, CName x2) => x1 = x2 adamc@207: | _ => false adamc@207: adam@1424: fun nameString (c, _) = adam@1424: case c of adam@1424: CName s => s adam@1424: | CVar (_, x) => x adam@1424: | _ => "?" adam@1424: adam@1627: datatype tableMode = adam@1627: Unknown adam@1627: | Everything adam@1627: | Selective of con adam@1627: adamc@1194: fun amend_select loc (si, (count, tabs, exps)) = adamc@233: case si of adamc@233: Field (tx, fx) => adamc@233: let adamc@233: val c = (CRecord ([(fx, (CWild (KType, loc), loc))]), loc) adamc@207: adamc@233: val (tabs, found) = ListUtil.foldlMap (fn ((tx', c'), found) => adamc@233: if eqTnames (tx, tx') then adam@1627: case c' of adam@1627: Everything => adam@1627: (ErrorMsg.errorAt loc adam@1627: "Mixing specific-field and '*' selection of fields from same table"; adam@1627: ((tx', c'), found)) adam@1627: | Unknown => adam@1627: ((tx', Selective c), true) adam@1627: | Selective c' => adam@1627: ((tx', Selective (CConcat (c, c'), loc)), true) adamc@233: else adamc@233: ((tx', c'), found)) adamc@233: false tabs adamc@233: in adamc@233: if found then adamc@233: () adamc@233: else adam@1424: ErrorMsg.errorAt loc ("Select of field " ^ nameString fx ^ " from unbound table " ^ nameString tx); adamc@233: adamc@1194: (count, tabs, exps) adamc@233: end adamc@341: | Fields (tx, fs) => adamc@341: let adamc@341: val (tabs, found) = ListUtil.foldlMap (fn ((tx', c'), found) => adamc@341: if eqTnames (tx, tx') then adam@1627: case c' of adam@1627: Everything => adam@1627: (ErrorMsg.errorAt loc adam@1627: "Mixing specific-field and '*' selection of fields from same table"; adam@1627: ((tx', c'), found)) adam@1627: | Selective c' => adam@1627: ((tx', Selective (CConcat (fs, c'), loc)), true) adam@1627: | Unknown => adam@1627: ((tx', Selective fs), true) adamc@341: else adamc@341: ((tx', c'), found)) adamc@341: false tabs adamc@341: in adamc@341: if found then adamc@341: () adamc@341: else adamc@341: ErrorMsg.errorAt loc "Select of field from unbound table"; adamc@341: adamc@1194: (count, tabs, exps) adamc@341: end adam@1627: | StarFields tx => adam@1627: if List.exists (fn (tx', c') => eqTnames (tx, tx') andalso case c' of adam@1627: Unknown => false adam@1627: | _ => true) tabs then adam@1627: (ErrorMsg.errorAt loc "Selection with '*' from table already mentioned in same SELECT clause"; adam@1627: (count, tabs, exps)) adam@1627: else if List.all (fn (tx', c') => not (eqTnames (tx, tx'))) tabs then adam@1627: (ErrorMsg.errorAt loc "Select of all fields from unbound table"; adam@1627: (count, tabs, exps)) adam@1627: else adam@1627: (count, map (fn (tx', c') => (tx', if eqTnames (tx, tx') then Everything else c')) tabs, exps) adamc@1194: | Exp (SOME c, e) => (count, tabs, (c, e) :: exps) adamc@1194: | Exp (NONE, e) => (count+1, tabs, ((CName (Int.toString count), loc), e) :: exps) adamc@207: adamc@226: fun amend_group loc (gi, tabs) = adamc@226: let adamc@226: val (tx, c) = case gi of adamc@226: GField (tx, fx) => (tx, (CRecord ([(fx, (CWild (KType, loc), loc))]), loc)) adam@1425: | GFields (tx, fxs) => (tx, fxs) adamc@226: adamc@226: val (tabs, found) = ListUtil.foldlMap (fn ((tx', c'), found) => adamc@226: if eqTnames (tx, tx') then adamc@226: ((tx', (CConcat (c, c'), loc)), true) adamc@226: else adamc@226: ((tx', c'), found)) adam@1425: false tabs adamc@226: in adamc@226: if found then adamc@226: () adamc@226: else adamc@226: ErrorMsg.errorAt loc "Select of field from unbound table"; adamc@226: adamc@226: tabs adamc@226: end adamc@226: adamc@403: fun sql_inject (v, loc) = adamc@403: (EApp ((EVar (["Basis"], "sql_inject", Infer), loc), (v, loc)), loc) adamc@209: adamc@220: fun sql_binary (oper, sqlexp1, sqlexp2, loc) = adamc@220: let adamc@403: val e = (EVar (["Basis"], "sql_binary", Infer), loc) adamc@403: val e = (EApp (e, (EVar (["Basis"], "sql_" ^ oper, Infer), loc)), loc) adamc@220: val e = (EApp (e, sqlexp1), loc) adamc@220: in adamc@220: (EApp (e, sqlexp2), loc) adamc@220: end adamc@220: adamc@220: fun sql_unary (oper, sqlexp, loc) = adamc@220: let adamc@403: val e = (EVar (["Basis"], "sql_unary", Infer), loc) adamc@403: val e = (EApp (e, (EVar (["Basis"], "sql_" ^ oper, Infer), loc)), loc) adamc@220: in adamc@220: (EApp (e, sqlexp), loc) adamc@219: end adamc@219: adam@1427: fun sql_relop (oper, all, sqlexp1, sqlexp2, loc) = adamc@229: let adamc@403: val e = (EVar (["Basis"], "sql_relop", Infer), loc) adamc@403: val e = (EApp (e, (EVar (["Basis"], "sql_" ^ oper, Infer), loc)), loc) adam@1427: val e = (EApp (e, (EVar (["Basis"], if all then "True" else "False", Infer), loc)), loc) adamc@229: val e = (EApp (e, sqlexp1), loc) adamc@229: in adamc@229: (EApp (e, sqlexp2), loc) adamc@229: end adamc@229: adamc@441: fun sql_nfunc (oper, loc) = adamc@441: let adamc@441: val e = (EVar (["Basis"], "sql_nfunc", Infer), loc) adamc@441: in adamc@441: (EApp (e, (EVar (["Basis"], "sql_" ^ oper, Infer), loc)), loc) adamc@441: end adamc@441: adamc@389: fun native_unop (oper, e1, loc) = adamc@389: let adamc@403: val e = (EVar (["Basis"], oper, Infer), loc) adamc@389: in adamc@389: (EApp (e, e1), loc) adamc@389: end adamc@389: adamc@256: fun native_op (oper, e1, e2, loc) = adamc@256: let adamc@403: val e = (EVar (["Basis"], oper, Infer), loc) adamc@256: val e = (EApp (e, e1), loc) adamc@256: in adamc@256: (EApp (e, e2), loc) adamc@256: end adamc@256: adamc@310: val inDml = ref false adamc@310: adamc@325: fun tagIn bt = adamc@325: case bt of adamc@325: "table" => "tabl" adamc@325: | _ => bt adamc@325: adamc@709: datatype prop_kind = Delete | Update adamc@709: adam@1751: datatype attr = Class of exp | DynClass of exp | Style of exp | DynStyle of exp | Normal of con * exp adamc@721: adamc@822: fun patType loc (p : pat) = adamc@822: case #1 p of adamc@822: PAnnot (_, t) => t adamc@822: | _ => (CWild (KType, loc), loc) adamc@822: adamc@1265: fun tnamesOf (e, _) = adamc@1265: case e of adamc@1265: EApp (e1, e2) => tnamesOf e1 @ tnamesOf e2 adamc@1265: | ECApp (e, c as (CName _, _)) => adamc@1265: let adamc@1265: fun isFt (e, _) = adamc@1265: case e of adamc@1265: EVar (["Basis"], "sql_from_table", _) => true adamc@1265: | EVar ([], "sql_from_table", _) => true adamc@1265: | ECApp (e, _) => isFt e adamc@1265: | EApp (e, _) => isFt e adamc@1265: | EDisjointApp e => isFt e adamc@1265: | _ => false adamc@1265: in adamc@1265: (if isFt e then [c] else []) @ tnamesOf e adamc@1265: end adamc@1265: | ECApp (e, _) => tnamesOf e adamc@1265: | EDisjointApp e => tnamesOf e adamc@1265: | _ => [] adamc@1265: adam@1761: fun classOut (s, pos) = adam@1761: let adam@1761: val s = case s of adam@1761: "table" => "tabl" adam@1761: | _ => s adam@1761: in adam@1761: (EVar ([], String.translate (fn #"-" => "_" | ch => str ch) s, Infer), pos) adam@1761: end adam@1749: adam@1749: fun parseClass s pos = adam@1749: case String.tokens Char.isSpace s of adam@1749: [] => (EVar (["Basis"], "null", Infer), pos) adam@1749: | class :: classes => adam@1749: foldl (fn (s, e) => (EApp ((EApp ((EVar (["Basis"], "classes", Infer), pos), e), pos), classOut (s, pos)), pos)) adam@1749: (classOut (class, pos)) classes adam@1749: adam@1750: fun parseValue s pos = adam@1750: if String.isPrefix "url(" s andalso String.isSuffix ")" s then adam@1750: let adam@1750: val s = String.substring (s, 4, size s - 5) adam@1750: adam@1750: val s = if size s >= 2 adam@1750: andalso ((String.isPrefix "\"" s andalso String.isSuffix "\"" s) adam@1750: orelse (String.isPrefix "'" s andalso String.isSuffix "'" s)) then adam@1750: String.substring (s, 1, size s - 2) adam@1750: else adam@1750: s adam@1750: in adam@1750: (EApp ((EVar (["Basis"], "css_url", Infer), pos), adam@1750: (EApp ((EVar (["Basis"], "bless", Infer), pos), adam@1750: (EPrim (Prim.String s), pos)), pos)), pos) adam@1750: end adam@1750: else adam@1750: (EApp ((EVar (["Basis"], "atom", Infer), pos), adam@1750: (EPrim (Prim.String s), pos)), pos) adam@1750: adam@1750: fun parseProperty s pos = adam@1750: let adam@1750: val (befor, after) = Substring.splitl (fn ch => ch <> #":") (Substring.full s) adam@1750: in adam@1750: if Substring.isEmpty after then adam@1750: (ErrorMsg.errorAt pos ("Invalid CSS property syntax: " ^ s); adam@1750: (EPrim (Prim.String ""), pos)) adam@1750: else adam@1750: foldl (fn (value, e) => (EApp ((EApp ((EVar (["Basis"], "value", Infer), pos), e), pos), parseValue value pos), pos)) adam@1750: (EApp ((EVar (["Basis"], "property", Infer), pos), adam@1750: (EPrim (Prim.String (Substring.string (#2 (Substring.splitl Char.isSpace befor)))), pos)), pos) adam@1750: (String.tokens Char.isSpace (Substring.string (Substring.slice (after, 1, NONE)))) adam@1750: end adam@1750: adam@1750: fun parseStyle s pos = adam@1750: case String.tokens (fn ch => ch = #";") s of adam@1750: [] => (EVar (["Basis"], "noStyle", Infer), pos) adam@1750: | props => adam@1750: foldl (fn (s, e) => (EApp ((EApp ((EVar (["Basis"], "oneProperty", Infer), pos), e), pos), parseProperty s pos), pos)) adam@1750: (EVar (["Basis"], "noStyle", Infer), pos) props adam@1750: adamc@1: %% adamc@244: %header (functor UrwebLrValsFn(structure Token : TOKEN)) adamc@1: adamc@1: %term adamc@1: EOF adamc@821: | STRING of string | INT of Int64.int | FLOAT of Real64.real | CHAR of char adamc@1: | SYMBOL of string | CSYMBOL of string adamc@1: | LPAREN | RPAREN | LBRACK | RBRACK | LBRACE | RBRACE adam@1306: | EQ | COMMA | COLON | DCOLON | DCOLONWILD | TCOLON | TCOLONWILD | DOT | HASH | UNDER | UNDERUNDER | BAR adamc@403: | PLUS | MINUS | DIVIDE | DOTDOTDOT | MOD | AT adamc@623: | CON | LTYPE | VAL | REC | AND | FUN | MAP | UNIT | KUNIT | CLASS adamc@156: | DATATYPE | OF adamc@7: | TYPE | NAME adamc@629: | ARROW | LARROW | DARROW | STAR | SEMI | KARROW | DKARROW | BANG adamc@674: | FN | PLUSPLUS | MINUSMINUS | MINUSMINUSMINUS | DOLLAR | TWIDDLE | CARET adamc@446: | LET | IN adam@1732: | STRUCTURE | SIGNATURE | STRUCT | SIG | END | FUNCTOR | WHERE | SQL | SELECT1 adamc@754: | INCLUDE | OPEN | CONSTRAINT | CONSTRAINTS | EXPORT | TABLE | SEQUENCE | VIEW adamc@1199: | COOKIE | STYLE | TASK | POLICY adamc@842: | CASE | IF | THEN | ELSE | ANDALSO | ORELSE adamc@1: adamc@360: | XML_BEGIN of string | XML_END | XML_BEGIN_END of string adamc@91: | NOTAGS of string adamc@91: | BEGIN_TAG of string | END_TAG of string adamc@91: adamc@993: | SELECT | DISTINCT | FROM | AS | CWHERE | GROUP | ORDER | BY | HAVING adamc@229: | UNION | INTERSECT | EXCEPT adamc@232: | LIMIT | OFFSET | ALL adamc@220: | TRUE | FALSE | CAND | OR | NOT adamc@236: | COUNT | AVG | SUM | MIN | MAX adam@1682: | ASC | DESC | RANDOM kkallio@1607: | INSERT | INTO | VALUES | UPDATE | SET | DELETE | NULL | IS | COALESCE | LIKE adamc@441: | CURRENT_TIMESTAMP adamc@219: | NE | LT | LE | GT | GE adamc@714: | CCONSTRAINT | UNIQUE | CHECK | PRIMARY | FOREIGN | KEY | ON | NO | ACTION | RESTRICT | CASCADE | REFERENCES adamc@751: | JOIN | INNER | CROSS | OUTER | LEFT | RIGHT | FULL kkallio@1572: | CIF | CTHEN | CELSE adamc@204: adamc@30: %nonterm adamc@1: file of decl list adamc@1: | decls of decl list adamc@325: | decl of decl list adamc@123: | vali of string * con option * exp adamc@123: | valis of (string * con option * exp) list adamc@242: | copt of con option adamc@1: adamc@191: | dargs of string list adamc@156: | barOpt of unit adamc@156: | dcons of (string * con option) list adamc@805: | dtype of string * string list * (string * con option) list adamc@805: | dtypes of (string * string list * (string * con option) list) list adamc@156: | dcon of string * con option adamc@156: adamc@707: | pkopt of exp adam@1722: | pk of exp adamc@707: | commaOpt of unit adamc@707: adamc@704: | cst of exp adamc@704: | csts of exp adamc@704: | cstopt of exp adamc@704: adamc@1001: | ckl of (string * kind option) list adamc@1001: adamc@709: | pmode of prop_kind * exp adamc@709: | pkind of prop_kind adamc@709: | prule of exp adamc@709: | pmodes of (prop_kind * exp) list adamc@709: adamc@30: | sgn of sgn adamc@42: | sgntm of sgn adamc@30: | sgi of sgn_item adamc@30: | sgis of sgn_item list adamc@30: adamc@30: | str of str adamc@30: adamc@1: | kind of kind adamc@207: | ktuple of kind list adamc@1: | kcolon of explicitness adamc@240: | kopt of kind option adamc@1: adamc@34: | path of string list * string adamc@156: | cpath of string list * string adamc@34: | spath of str adamc@59: | mpath of string list adamc@34: adamc@1: | cexp of con adam@1577: | cexpO of con option adamc@1: | capps of con adamc@1: | cterm of con adamc@195: | ctuple of con list adamc@207: | ctuplev of con list adamc@1: | ident of con adamc@200: | idents of con list adamc@1: | rcon of (con * con) list adamc@83: | rconn of (con * con) list adamc@1: | rcone of (con * con) list adamc@239: | cargs of con * kind -> con * kind adamc@239: | cargl of con * kind -> con * kind adamc@240: | cargl2 of con * kind -> con * kind adamc@239: | carg of con * kind -> con * kind adamc@239: | cargp of con * kind -> con * kind adamc@1: adamc@8: | eexp of exp adamc@8: | eapps of exp adamc@8: | eterm of exp adamc@195: | etuple of exp list adamc@12: | rexp of (con * exp) list adamc@91: | xml of exp adamc@91: | xmlOne of exp adamc@1045: | xmlOpt of exp adam@1643: | tag of (string * exp) * exp option * exp option * exp adamc@141: | tagHead of string * exp adamc@434: | bind of string * con option * exp adamc@446: | edecl of edecl adamc@446: | edecls of edecl list adamc@8: adamc@241: | earg of exp * con -> exp * con adamc@241: | eargp of exp * con -> exp * con adamc@822: | earga of exp * con -> exp * con adamc@241: | eargs of exp * con -> exp * con adamc@241: | eargl of exp * con -> exp * con adamc@242: | eargl2 of exp * con -> exp * con adamc@241: adamc@170: | branch of pat * exp adamc@170: | branchs of (pat * exp) list adamc@170: | pat of pat adamc@822: | patS of pat adamc@170: | pterm of pat adamc@174: | rpat of (string * pat) list * bool adamc@195: | ptuple of pat list adamc@170: adam@1751: | attrs of exp option * exp option * exp option * exp option * (con * exp) list adamc@721: | attr of attr adamc@104: | attrv of exp adamc@104: adamc@204: | query of exp adamc@226: | query1 of exp adamc@993: | dopt of exp adamc@748: | tables of con list * exp adamc@749: | fitem of con list * exp adamc@204: | tname of con adamc@705: | tnameW of con * con adamc@705: | tnames of (con * con) * (con * con) list adamc@705: | tnames' of (con * con) * (con * con) list adamc@204: | table of con * exp adamc@748: | table' of con * exp adamc@207: | tident of con adamc@207: | fident of con adamc@207: | seli of select_item adamc@207: | selis of select_item list adamc@207: | select of select adamc@209: | sqlexp of exp adamc@209: | wopt of exp adamc@226: | groupi of group_item adamc@226: | groupis of group_item list adamc@226: | gopt of group_item list option adamc@227: | hopt of exp adamc@230: | obopt of exp adamc@268: | obitem of exp * exp adamc@230: | obexps of exp adam@1682: | popt of unit adamc@268: | diropt of exp adamc@231: | lopt of exp adamc@232: | ofopt of exp adamc@231: | sqlint of exp adamc@236: | sqlagg of string adamc@746: | fname of exp adamc@207: adamc@302: | texp of exp adamc@302: | fields of con list adamc@302: | sqlexps of exp list adamc@303: | fsets of (con * exp) list adamc@310: | enterDml of unit adamc@310: | leaveDml of unit adamc@302: adamc@204: adamc@1: %verbose (* print summary of errors *) adamc@1: %pos int (* positions *) adamc@1: %start file adamc@1: %pure adamc@1: %eop EOF adamc@1: %noshift EOF adamc@1: adamc@244: %name Urweb adamc@1: adamc@623: %right KARROW adamc@623: %nonassoc DKARROW adamc@243: %right SEMI adamc@243: %nonassoc LARROW adamc@195: %nonassoc IF THEN ELSE adamc@843: %nonassoc DARROW adamc@842: %left ANDALSO adamc@842: %left ORELSE adamc@1: %nonassoc COLON adam@1306: %nonassoc DCOLON TCOLON DCOLONWILD TCOLONWILD adam@1427: %left UNION INTERSECT EXCEPT ALL adamc@1: %right COMMA adamc@751: %right JOIN INNER CROSS OUTER LEFT RIGHT FULL adamc@220: %right OR adamc@220: %right CAND adamc@470: %nonassoc EQ NE LT LE GT GE IS adamc@243: %right ARROW adamc@837: %right CARET PLUSPLUS adamc@837: %left MINUSMINUS MINUSMINUSMINUS adamc@389: %left PLUS MINUS adamc@389: %left STAR DIVIDE MOD adamc@220: %left NOT adamc@84: %nonassoc TWIDDLE adamc@1: %nonassoc DOLLAR adamc@1: %left DOT adamc@221: %nonassoc LBRACE RBRACE adamc@1: adamc@1: %% adamc@1: adamc@1: file : decls (decls) adamc@54: | SIG sgis ([(DSgn ("?", (SgnConst sgis, s (SIGleft, sgisright))), adamc@54: s (SIGleft, sgisright))]) adamc@1: adamc@1: decls : ([]) adamc@325: | decl decls (decl @ decls) adamc@1: adamc@240: decl : CON SYMBOL cargl2 kopt EQ cexp (let adamc@240: val loc = s (CONleft, cexpright) adamc@240: adamc@240: val k = Option.getOpt (kopt, (KWild, loc)) adamc@240: val (c, k) = cargl2 (cexp, k) adamc@240: in adamc@325: [(DCon (SYMBOL, SOME k, c), loc)] adamc@240: end) adam@1654: | LTYPE SYMBOL cargl2 EQ cexp (let adam@1654: val loc = s (LTYPEleft, cexpright) adam@1654: adam@1654: val k = (KWild, loc) adam@1654: val (c, k) = cargl2 (cexp, k) adam@1654: in adam@1654: [(DCon (SYMBOL, SOME k, c), loc)] adam@1654: end) adamc@805: | DATATYPE dtypes ([(DDatatype dtypes, s (DATATYPEleft, dtypesright))]) adamc@191: | DATATYPE SYMBOL dargs EQ DATATYPE CSYMBOL DOT path adamc@191: (case dargs of adamc@325: [] => [(DDatatypeImp (SYMBOL, CSYMBOL :: #1 path, #2 path), s (DATATYPEleft, pathright))] adamc@191: | _ => raise Fail "Arguments specified for imported datatype") adamc@325: | VAL vali ([(DVal vali, s (VALleft, valiright))]) adamc@325: | VAL REC valis ([(DValRec valis, s (VALleft, valisright))]) adamc@325: | FUN valis ([(DValRec valis, s (FUNleft, valisright))]) adamc@1: adamc@325: | SIGNATURE CSYMBOL EQ sgn ([(DSgn (CSYMBOL, sgn), s (SIGNATUREleft, sgnright))]) adam@1732: | STRUCTURE CSYMBOL EQ str ([(DStr (CSYMBOL, NONE, NONE, str), s (STRUCTUREleft, strright))]) adam@1732: | STRUCTURE CSYMBOL COLON sgn EQ str ([(DStr (CSYMBOL, SOME sgn, NONE, str), s (STRUCTUREleft, strright))]) adamc@42: | FUNCTOR CSYMBOL LPAREN CSYMBOL COLON sgn RPAREN EQ str adam@1732: ([(DStr (CSYMBOL1, NONE, NONE, adamc@325: (StrFun (CSYMBOL2, sgn1, NONE, str), s (FUNCTORleft, strright))), adamc@325: s (FUNCTORleft, strright))]) adamc@42: | FUNCTOR CSYMBOL LPAREN CSYMBOL COLON sgn RPAREN COLON sgn EQ str adam@1732: ([(DStr (CSYMBOL1, NONE, NONE, adamc@325: (StrFun (CSYMBOL2, sgn1, SOME sgn2, str), s (FUNCTORleft, strright))), adamc@325: s (FUNCTORleft, strright))]) adamc@61: | OPEN mpath (case mpath of adamc@61: [] => raise Fail "Impossible mpath parse [1]" adamc@325: | m :: ms => [(DOpen (m, ms), s (OPENleft, mpathright))]) adamc@325: | OPEN mpath LPAREN str RPAREN (let adamc@325: val loc = s (OPENleft, RPARENright) adamc@325: adamc@325: val m = case mpath of adamc@325: [] => raise Fail "Impossible mpath parse [4]" adamc@325: | m :: ms => adamc@325: foldl (fn (m, str) => (StrProj (str, m), loc)) adamc@325: (StrVar m, loc) ms adamc@325: in adam@1732: [(DStr ("anon", NONE, NONE, (StrApp (m, str), loc)), loc), adamc@325: (DOpen ("anon", []), loc)] adamc@325: end) adamc@88: | OPEN CONSTRAINTS mpath (case mpath of adamc@88: [] => raise Fail "Impossible mpath parse [3]" adamc@325: | m :: ms => [(DOpenConstraints (m, ms), s (OPENleft, mpathright))]) adamc@325: | CONSTRAINT cterm TWIDDLE cterm ([(DConstraint (cterm1, cterm2), s (CONSTRAINTleft, ctermright))]) adamc@325: | EXPORT spath ([(DExport spath, s (EXPORTleft, spathright))]) adamc@707: | TABLE SYMBOL COLON cterm pkopt commaOpt cstopt([(DTable (SYMBOL, entable cterm, pkopt, cstopt), adamc@707: s (TABLEleft, cstoptright))]) adamc@338: | SEQUENCE SYMBOL ([(DSequence SYMBOL, s (SEQUENCEleft, SYMBOLright))]) adamc@754: | VIEW SYMBOL EQ query ([(DView (SYMBOL, query), adamc@754: s (VIEWleft, queryright))]) adamc@754: | VIEW SYMBOL EQ LBRACE eexp RBRACE ([(DView (SYMBOL, eexp), adamc@754: s (VIEWleft, RBRACEright))]) adamc@563: | CLASS SYMBOL EQ cexp (let adamc@563: val loc = s (CLASSleft, cexpright) adamc@563: in adamc@563: [(DClass (SYMBOL, (KWild, loc), cexp), loc)] adamc@563: end) adamc@563: | CLASS SYMBOL DCOLON kind EQ cexp ([(DClass (SYMBOL, kind, cexp), s (CLASSleft, cexpright))]) adamc@211: | CLASS SYMBOL SYMBOL EQ cexp (let adamc@211: val loc = s (CLASSleft, cexpright) adamc@563: val k = (KWild, loc) adamc@211: val c = (CAbs (SYMBOL2, SOME k, cexp), loc) adamc@211: in adamc@563: [(DClass (SYMBOL1, k, c), s (CLASSleft, cexpright))] adamc@563: end) adamc@563: | CLASS SYMBOL LPAREN SYMBOL DCOLON kind RPAREN EQ cexp (let adamc@563: val loc = s (CLASSleft, cexpright) adamc@563: val c = (CAbs (SYMBOL2, SOME kind, cexp), loc) adamc@563: in adamc@563: [(DClass (SYMBOL1, kind, c), s (CLASSleft, cexpright))] adamc@211: end) adamc@459: | COOKIE SYMBOL COLON cexp ([(DCookie (SYMBOL, cexp), s (COOKIEleft, cexpright))]) adamc@720: | STYLE SYMBOL ([(DStyle SYMBOL, s (STYLEleft, SYMBOLright))]) adamc@1075: | TASK eapps EQ eexp ([(DTask (eapps, eexp), s (TASKleft, eexpright))]) adamc@1199: | POLICY eexp ([(DPolicy eexp, s (POLICYleft, eexpright))]) adamc@30: adamc@805: dtype : SYMBOL dargs EQ barOpt dcons (SYMBOL, dargs, dcons) adamc@805: adamc@805: dtypes : dtype ([dtype]) adamc@805: | dtype AND dtypes (dtype :: dtypes) adamc@805: adamc@240: kopt : (NONE) adamc@240: | DCOLON kind (SOME kind) adam@1302: | DCOLONWILD (SOME (KWild, s (DCOLONWILDleft, DCOLONWILDright))) adamc@240: adamc@191: dargs : ([]) adamc@191: | SYMBOL dargs (SYMBOL :: dargs) adamc@191: adamc@156: barOpt : () adamc@156: | BAR () adamc@156: adamc@156: dcons : dcon ([dcon]) adamc@156: | dcon BAR dcons (dcon :: dcons) adamc@156: adamc@156: dcon : CSYMBOL (CSYMBOL, NONE) adamc@156: | CSYMBOL OF cexp (CSYMBOL, SOME cexp) adamc@156: adamc@242: vali : SYMBOL eargl2 copt EQ eexp (let adamc@242: val loc = s (SYMBOLleft, eexpright) adamc@242: val t = Option.getOpt (copt, (CWild (KType, loc), loc)) adamc@242: adamc@242: val (e, t) = eargl2 (eexp, t) adamc@242: in adamc@242: (SYMBOL, SOME t, e) adamc@242: end) adamc@242: adamc@242: copt : (NONE) adamc@242: | COLON cexp (SOME cexp) adamc@123: adamc@704: cstopt : (EVar (["Basis"], "no_constraint", Infer), dummy) adamc@704: | csts (csts) adamc@704: adamc@704: csts : CCONSTRAINT tname cst (let adamc@704: val loc = s (CCONSTRAINTleft, cstright) adamc@704: adamc@704: val e = (EVar (["Basis"], "one_constraint", Infer), loc) adamc@704: val e = (ECApp (e, tname), loc) adamc@704: in adamc@704: (EApp (e, cst), loc) adamc@704: end) adamc@704: | csts COMMA csts (let adamc@704: val loc = s (csts1left, csts2right) adamc@704: adamc@704: val e = (EVar (["Basis"], "join_constraints", Infer), loc) adamc@704: val e = (EApp (e, csts1), loc) adamc@704: in adamc@704: (EApp (e, csts2), loc) adamc@704: end) adamc@704: | LBRACE LBRACE eexp RBRACE RBRACE (eexp) adamc@704: adamc@704: cst : UNIQUE tnames (let adamc@704: val loc = s (UNIQUEleft, tnamesright) adamc@704: adamc@704: val e = (EVar (["Basis"], "unique", Infer), loc) adamc@705: val e = (ECApp (e, #1 (#1 tnames)), loc) adamc@705: val e = (ECApp (e, (CRecord (#2 tnames), loc)), loc) adamc@704: in adamc@1093: e adamc@704: end) adamc@709: adamc@714: | CHECK sqlexp (let adamc@714: val loc = s (CHECKleft, sqlexpright) adamc@714: in adamc@714: (EApp ((EVar (["Basis"], "check", Infer), loc), adamc@714: sqlexp), loc) adamc@714: end) adamc@714: adamc@709: | FOREIGN KEY tnames REFERENCES texp LPAREN tnames' RPAREN pmodes adamc@709: (let adamc@709: val loc = s (FOREIGNleft, pmodesright) adamc@709: adamc@709: val mat = ListPair.foldrEq adamc@709: (fn ((nm1, _), (nm2, _), mat) => adamc@709: let adamc@709: val e = (EVar (["Basis"], "mat_cons", Infer), loc) adamc@709: val e = (ECApp (e, nm1), loc) adamc@709: val e = (ECApp (e, nm2), loc) adamc@709: in adamc@709: (EApp (e, mat), loc) adamc@709: end) adamc@709: (EVar (["Basis"], "mat_nil", Infer), loc) adamc@709: (#1 tnames :: #2 tnames, #1 tnames' :: #2 tnames') adam@1401: handle ListPair.UnequalLengths => adam@1401: (ErrorMsg.errorAt loc ("Unequal foreign key list lengths (" adam@1401: ^ Int.toString (1 + length (#2 tnames)) adam@1401: ^ " vs. " adam@1401: ^ Int.toString (1 + length (#2 tnames')) adam@1401: ^ ")"); adam@1401: (EVar (["Basis"], "mat_nil", Infer), loc)) adamc@709: adamc@709: fun findMode mode = adamc@709: let adamc@709: fun findMode' pmodes = adamc@709: case pmodes of adamc@709: [] => (EVar (["Basis"], "no_action", Infer), loc) adamc@709: | (mode', rule) :: pmodes' => adamc@709: if mode' = mode then adamc@709: (if List.exists (fn (mode', _) => mode' = mode) adamc@709: pmodes' then adamc@709: ErrorMsg.errorAt loc "Duplicate propagation rule" adamc@709: else adamc@709: (); adamc@709: rule) adamc@709: else adamc@709: findMode' pmodes' adamc@709: in adamc@709: findMode' pmodes adamc@709: end adamc@709: adamc@709: val e = (EVar (["Basis"], "foreign_key", Infer), loc) adamc@709: val e = (EApp (e, mat), loc) adamc@709: val e = (EApp (e, texp), loc) adamc@709: in adamc@709: (EApp (e, (ERecord [((CName "OnDelete", loc), adamc@709: findMode Delete), adamc@709: ((CName "OnUpdate", loc), adamc@709: findMode Update)], loc)), loc) adamc@709: end) adamc@709: adamc@704: | LBRACE eexp RBRACE (eexp) adamc@704: adamc@704: tnameW : tname (let adamc@704: val loc = s (tnameleft, tnameright) adamc@704: in adamc@704: (tname, (CWild (KType, loc), loc)) adamc@704: end) adamc@704: adamc@705: tnames : tnameW (tnameW, []) adamc@705: | LPAREN tnames' RPAREN (tnames') adamc@704: adamc@705: tnames': tnameW (tnameW, []) adamc@705: | tnameW COMMA tnames' (#1 tnames', tnameW :: #2 tnames') adamc@704: adamc@709: pmode : ON pkind prule (pkind, prule) adamc@709: adamc@709: pkind : DELETE (Delete) adamc@709: | UPDATE (Update) adamc@709: adamc@709: prule : NO ACTION (EVar (["Basis"], "no_action", Infer), s (NOleft, ACTIONright)) adamc@709: | RESTRICT (EVar (["Basis"], "restrict", Infer), s (RESTRICTleft, RESTRICTright)) adamc@709: | CASCADE (EVar (["Basis"], "cascade", Infer), s (CASCADEleft, CASCADEright)) adamc@709: | SET NULL (EVar (["Basis"], "set_null", Infer), s (SETleft, NULLright)) adamc@709: adamc@709: pmodes : ([]) adamc@709: | pmode pmodes (pmode :: pmodes) adamc@709: adamc@707: commaOpt: () adamc@707: | COMMA () adamc@707: adam@1722: pk : LBRACE LBRACE eexp RBRACE RBRACE (eexp) adam@1722: | tnames (let adam@1722: val loc = s (tnamesleft, tnamesright) adamc@707: adamc@1093: val e = (EVar (["Basis"], "primary_key", TypesOnly), loc) adamc@707: val e = (ECApp (e, #1 (#1 tnames)), loc) adamc@707: val e = (ECApp (e, (CRecord (#2 tnames), loc)), loc) adamc@707: val e = (EDisjointApp e, loc) adamc@707: val e = (EDisjointApp e, loc) adamc@707: adamc@707: val witness = map (fn (c, _) => adamc@707: (c, (EWild, loc))) adamc@707: (#1 tnames :: #2 tnames) adamc@707: val witness = (ERecord witness, loc) adamc@707: in adamc@707: (EApp (e, witness), loc) adamc@707: end) adamc@707: adam@1722: pkopt : (EVar (["Basis"], "no_primary_key", Infer), dummy) adam@1722: | PRIMARY KEY pk (pk) adam@1722: adamc@123: valis : vali ([vali]) adamc@123: | vali AND valis (vali :: valis) adamc@123: adamc@42: sgn : sgntm (sgntm) adamc@40: | FUNCTOR LPAREN CSYMBOL COLON sgn RPAREN COLON sgn adamc@40: (SgnFun (CSYMBOL, sgn1, sgn2), s (FUNCTORleft, sgn2right)) adamc@30: adamc@42: sgntm : SIG sgis END (SgnConst sgis, s (SIGleft, ENDright)) adamc@59: | mpath (case mpath of adamc@61: [] => raise Fail "Impossible mpath parse [2]" adamc@59: | [x] => SgnVar x adamc@59: | m :: ms => SgnProj (m, adamc@59: List.take (ms, length ms - 1), adamc@59: List.nth (ms, length ms - 1)), adamc@59: s (mpathleft, mpathright)) adamc@42: | sgntm WHERE CON SYMBOL EQ cexp (SgnWhere (sgntm, SYMBOL, cexp), s (sgntmleft, cexpright)) adamc@42: | sgntm WHERE LTYPE SYMBOL EQ cexp(SgnWhere (sgntm, SYMBOL, cexp), s (sgntmleft, cexpright)) adamc@42: | LPAREN sgn RPAREN (sgn) adamc@42: adam@1577: cexpO : (NONE) adam@1577: | EQ cexp (SOME cexp) adam@1577: adam@1577: sgi : LTYPE SYMBOL ((SgiConAbs (SYMBOL, (KType, s (LTYPEleft, SYMBOLright))), adamc@706: s (LTYPEleft, SYMBOLright))) adam@1577: | CON SYMBOL cargl2 kopt cexpO (let adam@1577: val loc = s (CONleft, cexpOright) adam@1574: adam@1574: val k = Option.getOpt (kopt, (KWild, loc)) adam@1574: in adam@1577: case cexpO of adam@1577: NONE => (SgiConAbs (SYMBOL, k), loc) adam@1577: | SOME cexp => adam@1577: let adam@1577: val (c, k) = cargl2 (cexp, k) adam@1577: in adam@1577: (SgiCon (SYMBOL, SOME k, c), loc) adam@1577: end adam@1574: end) adam@1654: | LTYPE SYMBOL cargl2 cexpO (let adam@1654: val loc = s (LTYPEleft, cexpOright) adam@1654: adam@1654: val k = (KWild, loc) adam@1654: in adam@1654: case cexpO of adam@1654: NONE => (SgiConAbs (SYMBOL, k), loc) adam@1654: | SOME cexp => adam@1654: let adam@1654: val (c, k) = cargl2 (cexp, k) adam@1654: in adam@1654: (SgiCon (SYMBOL, SOME k, c), loc) adam@1654: end adam@1654: end) adamc@805: | DATATYPE dtypes ((SgiDatatype dtypes, s (DATATYPEleft, dtypesright))) adamc@191: | DATATYPE SYMBOL dargs EQ DATATYPE CSYMBOL DOT path adamc@191: (case dargs of adamc@191: [] => (SgiDatatypeImp (SYMBOL, CSYMBOL :: #1 path, #2 path), s (DATATYPEleft, pathright)) adamc@191: | _ => raise Fail "Arguments specified for imported datatype") adamc@706: | VAL SYMBOL COLON cexp ((SgiVal (SYMBOL, cexp), s (VALleft, cexpright))) adamc@30: adamc@706: | STRUCTURE CSYMBOL COLON sgn ((SgiStr (CSYMBOL, sgn), s (STRUCTUREleft, sgnright))) adamc@706: | SIGNATURE CSYMBOL EQ sgn ((SgiSgn (CSYMBOL, sgn), s (SIGNATUREleft, sgnright))) adamc@42: | FUNCTOR CSYMBOL LPAREN CSYMBOL COLON sgn RPAREN COLON sgn adamc@706: ((SgiStr (CSYMBOL1, adamc@706: (SgnFun (CSYMBOL2, sgn1, sgn2), s (FUNCTORleft, sgn2right))), adamc@706: s (FUNCTORleft, sgn2right))) adamc@706: | INCLUDE sgn ((SgiInclude sgn, s (INCLUDEleft, sgnright))) adamc@706: | CONSTRAINT cterm TWIDDLE cterm ((SgiConstraint (cterm1, cterm2), s (CONSTRAINTleft, ctermright))) adamc@707: | TABLE SYMBOL COLON cterm pkopt commaOpt cstopt (let adamc@707: val loc = s (TABLEleft, ctermright) adamc@707: in adamc@707: (SgiTable (SYMBOL, entable cterm, pkopt, cstopt), loc) adamc@707: end) adamc@460: | SEQUENCE SYMBOL (let adamc@460: val loc = s (SEQUENCEleft, SYMBOLright) adamc@460: val t = (CVar (["Basis"], "sql_sequence"), loc) adamc@460: in adamc@460: (SgiVal (SYMBOL, t), loc) adamc@460: end) adamc@754: | VIEW SYMBOL COLON cexp (let adamc@754: val loc = s (VIEWleft, cexpright) adamc@754: val t = (CVar (["Basis"], "sql_view"), loc) adamc@1076: val t = (CApp (t, entable cexp), loc) adamc@754: in adamc@754: (SgiVal (SYMBOL, t), loc) adamc@754: end) adamc@563: | CLASS SYMBOL (let adamc@563: val loc = s (CLASSleft, SYMBOLright) adamc@711: val k = (KArrow ((KType, loc), (KType, loc)), loc) adamc@563: in adamc@711: (SgiClassAbs (SYMBOL, k), loc) adamc@563: end) adamc@563: | CLASS SYMBOL DCOLON kind (let adamc@563: val loc = s (CLASSleft, kindright) adamc@563: in adamc@563: (SgiClassAbs (SYMBOL, kind), loc) adamc@563: end) adamc@563: | CLASS SYMBOL EQ cexp (let adamc@563: val loc = s (CLASSleft, cexpright) adamc@563: in adamc@563: (SgiClass (SYMBOL, (KWild, loc), cexp), loc) adamc@563: end) adamc@563: | CLASS SYMBOL DCOLON kind EQ cexp (let adamc@563: val loc = s (CLASSleft, cexpright) adamc@563: in adamc@563: (SgiClass (SYMBOL, kind, cexp), loc) adamc@563: end) adamc@211: | CLASS SYMBOL SYMBOL EQ cexp (let adamc@211: val loc = s (CLASSleft, cexpright) adamc@563: val k = (KWild, loc) adamc@211: val c = (CAbs (SYMBOL2, SOME k, cexp), loc) adamc@211: in adamc@563: (SgiClass (SYMBOL1, k, c), s (CLASSleft, cexpright)) adamc@563: end) adamc@563: | CLASS SYMBOL LPAREN SYMBOL DCOLON kind RPAREN EQ cexp (let adamc@563: val loc = s (CLASSleft, cexpright) adamc@563: val c = (CAbs (SYMBOL2, SOME kind, cexp), loc) adamc@563: in adamc@563: (SgiClass (SYMBOL1, kind, c), s (CLASSleft, cexpright)) adamc@211: end) adamc@460: | COOKIE SYMBOL COLON cexp (let adamc@460: val loc = s (COOKIEleft, cexpright) adamc@460: val t = (CApp ((CVar (["Basis"], "http_cookie"), loc), adamc@460: entable cexp), loc) adamc@460: in adamc@460: (SgiVal (SYMBOL, t), loc) adamc@460: end) adamc@720: | STYLE SYMBOL (let adamc@720: val loc = s (STYLEleft, SYMBOLright) adamc@720: val t = (CVar (["Basis"], "css_class"), loc) adamc@718: in adamc@718: (SgiVal (SYMBOL, t), loc) adamc@718: end) adamc@30: adamc@30: sgis : ([]) adamc@30: | sgi sgis (sgi :: sgis) adamc@30: adamc@30: str : STRUCT decls END (StrConst decls, s (STRUCTleft, ENDright)) adamc@34: | spath (spath) adamc@40: | FUNCTOR LPAREN CSYMBOL COLON sgn RPAREN DARROW str adamc@40: (StrFun (CSYMBOL, sgn, NONE, str), s (FUNCTORleft, strright)) adamc@40: | FUNCTOR LPAREN CSYMBOL COLON sgn RPAREN COLON sgn DARROW str adamc@40: (StrFun (CSYMBOL, sgn1, SOME sgn2, str), s (FUNCTORleft, strright)) adamc@44: | spath LPAREN str RPAREN (StrApp (spath, str), s (spathleft, RPARENright)) adamc@34: adamc@34: spath : CSYMBOL (StrVar CSYMBOL, s (CSYMBOLleft, CSYMBOLright)) adamc@34: | spath DOT CSYMBOL (StrProj (spath, CSYMBOL), s (spathleft, CSYMBOLright)) adamc@30: adamc@1: kind : TYPE (KType, s (TYPEleft, TYPEright)) adamc@1: | NAME (KName, s (NAMEleft, NAMEright)) adamc@1: | LBRACE kind RBRACE (KRecord kind, s (LBRACEleft, RBRACEright)) adamc@1: | kind ARROW kind (KArrow (kind1, kind2), s (kind1left, kind2right)) adamc@1: | LPAREN kind RPAREN (#1 kind, s (LPARENleft, RPARENright)) adamc@82: | KUNIT (KUnit, s (KUNITleft, KUNITright)) adamc@18: | UNDERUNDER (KWild, s (UNDERUNDERleft, UNDERUNDERright)) adamc@207: | LPAREN ktuple RPAREN (KTuple ktuple, s (LPARENleft, RPARENright)) adamc@623: | CSYMBOL (KVar CSYMBOL, s (CSYMBOLleft, CSYMBOLright)) adamc@623: | CSYMBOL KARROW kind (KFun (CSYMBOL, kind), s (CSYMBOLleft, kindright)) adamc@207: adamc@207: ktuple : kind STAR kind ([kind1, kind2]) adamc@207: | kind STAR ktuple (kind :: ktuple) adamc@1: adamc@1: capps : cterm (cterm) adamc@1: | capps cterm (CApp (capps, cterm), s (cappsleft, ctermright)) adamc@1: adamc@1: cexp : capps (capps) adamc@1: | cexp ARROW cexp (TFun (cexp1, cexp2), s (cexp1left, cexp2right)) adamc@15: | SYMBOL kcolon kind ARROW cexp (TCFun (kcolon, SYMBOL, kind, cexp), s (SYMBOLleft, cexpright)) adamc@623: | CSYMBOL KARROW cexp (TKFun (CSYMBOL, cexp), s (CSYMBOLleft, cexpright)) adamc@1: adamc@1: | cexp PLUSPLUS cexp (CConcat (cexp1, cexp2), s (cexp1left, cexp1right)) adamc@1: adamc@239: | FN cargs DARROW cexp (#1 (cargs (cexp, (KWild, s (FNleft, cexpright))))) adamc@628: | LBRACK cexp TWIDDLE cexp RBRACK DARROW cexp (TDisjoint (cexp1, cexp2, cexp3), s (LBRACKleft, cexp3right)) adamc@623: | CSYMBOL DKARROW cexp (CKAbs (CSYMBOL, cexp), s (CSYMBOLleft, cexpright)) adamc@1: adamc@8: | LPAREN cexp RPAREN DCOLON kind (CAnnot (cexp, kind), s (LPARENleft, kindright)) adamc@6: adamc@18: | UNDER DCOLON kind (CWild kind, s (UNDERleft, UNDERright)) adamc@195: | ctuple (let adamc@195: val loc = s (ctupleleft, ctupleright) adamc@195: in adamc@195: (TRecord (CRecord (ListUtil.mapi (fn (i, c) => adamc@195: ((CName (Int.toString (i + 1)), loc), adamc@195: c)) ctuple), adamc@195: loc), loc) adamc@195: end) adamc@18: adamc@1: kcolon : DCOLON (Explicit) adamc@1: | TCOLON (Implicit) adamc@1: adamc@239: cargs : carg (carg) adamc@239: | cargl (cargl) adamc@239: adamc@239: cargl : cargp cargp (cargp1 o cargp2) adamc@239: | cargp cargl (cargp o cargl) adamc@239: adamc@240: cargl2 : (fn x => x) adamc@240: | cargp cargl2 (cargp o cargl2) adamc@240: adamc@241: carg : SYMBOL DCOLON kind (fn (c, k) => adamc@239: let adamc@239: val loc = s (SYMBOLleft, kindright) adamc@239: in adamc@239: ((CAbs (SYMBOL, SOME kind, c), loc), adamc@239: (KArrow (kind, k), loc)) adamc@239: end) adamc@329: | UNDER DCOLON kind (fn (c, k) => adamc@329: let adamc@329: val loc = s (UNDERleft, kindright) adamc@329: in adamc@329: ((CAbs ("_", SOME kind, c), loc), adamc@329: (KArrow (kind, k), loc)) adamc@329: end) adam@1302: | SYMBOL DCOLONWILD (fn (c, k) => adam@1302: let adam@1302: val loc = s (SYMBOLleft, DCOLONWILDright) adam@1302: val kind = (KWild, loc) adam@1302: in adam@1302: ((CAbs (SYMBOL, NONE, c), loc), adam@1302: (KArrow (kind, k), loc)) adam@1302: end) adam@1302: | UNDER DCOLONWILD (fn (c, k) => adam@1302: let adam@1302: val loc = s (UNDERleft, DCOLONWILDright) adam@1302: val kind = (KWild, loc) adam@1302: in adam@1302: ((CAbs ("_", NONE, c), loc), adam@1302: (KArrow (kind, k), loc)) adam@1302: end) adamc@241: | cargp (cargp) adamc@239: adamc@239: cargp : SYMBOL (fn (c, k) => adamc@239: let adamc@239: val loc = s (SYMBOLleft, SYMBOLright) adamc@239: in adamc@239: ((CAbs (SYMBOL, NONE, c), loc), adamc@239: (KArrow ((KWild, loc), k), loc)) adamc@239: end) adamc@329: | UNDER (fn (c, k) => adamc@329: let adamc@329: val loc = s (UNDERleft, UNDERright) adamc@329: in adamc@329: ((CAbs ("_", NONE, c), loc), adamc@329: (KArrow ((KWild, loc), k), loc)) adamc@329: end) adamc@1001: | LPAREN SYMBOL kopt ckl RPAREN (fn (c, k) => adamc@239: let adamc@239: val loc = s (LPARENleft, RPARENright) adamc@1001: val ckl = (SYMBOL, kopt) :: ckl adamc@1001: val ckl = map (fn (x, ko) => (x, case ko of adamc@1001: NONE => (KWild, loc) adamc@1001: | SOME k => k)) ckl adamc@239: in adamc@1001: case ckl of adamc@1001: [(x, k')] => ((CAbs (SYMBOL, SOME k', c), loc), adamc@1001: (KArrow (k', k), loc)) adamc@1001: | _ => adamc@1001: let adamc@1001: val k' = (KTuple (map #2 ckl), loc) adamc@1001: adamc@1001: val c = foldr (fn ((x, k), c) => adamc@1001: (CAbs (x, SOME k, c), loc)) c ckl adamc@1001: val v = (CVar ([], "$x"), loc) adamc@1001: val c = ListUtil.foldli (fn (i, _, c) => adamc@1001: (CApp (c, (CProj (v, i + 1), loc)), adamc@1001: loc)) c ckl adamc@1001: in adamc@1001: ((CAbs ("$x", SOME k', c), loc), adamc@1001: (KArrow (k', k), loc)) adamc@1001: end adamc@239: end) adamc@628: adamc@1001: ckl : ([]) adamc@1001: | COMMA SYMBOL kopt ckl ((SYMBOL, kopt) :: ckl) adamc@239: adamc@34: path : SYMBOL ([], SYMBOL) adamc@34: | CSYMBOL DOT path (let val (ms, x) = path in (CSYMBOL :: ms, x) end) adamc@34: adamc@156: cpath : CSYMBOL ([], CSYMBOL) adamc@156: | CSYMBOL DOT cpath (let val (ms, x) = cpath in (CSYMBOL :: ms, x) end) adamc@156: adamc@59: mpath : CSYMBOL ([CSYMBOL]) adamc@59: | CSYMBOL DOT mpath (CSYMBOL :: mpath) adamc@59: adamc@1: cterm : LPAREN cexp RPAREN (#1 cexp, s (LPARENleft, RPARENright)) adamc@1: | LBRACK rcon RBRACK (CRecord rcon, s (LBRACKleft, RBRACKright)) adamc@83: | LBRACK rconn RBRACK (CRecord rconn, s (LBRACKleft, RBRACKright)) adamc@1: | LBRACE rcone RBRACE (TRecord (CRecord rcone, s (LBRACEleft, RBRACEright)), adamc@1: s (LBRACEleft, RBRACEright)) adamc@1: | DOLLAR cterm (TRecord cterm, s (DOLLARleft, ctermright)) adamc@1: | HASH CSYMBOL (CName CSYMBOL, s (HASHleft, CSYMBOLright)) adamc@195: | HASH INT (CName (Int64.toString INT), s (HASHleft, INTright)) adamc@1: adamc@34: | path (CVar path, s (pathleft, pathright)) adamc@207: | path DOT INT (CProj ((CVar path, s (pathleft, pathright)), Int64.toInt INT), adamc@207: s (pathleft, INTright)) adamc@18: | UNDER (CWild (KWild, s (UNDERleft, UNDERright)), s (UNDERleft, UNDERright)) adamc@621: | MAP (CMap, s (MAPleft, MAPright)) adamc@82: | UNIT (CUnit, s (UNITleft, UNITright)) adamc@207: | LPAREN ctuplev RPAREN (CTuple ctuplev, s (LPARENleft, RPARENright)) adamc@207: adamc@207: ctuplev: cexp COMMA cexp ([cexp1, cexp2]) adamc@207: | cexp COMMA ctuplev (cexp :: ctuplev) adamc@1: adamc@196: ctuple : capps STAR capps ([capps1, capps2]) adamc@196: | capps STAR ctuple (capps :: ctuple) adamc@195: adamc@1: rcon : ([]) adamc@1: | ident EQ cexp ([(ident, cexp)]) adamc@1: | ident EQ cexp COMMA rcon ((ident, cexp) :: rcon) adamc@1: adamc@83: rconn : ident ([(ident, (CUnit, s (identleft, identright)))]) adamc@83: | ident COMMA rconn ((ident, (CUnit, s (identleft, identright))) :: rconn) adamc@83: adamc@1: rcone : ([]) adamc@1: | ident COLON cexp ([(ident, cexp)]) adamc@1: | ident COLON cexp COMMA rcone ((ident, cexp) :: rcone) adamc@1: adamc@1: ident : CSYMBOL (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright)) adamc@195: | INT (CName (Int64.toString INT), s (INTleft, INTright)) adamc@200: | SYMBOL (CVar ([], SYMBOL), s (SYMBOLleft, SYMBOLright)) adamc@8: adamc@8: eapps : eterm (eterm) adamc@8: | eapps eterm (EApp (eapps, eterm), s (eappsleft, etermright)) adamc@8: | eapps LBRACK cexp RBRACK (ECApp (eapps, cexp), s (eappsleft, RBRACKright)) adamc@629: | eapps BANG (EDisjointApp eapps, s (eappsleft, BANGright)) adamc@8: adam@1751: eexp : eapps (case #1 eapps of adam@1751: EApp ((EVar ([], "CLASS", _), _), (EPrim (Prim.String s), loc)) => parseClass s loc adam@1751: | EApp ((EVar ([], "STYLE", _), _), (EPrim (Prim.String s), loc)) => parseStyle s loc adam@1751: | _ => eapps) adamc@241: | FN eargs DARROW eexp (let adamc@93: val loc = s (FNleft, eexpright) adamc@93: in adamc@241: #1 (eargs (eexp, (CWild (KType, loc), loc))) adamc@93: end) adamc@623: | CSYMBOL DKARROW eexp (EKAbs (CSYMBOL, eexp), s (CSYMBOLleft, eexpright)) adamc@196: | eexp COLON cexp (EAnnot (eexp, cexp), s (eexpleft, cexpright)) adamc@149: | eexp MINUSMINUS cexp (ECut (eexp, cexp), s (eexpleft, cexpright)) adamc@493: | eexp MINUSMINUSMINUS cexp (ECutMulti (eexp, cexp), s (eexpleft, cexpright)) adamc@170: | CASE eexp OF barOpt branch branchs (ECase (eexp, branch :: branchs), s (CASEleft, branchsright)) adamc@190: | IF eexp THEN eexp ELSE eexp (let adamc@190: val loc = s (IFleft, eexp3right) adamc@190: in adamc@190: (ECase (eexp1, [((PCon (["Basis"], "True", NONE), loc), eexp2), adamc@190: ((PCon (["Basis"], "False", NONE), loc), eexp3)]), loc) adamc@190: end) adamc@434: | bind SEMI eexp (let adamc@434: val loc = s (bindleft, eexpright) adamc@434: val (v, to, e1) = bind adamc@403: val e = (EVar (["Basis"], "bind", Infer), loc) adamc@434: val e = (EApp (e, e1), loc) adamc@243: in adamc@434: (EApp (e, (EAbs (v, to, eexp), loc)), loc) adamc@299: end) adamc@256: | eexp EQ eexp (native_op ("eq", eexp1, eexp2, s (eexp1left, eexp2right))) adamc@257: | eexp NE eexp (native_op ("ne", eexp1, eexp2, s (eexp1left, eexp2right))) adamc@389: | MINUS eterm (native_unop ("neg", eterm, s (MINUSleft, etermright))) adamc@389: | eexp PLUS eexp (native_op ("plus", eexp1, eexp2, s (eexp1left, eexp2right))) adamc@389: | eexp MINUS eexp (native_op ("minus", eexp1, eexp2, s (eexp1left, eexp2right))) adamc@1116: | eapps STAR eexp (native_op ("times", eapps, eexp, s (eappsleft, eexpright))) adamc@964: | eexp DIVIDE eexp (native_op ("divide", eexp1, eexp2, s (eexp1left, eexp2right))) adamc@389: | eexp MOD eexp (native_op ("mod", eexp1, eexp2, s (eexp1left, eexp2right))) adamc@391: adamc@391: | eexp LT eexp (native_op ("lt", eexp1, eexp2, s (eexp1left, eexp2right))) adamc@391: | eexp LE eexp (native_op ("le", eexp1, eexp2, s (eexp1left, eexp2right))) adamc@391: | eexp GT eexp (native_op ("gt", eexp1, eexp2, s (eexp1left, eexp2right))) adamc@391: | eexp GE eexp (native_op ("ge", eexp1, eexp2, s (eexp1left, eexp2right))) adamc@391: adamc@842: | eexp ANDALSO eexp (let adamc@842: val loc = s (eexp1left, eexp2right) adamc@842: in adamc@842: (ECase (eexp1, [((PCon (["Basis"], "True", NONE), loc), adamc@842: eexp2), adamc@842: ((PCon (["Basis"], "False", NONE), loc), adamc@842: (EVar (["Basis"], "False", Infer), loc))]), loc) adamc@842: end) adamc@842: | eexp ORELSE eexp (let adamc@842: val loc = s (eexp1left, eexp2right) adamc@842: in adamc@842: (ECase (eexp1, [((PCon (["Basis"], "True", NONE), loc), adamc@842: (EVar (["Basis"], "True", Infer), loc)), adamc@842: ((PCon (["Basis"], "False", NONE), loc), adamc@842: eexp2)]), loc) adamc@842: end) adamc@842: adamc@445: | eexp PLUSPLUS eexp (EConcat (eexp1, eexp2), s (eexp1left, eexp2right)) adamc@8: adamc@674: | eexp CARET eexp (native_op ("strcat", eexp1, eexp2, s (eexp1left, eexp2right))) adamc@674: adamc@794: | eapps DCOLON eexp (let adamc@794: val loc = s (eappsleft, eexpright) adamc@762: in adamc@762: (EApp ((EVar (["Basis"], "Cons", Infer), loc), adamc@762: (ERecord [((CName "1", loc), adamc@794: eapps), adamc@762: ((CName "2", loc), adamc@762: eexp)], loc)), loc) adamc@762: end) adamc@762: adamc@434: bind : SYMBOL LARROW eapps (SYMBOL, NONE, eapps) adamc@434: | eapps (let adamc@434: val loc = s (eappsleft, eappsright) adamc@434: in adamc@434: ("_", SOME (TRecord (CRecord [], loc), loc), eapps) adamc@434: end) adamc@434: adamc@241: eargs : earg (earg) adamc@241: | eargl (eargl) adamc@241: adamc@241: eargl : eargp eargp (eargp1 o eargp2) adamc@241: | eargp eargl (eargp o eargl) adamc@241: adamc@242: eargl2 : (fn x => x) adamc@242: | eargp eargl2 (eargp o eargl2) adamc@242: adamc@822: earg : patS (fn (e, t) => adamc@241: let adamc@822: val loc = s (patSleft, patSright) adamc@822: val pt = patType loc patS adamc@822: adamc@822: val e' = case #1 patS of adamc@822: PVar x => (EAbs (x, NONE, e), loc) adamc@823: | PAnnot ((PVar x, _), t) => (EAbs (x, SOME t, e), loc) adamc@822: | _ => (EAbs ("$x", SOME pt, adamc@822: (ECase ((EVar ([], "$x", DontInfer), adamc@822: loc), adamc@822: [(patS, e)]), loc)), loc) adamc@241: in adamc@822: (e', (TFun (pt, t), loc)) adamc@241: end) adamc@822: | earga (earga) adamc@822: adamc@822: eargp : pterm (fn (e, t) => adamc@241: let adamc@822: val loc = s (ptermleft, ptermright) adamc@822: val pt = patType loc pterm adamc@822: adamc@822: val e' = case #1 pterm of adamc@822: PVar x => (EAbs (x, NONE, e), loc) adamc@823: | PAnnot ((PVar x, _), t) => (EAbs (x, SOME t, e), loc) adamc@822: | _ => (EAbs ("$x", SOME pt, adamc@822: (ECase ((EVar ([], "$x", DontInfer), adamc@822: loc), adamc@822: [(pterm, e)]), loc)), loc) adamc@241: in adamc@822: (e', (TFun (pt, t), loc)) adamc@241: end) adamc@822: | earga (earga) adamc@241: adamc@822: earga : LBRACK SYMBOL RBRACK (fn (e, t) => adamc@241: let adamc@822: val loc = s (LBRACKleft, RBRACKright) adamc@822: val kind = (KWild, loc) adamc@822: in adamc@822: ((ECAbs (Implicit, SYMBOL, kind, e), loc), adamc@822: (TCFun (Implicit, SYMBOL, kind, t), loc)) adamc@822: end) adam@1302: | LBRACK SYMBOL DCOLONWILD RBRACK (fn (e, t) => adam@1302: let adam@1302: val loc = s (LBRACKleft, RBRACKright) adam@1302: val kind = (KWild, loc) adam@1302: in adam@1302: ((ECAbs (Explicit, SYMBOL, kind, e), loc), adam@1302: (TCFun (Explicit, SYMBOL, kind, t), loc)) adam@1302: end) adamc@822: | LBRACK SYMBOL kcolon kind RBRACK(fn (e, t) => adamc@822: let adamc@822: val loc = s (LBRACKleft, RBRACKright) adamc@241: in adamc@241: ((ECAbs (kcolon, SYMBOL, kind, e), loc), adamc@241: (TCFun (kcolon, SYMBOL, kind, t), loc)) adamc@241: end) adam@1306: | LBRACK SYMBOL TCOLONWILD RBRACK (fn (e, t) => adam@1306: let adam@1306: val loc = s (LBRACKleft, RBRACKright) adam@1306: val kind = (KWild, loc) adam@1306: in adam@1306: ((ECAbs (Implicit, SYMBOL, kind, e), loc), adam@1306: (TCFun (Implicit, SYMBOL, kind, t), loc)) adam@1306: end) adamc@478: | LBRACK cexp TWIDDLE cexp RBRACK(fn (e, t) => adamc@356: let adamc@356: val loc = s (LBRACKleft, RBRACKright) adamc@356: in adamc@478: ((EDisjoint (cexp1, cexp2, e), loc), adamc@628: (TDisjoint (cexp1, cexp2, t), loc)) adamc@356: end) adamc@822: | LBRACK CSYMBOL RBRACK (fn (e, t) => adamc@623: let adamc@623: val loc = s (CSYMBOLleft, CSYMBOLright) adamc@623: in adamc@623: ((EKAbs (CSYMBOL, e), loc), adamc@623: (TKFun (CSYMBOL, t), loc)) adamc@623: end) adamc@241: adamc@8: eterm : LPAREN eexp RPAREN (#1 eexp, s (LPARENleft, RPARENright)) adamc@195: | LPAREN etuple RPAREN (let adamc@195: val loc = s (LPARENleft, RPARENright) adamc@195: in adamc@195: (ERecord (ListUtil.mapi (fn (i, e) => adamc@195: ((CName (Int.toString (i + 1)), loc), adamc@195: e)) etuple), loc) adamc@195: end) adamc@8: adamc@403: | path (EVar (#1 path, #2 path, Infer), s (pathleft, pathright)) adamc@403: | cpath (EVar (#1 cpath, #2 cpath, Infer), s (cpathleft, cpathright)) adamc@403: | AT path (EVar (#1 path, #2 path, TypesOnly), s (ATleft, pathright)) adamc@403: | AT AT path (EVar (#1 path, #2 path, DontInfer), s (AT1left, pathright)) adamc@403: | AT cpath (EVar (#1 cpath, #2 cpath, TypesOnly), s (ATleft, cpathright)) adamc@403: | AT AT cpath (EVar (#1 cpath, #2 cpath, DontInfer), s (AT1left, cpathright)) adamc@12: | LBRACE rexp RBRACE (ERecord rexp, s (LBRACEleft, RBRACEright)) adamc@110: | UNIT (ERecord [], s (UNITleft, UNITright)) adamc@12: adamc@14: | INT (EPrim (Prim.Int INT), s (INTleft, INTright)) adamc@14: | FLOAT (EPrim (Prim.Float FLOAT), s (FLOATleft, FLOATright)) adamc@14: | STRING (EPrim (Prim.String STRING), s (STRINGleft, STRINGright)) adamc@821: | CHAR (EPrim (Prim.Char CHAR), s (CHARleft, CHARright)) adamc@14: adamc@200: | path DOT idents (let adamc@200: val loc = s (pathleft, identsright) adamc@200: in adamc@200: foldl (fn (ident, e) => adamc@200: (EField (e, ident), loc)) adamc@403: (EVar (#1 path, #2 path, Infer), s (pathleft, pathright)) idents adamc@403: end) adamc@910: | LPAREN eexp RPAREN DOT idents (let adamc@910: val loc = s (LPARENleft, identsright) adamc@910: in adamc@910: foldl (fn (ident, e) => adamc@910: (EField (e, ident), loc)) adamc@910: eexp idents adamc@910: end) adamc@403: | AT path DOT idents (let adamc@403: val loc = s (ATleft, identsright) adamc@403: in adamc@403: foldl (fn (ident, e) => adamc@403: (EField (e, ident), loc)) adamc@403: (EVar (#1 path, #2 path, TypesOnly), s (pathleft, pathright)) idents adamc@403: end) adamc@403: | AT AT path DOT idents (let adamc@403: val loc = s (AT1left, identsright) adamc@403: in adamc@403: foldl (fn (ident, e) => adamc@403: (EField (e, ident), loc)) adamc@403: (EVar (#1 path, #2 path, DontInfer), s (pathleft, pathright)) idents adamc@200: end) adamc@71: adamc@360: | XML_BEGIN xml XML_END (let adamc@360: val loc = s (XML_BEGINleft, XML_ENDright) adamc@360: in adamc@360: if XML_BEGIN = "xml" then adamc@360: () adamc@360: else adamc@360: ErrorMsg.errorAt loc "Initial XML tag pair aren't both tagged \"xml\"."; adamc@360: xml adamc@360: end) adamc@360: | XML_BEGIN XML_END (let adamc@360: val loc = s (XML_BEGINleft, XML_ENDright) adamc@360: in adamc@360: if XML_BEGIN = "xml" then adamc@360: () adamc@360: else adamc@360: ErrorMsg.errorAt loc "Initial XML tag pair aren't both tagged \"xml\"."; adamc@403: (EApp ((EVar (["Basis"], "cdata", Infer), loc), adamc@360: (EPrim (Prim.String ""), loc)), adamc@360: loc) adamc@360: end) adamc@360: | XML_BEGIN_END (let adamc@360: val loc = s (XML_BEGIN_ENDleft, XML_BEGIN_ENDright) adamc@360: in adamc@360: if XML_BEGIN_END = "xml" then adamc@360: () adamc@360: else adamc@360: ErrorMsg.errorAt loc "Initial XML tag pair aren't both tagged \"xml\"."; adamc@403: (EApp ((EVar (["Basis"], "cdata", Infer), loc), adamc@360: (EPrim (Prim.String ""), loc)), adamc@360: loc) adamc@360: end) adamc@302: adamc@204: | LPAREN query RPAREN (query) adamc@300: | LPAREN CWHERE sqlexp RPAREN (sqlexp) adamc@339: | LPAREN SQL sqlexp RPAREN (sqlexp) adamc@1070: | LPAREN FROM tables RPAREN (#2 tables) adamc@1071: | LPAREN SELECT1 query1 RPAREN (query1) adamc@302: adamc@302: | LPAREN INSERT INTO texp LPAREN fields RPAREN VALUES LPAREN sqlexps RPAREN RPAREN adamc@302: (let adamc@302: val loc = s (LPAREN1left, RPAREN3right) adamc@302: adamc@403: val e = (EVar (["Basis"], "insert", Infer), loc) adamc@302: val e = (EApp (e, texp), loc) adamc@302: in adamc@302: if length fields <> length sqlexps then adam@1360: ErrorMsg.errorAt loc ("Length mismatch in INSERT field specification (" adam@1360: ^ Int.toString (length fields) adam@1360: ^ " vs. " ^ Int.toString (length sqlexps) ^ ")") adamc@302: else adamc@302: (); adamc@302: (EApp (e, (ERecord (ListPair.zip (fields, sqlexps)), loc)), loc) adamc@302: end) adamc@310: | LPAREN enterDml UPDATE texp SET fsets CWHERE sqlexp leaveDml RPAREN adamc@303: (let adamc@303: val loc = s (LPARENleft, RPARENright) adamc@303: adamc@403: val e = (EVar (["Basis"], "update", Infer), loc) adamc@342: val e = (ECApp (e, (CWild (KRecord (KType, loc), loc), loc)), loc) adamc@306: val e = (EApp (e, (ERecord fsets, loc)), loc) adamc@305: val e = (EApp (e, texp), loc) adamc@303: in adamc@303: (EApp (e, sqlexp), loc) adamc@303: end) adamc@310: | LPAREN enterDml DELETE FROM texp CWHERE sqlexp leaveDml RPAREN adamc@304: (let adamc@304: val loc = s (LPARENleft, RPARENright) adamc@304: adamc@403: val e = (EVar (["Basis"], "delete", Infer), loc) adamc@304: val e = (EApp (e, texp), loc) adamc@304: in adamc@304: (EApp (e, sqlexp), loc) adamc@304: end) adamc@302: adamc@211: | UNDER (EWild, s (UNDERleft, UNDERright)) adamc@91: adamc@446: | LET edecls IN eexp END (ELet (edecls, eexp), s (LETleft, ENDright)) adamc@446: adamc@762: | LBRACK RBRACK (EVar (["Basis"], "Nil", Infer), s (LBRACKleft, RBRACKright)) adamc@762: adamc@446: edecls : ([]) adamc@446: | edecl edecls (edecl :: edecls) adamc@446: adamc@825: edecl : VAL pat EQ eexp ((EDVal (pat, eexp), s (VALleft, eexpright))) adamc@446: | VAL REC valis ((EDValRec valis, s (VALleft, valisright))) adamc@446: | FUN valis ((EDValRec valis, s (FUNleft, valisright))) adamc@446: adamc@310: enterDml : (inDml := true) adamc@310: leaveDml : (inDml := false) adamc@310: adamc@403: texp : SYMBOL (EVar ([], SYMBOL, Infer), s (SYMBOLleft, SYMBOLright)) adamc@302: | LBRACE LBRACE eexp RBRACE RBRACE (eexp) adamc@302: adamc@302: fields : fident ([fident]) adamc@302: | fident COMMA fields (fident :: fields) adamc@302: adamc@302: sqlexps: sqlexp ([sqlexp]) adamc@302: | sqlexp COMMA sqlexps (sqlexp :: sqlexps) adamc@302: adamc@303: fsets : fident EQ sqlexp ([(fident, sqlexp)]) adamc@303: | fident EQ sqlexp COMMA fsets ((fident, sqlexp) :: fsets) adamc@303: adamc@200: idents : ident ([ident]) adamc@200: | ident DOT idents (ident :: idents) adamc@200: adamc@195: etuple : eexp COMMA eexp ([eexp1, eexp2]) adamc@195: | eexp COMMA etuple (eexp :: etuple) adamc@195: adamc@170: branch : pat DARROW eexp (pat, eexp) adamc@170: adamc@170: branchs: ([]) adamc@170: | BAR branch branchs (branch :: branchs) adamc@170: adamc@822: patS : pterm (pterm) adamc@822: | pterm DCOLON patS (let adamc@822: val loc = s (ptermleft, patSright) adamc@762: in adamc@762: (PCon (["Basis"], "Cons", SOME (PRecord ([("1", pterm), adamc@822: ("2", patS)], false), loc)), adamc@762: loc) adamc@762: end) adamc@822: | patS COLON cexp (PAnnot (patS, cexp), s (patSleft, cexpright)) adamc@822: adamc@822: pat : patS (patS) adamc@822: | cpath pterm (PCon (#1 cpath, #2 cpath, SOME pterm), s (cpathleft, ptermright)) adamc@170: adamc@170: pterm : SYMBOL (PVar SYMBOL, s (SYMBOLleft, SYMBOLright)) adamc@170: | cpath (PCon (#1 cpath, #2 cpath, NONE), s (cpathleft, cpathright)) adamc@170: | UNDER (PWild, s (UNDERleft, UNDERright)) adamc@173: | INT (PPrim (Prim.Int INT), s (INTleft, INTright)) adam@1420: | MINUS INT (PPrim (Prim.Int (~INT)), s (MINUSleft, INTright)) adamc@173: | STRING (PPrim (Prim.String STRING), s (STRINGleft, STRINGright)) adamc@821: | CHAR (PPrim (Prim.Char CHAR), s (CHARleft, CHARright)) adamc@170: | LPAREN pat RPAREN (pat) adamc@174: | LBRACE RBRACE (PRecord ([], false), s (LBRACEleft, RBRACEright)) adamc@174: | UNIT (PRecord ([], false), s (UNITleft, UNITright)) adamc@174: | LBRACE rpat RBRACE (PRecord rpat, s (LBRACEleft, RBRACEright)) adamc@195: | LPAREN ptuple RPAREN (PRecord (ListUtil.mapi (fn (i, p) => (Int.toString (i + 1), p)) ptuple, adamc@195: false), adamc@195: s (LPARENleft, RPARENright)) adamc@762: | LBRACK RBRACK (PCon (["Basis"], "Nil", NONE), s (LBRACKleft, RBRACKright)) adamc@174: adamc@175: rpat : CSYMBOL EQ pat ([(CSYMBOL, pat)], false) adamc@243: | INT EQ pat ([(Int64.toString INT, pat)], false) adamc@174: | DOTDOTDOT ([], true) adamc@175: | CSYMBOL EQ pat COMMA rpat ((CSYMBOL, pat) :: #1 rpat, #2 rpat) adamc@243: | INT EQ pat COMMA rpat ((Int64.toString INT, pat) :: #1 rpat, #2 rpat) adamc@170: adamc@195: ptuple : pat COMMA pat ([pat1, pat2]) adamc@195: | pat COMMA ptuple (pat :: ptuple) adamc@195: adamc@12: rexp : ([]) adamc@12: | ident EQ eexp ([(ident, eexp)]) adamc@12: | ident EQ eexp COMMA rexp ((ident, eexp) :: rexp) adamc@91: adamc@141: xml : xmlOne xml (let adamc@141: val pos = s (xmlOneleft, xmlright) adamc@141: in adamc@720: (EApp ((EApp ( adamc@720: (EVar (["Basis"], "join", Infer), pos), adamc@720: xmlOne), pos), adamc@720: xml), pos) adamc@141: end) adamc@141: | xmlOne (xmlOne) adamc@91: adamc@1045: xmlOpt : xml (xml) adamc@1045: | (EApp ((EVar (["Basis"], "cdata", Infer), dummy), adamc@1045: (EPrim (Prim.String ""), dummy)), adamc@1045: dummy) adamc@1045: adamc@403: xmlOne : NOTAGS (EApp ((EVar (["Basis"], "cdata", Infer), s (NOTAGSleft, NOTAGSright)), adamc@141: (EPrim (Prim.String NOTAGS), s (NOTAGSleft, NOTAGSright))), adamc@141: s (NOTAGSleft, NOTAGSright)) adamc@141: | tag DIVIDE GT (let adamc@141: val pos = s (tagleft, GTright) adamc@710: adamc@710: val cdata = adamc@756: if #1 (#1 tag) = "submit" orelse #1 (#1 tag) = "dyn" then adamc@710: let adamc@710: val e = (EVar (["Basis"], "cdata", DontInfer), pos) adamc@710: val e = (ECApp (e, (CWild (KWild, pos), pos)), pos) adamc@710: in adamc@710: (ECApp (e, (CRecord [], pos)), pos) adamc@710: end adamc@710: else adamc@710: (EVar (["Basis"], "cdata", Infer), pos) adamc@710: adamc@710: val cdata = (EApp (cdata, adamc@710: (EPrim (Prim.String ""), pos)), adamc@710: pos) adamc@141: in adam@1643: (EApp (#4 tag, cdata), pos) adamc@141: end) adamc@141: adamc@1045: | tag GT xmlOpt END_TAG (let adam@1563: fun tagOut s = adam@1563: case s of adam@1563: "tabl" => "table" adam@1563: | _ => s adam@1563: adamc@141: val pos = s (tagleft, GTright) adamc@325: val et = tagIn END_TAG adamc@141: in adamc@756: if #1 (#1 tag) = et then adamc@361: if et = "form" then adam@1412: let adam@1412: val e = (EVar (["Basis"], "form", Infer), pos) adam@1412: val e = (EApp (e, case #2 tag of adam@1412: NONE => (EVar (["Basis"], "None", Infer), pos) adam@1412: | SOME c => (EApp ((EVar (["Basis"], "Some", Infer), pos), c), pos)), pos) adam@1412: in adam@1651: case #3 tag of adam@1651: NONE => () adam@1651: | SOME _ => ErrorMsg.errorAt pos "
does not support 'dynClass' attribute"; adam@1412: (EApp (e, xmlOpt), pos) adam@1412: end adamc@1093: else if et = "subform" orelse et = "subforms" then adamc@1093: (EApp (#2 (#1 tag), adamc@1045: xmlOpt), pos) adamc@758: else if et = "entry" then adamc@758: (EApp ((EVar (["Basis"], "entry", Infer), pos), adamc@1045: xmlOpt), pos) adamc@141: else adam@1643: (EApp (#4 tag, xmlOpt), pos) adamc@141: else adamc@325: (if ErrorMsg.anyErrors () then adamc@325: () adamc@325: else adamc@1189: ErrorMsg.errorAt pos ("Begin tag <" adam@1563: ^ tagOut (#1 (#1 tag)) adamc@1189: ^ "> and end tag don't match."); adamc@623: (EWild, pos)) adamc@141: end) adamc@141: | LBRACE eexp RBRACE (eexp) adamc@391: | LBRACE LBRACK eexp RBRACK RBRACE (let adamc@391: val loc = s (LBRACEleft, RBRACEright) adamc@403: val e = (EVar (["Top"], "txt", Infer), loc) adamc@391: in adamc@391: (EApp (e, eexp), loc) adamc@391: end) adamc@92: adamc@141: tag : tagHead attrs (let adamc@141: val pos = s (tagHeadleft, attrsright) adamc@721: adamc@721: val e = (EVar (["Basis"], "tag", Infer), pos) adamc@721: val eo = case #1 attrs of adam@1749: NONE => (EVar (["Basis"], "null", Infer), pos) adam@1749: | SOME (EPrim (Prim.String s), pos) => parseClass s pos adam@1749: | SOME e => e adamc@721: val e = (EApp (e, eo), pos) adam@1643: val eo = case #2 attrs of adam@1643: NONE => (EVar (["Basis"], "None", Infer), pos) adam@1643: | SOME e => (EApp ((EVar (["Basis"], "Some", Infer), pos), adam@1643: e), pos) adam@1643: val e = (EApp (e, eo), pos) adam@1750: val eo = case #3 attrs of adam@1750: NONE => (EVar (["Basis"], "noStyle", Infer), pos) adam@1750: | SOME (EPrim (Prim.String s), pos) => parseStyle s pos adam@1750: | SOME e => e adam@1750: val e = (EApp (e, eo), pos) adam@1751: val eo = case #4 attrs of adam@1751: NONE => (EVar (["Basis"], "None", Infer), pos) adam@1751: | SOME e => (EApp ((EVar (["Basis"], "Some", Infer), pos), adam@1751: e), pos) adam@1751: val e = (EApp (e, eo), pos) adam@1751: val e = (EApp (e, (ERecord (#5 attrs), pos)), pos) adamc@721: val e = (EApp (e, (EApp (#2 tagHead, adamc@721: (ERecord [], pos)), pos)), pos) adamc@141: in adam@1643: (tagHead, #1 attrs, #2 attrs, e) adamc@141: end) adamc@141: adamc@141: tagHead: BEGIN_TAG (let adamc@325: val bt = tagIn BEGIN_TAG adamc@141: val pos = s (BEGIN_TAGleft, BEGIN_TAGright) adamc@141: in adamc@325: (bt, adamc@473: (EVar (["Basis"], bt, Infer), pos)) adamc@141: end) adamc@141: | tagHead LBRACE cexp RBRACE (#1 tagHead, (ECApp (#2 tagHead, cexp), s (tagHeadleft, RBRACEright))) adamc@92: adam@1751: attrs : (NONE, NONE, NONE, NONE, []) adamc@721: | attr attrs (let adamc@721: val loc = s (attrleft, attrsright) adamc@721: in adamc@721: case attr of adamc@721: Class e => adamc@721: (case #1 attrs of adamc@721: NONE => () adamc@721: | SOME _ => ErrorMsg.errorAt loc "Multiple classes specified for tag"; adam@1751: (SOME e, #2 attrs, #3 attrs, #4 attrs, #5 attrs)) adam@1643: | DynClass e => adam@1643: (case #2 attrs of adam@1643: NONE => () adam@1643: | SOME _ => ErrorMsg.errorAt loc "Multiple dynamic classes specified for tag"; adam@1751: (#1 attrs, SOME e, #3 attrs, #4 attrs, #5 attrs)) adam@1750: | Style e => adam@1750: (case #3 attrs of adam@1750: NONE => () adam@1750: | SOME _ => ErrorMsg.errorAt loc "Multiple styles specified for tag"; adam@1751: (#1 attrs, #2 attrs, SOME e, #4 attrs, #5 attrs)) adam@1751: | DynStyle e => adam@1751: (case #4 attrs of adam@1751: NONE => () adam@1751: | SOME _ => ErrorMsg.errorAt loc "Multiple dynamic classes specified for tag"; adam@1751: (#1 attrs, #2 attrs, #3 attrs, SOME e, #5 attrs)) adamc@721: | Normal xe => adam@1751: (#1 attrs, #2 attrs, #3 attrs, #4 attrs, xe :: #5 attrs) adamc@721: end) adamc@104: adam@1643: attr : SYMBOL EQ attrv (case SYMBOL of adam@1643: "class" => Class attrv adam@1643: | "dynClass" => DynClass attrv adam@1750: | "style" => Style attrv adam@1751: | "dynStyle" => DynStyle attrv adam@1643: | _ => adamc@724: let adamc@724: val sym = adamc@724: case SYMBOL of adamc@724: "type" => "Typ" adamc@724: | x => capitalize x adamc@724: in adamc@724: Normal ((CName sym, s (SYMBOLleft, SYMBOLright)), adamc@724: if (sym = "Href" orelse sym = "Src") adamc@724: andalso (case #1 attrv of adamc@724: EPrim _ => true adamc@724: | _ => false) then adamc@724: let adamc@724: val loc = s (attrvleft, attrvright) adamc@724: in adamc@724: (EApp ((EVar (["Basis"], "bless", Infer), loc), adamc@724: attrv), loc) adamc@724: end adamc@724: else adamc@724: attrv) adamc@724: end) adamc@204: adamc@104: attrv : INT (EPrim (Prim.Int INT), s (INTleft, INTright)) adamc@104: | FLOAT (EPrim (Prim.Float FLOAT), s (FLOATleft, FLOATright)) adamc@104: | STRING (EPrim (Prim.String STRING), s (STRINGleft, STRINGright)) adamc@110: | LBRACE eexp RBRACE (eexp) adamc@226: adamc@232: query : query1 obopt lopt ofopt (let adamc@229: val loc = s (query1left, query1right) adamc@230: adamc@230: val re = (ERecord [((CName "Rows", loc), adamc@230: query1), adamc@230: ((CName "OrderBy", loc), adamc@231: obopt), adamc@231: ((CName "Limit", loc), adamc@232: lopt), adamc@232: ((CName "Offset", loc), adamc@232: ofopt)], loc) adamc@229: in adamc@403: (EApp ((EVar (["Basis"], "sql_query", Infer), loc), re), loc) adamc@229: end) adamc@993: adamc@993: dopt : (EVar (["Basis"], "False", Infer), dummy) adamc@993: | DISTINCT (EVar (["Basis"], "True", Infer), adamc@993: s (DISTINCTleft, DISTINCTright)) adamc@993: adamc@993: query1 : SELECT dopt select FROM tables wopt gopt hopt adamc@209: (let adamc@204: val loc = s (SELECTleft, tablesright) adamc@207: adamc@1070: val (empties, sel, exps) = adamc@207: case select of adamc@1070: Star => ([], adamc@1070: map (fn nm => adamc@233: (nm, (CTuple [(CWild (KRecord (KType, loc), loc), adamc@233: loc), adamc@233: (CRecord [], loc)], adamc@748: loc))) (#1 tables), adamc@233: []) adamc@207: | Items sis => adamc@207: let adam@1627: val tabs = map (fn nm => (nm, Unknown)) (#1 tables) adamc@1194: val (_, tabs, exps) = foldl (amend_select loc) adamc@1194: (1, tabs, []) sis adam@1627: val empties = List.mapPartial (fn (nm, c) => adam@1627: case c of adam@1627: Unknown => SOME nm adam@1627: | Selective (CRecord [], _) => SOME nm adam@1627: | _ => NONE) tabs adamc@207: in adamc@1070: (empties, adamc@1070: map (fn (nm, c) => (nm, adam@1627: case c of adam@1627: Everything => adam@1627: (CTuple [(CWild (KRecord (KType, loc), loc), loc), adam@1627: (CRecord [], loc)], loc) adam@1627: | _ => adam@1627: let adam@1627: val c = case c of adam@1627: Selective c => c adam@1627: | _ => (CRecord [], loc) adam@1627: in adam@1627: (CTuple [c, adam@1627: (CWild (KRecord (KType, loc), loc), adam@1627: loc)], loc) adam@1627: end)) tabs, adamc@233: exps) adamc@207: end adamc@207: adamc@207: val sel = (CRecord sel, loc) adamc@207: adamc@226: val grp = case gopt of adamc@403: NONE => (ECApp ((EVar (["Basis"], "sql_subset_all", adamc@403: Infer), loc), adamc@226: (CWild (KRecord (KRecord (KType, loc), loc), adamc@226: loc), loc)), loc) adamc@226: | SOME gis => adamc@226: let adamc@748: val tabs = map (fn nm => adamc@748: (nm, (CRecord [], loc))) (#1 tables) adamc@226: val tabs = foldl (amend_group loc) tabs gis adamc@226: adamc@226: val tabs = map (fn (nm, c) => adamc@226: (nm, adamc@226: (CTuple [c, adamc@226: (CWild (KRecord (KType, loc), adamc@226: loc), adamc@226: loc)], loc))) tabs adamc@226: in adamc@403: (ECApp ((EVar (["Basis"], "sql_subset", Infer), loc), adamc@226: (CRecord tabs, loc)), loc) adamc@226: end adamc@226: adamc@403: val e = (EVar (["Basis"], "sql_query1", Infer), loc) adamc@1070: val e = (ECApp (e, (CRecord (map (fn nm => (nm, (CUnit, loc))) empties), adamc@1070: loc)), loc) adamc@993: val re = (ERecord [((CName "Distinct", loc), adamc@993: dopt), adamc@993: ((CName "From", loc), adamc@748: #2 tables), adamc@209: ((CName "Where", loc), adamc@223: wopt), adamc@224: ((CName "GroupBy", loc), adamc@226: grp), adamc@224: ((CName "Having", loc), adamc@224: hopt), adamc@223: ((CName "SelectFields", loc), adamc@403: (ECApp ((EVar (["Basis"], "sql_subset", Infer), loc), adamc@233: sel), loc)), adamc@233: ((CName "SelectExps", loc), adamc@233: (ERecord exps, loc))], loc) adamc@223: adamc@209: val e = (EApp (e, re), loc) adamc@204: in adamc@207: e adamc@204: end) adam@1427: | query1 UNION query1 (sql_relop ("union", false, query11, query12, s (query11left, query12right))) adam@1427: | query1 INTERSECT query1 (sql_relop ("intersect", false, query11, query12, s (query11left, query12right))) adam@1427: | query1 EXCEPT query1 (sql_relop ("except", false, query11, query12, s (query11left, query12right))) adam@1427: | query1 UNION ALL query1 (sql_relop ("union", true, query11, query12, s (query11left, query12right))) adam@1427: | query1 INTERSECT ALL query1 (sql_relop ("intersect", true, query11, query12, s (query11left, query12right))) adam@1427: | query1 EXCEPT ALL query1 (sql_relop ("except", true, query11, query12, s (query11left, query12right))) adamc@1070: | LBRACE LBRACE LBRACE eexp RBRACE RBRACE RBRACE (eexp) adamc@204: adamc@749: tables : fitem (fitem) adamc@749: | fitem COMMA tables (let adamc@749: val loc = s (fitemleft, tablesright) adamc@748: adamc@748: val e = (EVar (["Basis"], "sql_from_comma", Infer), loc) adamc@749: val e = (EApp (e, #2 fitem), loc) adamc@748: in adamc@749: (#1 fitem @ #1 tables, adamc@748: (EApp (e, #2 tables), loc)) adamc@748: end) adamc@204: adamc@749: fitem : table' ([#1 table'], #2 table') adamc@1265: | LBRACE LBRACE eexp RBRACE RBRACE (tnamesOf eexp, eexp) adamc@749: | fitem JOIN fitem ON sqlexp (let adamc@749: val loc = s (fitem1left, sqlexpright) adamc@749: adamc@749: val e = (EVar (["Basis"], "sql_inner_join", Infer), loc) adamc@749: val e = (EApp (e, #2 fitem1), loc) adamc@749: val e = (EApp (e, #2 fitem2), loc) adamc@749: in adamc@749: (#1 fitem1 @ #1 fitem2, adamc@749: (EApp (e, sqlexp), loc)) adamc@749: end) adamc@749: | fitem INNER JOIN fitem ON sqlexp (let adamc@749: val loc = s (fitem1left, sqlexpright) adamc@749: adamc@749: val e = (EVar (["Basis"], "sql_inner_join", Infer), loc) adamc@749: val e = (EApp (e, #2 fitem1), loc) adamc@749: val e = (EApp (e, #2 fitem2), loc) adamc@749: in adamc@749: (#1 fitem1 @ #1 fitem2, adamc@749: (EApp (e, sqlexp), loc)) adamc@749: end) adamc@749: | fitem CROSS JOIN fitem (let adamc@749: val loc = s (fitem1left, fitem2right) adamc@749: adamc@749: val e = (EVar (["Basis"], "sql_inner_join", Infer), loc) adamc@749: val e = (EApp (e, #2 fitem1), loc) adamc@749: val e = (EApp (e, #2 fitem2), loc) adamc@749: val tru = sql_inject (EVar (["Basis"], "True", Infer), loc) adamc@749: in adamc@749: (#1 fitem1 @ #1 fitem2, adamc@749: (EApp (e, tru), loc)) adamc@749: end) adamc@750: | fitem LEFT JOIN fitem ON sqlexp (let adamc@750: val loc = s (fitem1left, sqlexpright) adamc@750: adamc@750: val e = (EVar (["Basis"], "sql_left_join", Infer), loc) adamc@750: val e = (EApp (e, #2 fitem1), loc) adamc@750: val e = (EApp (e, #2 fitem2), loc) adamc@750: in adamc@750: (#1 fitem1 @ #1 fitem2, adamc@750: (EApp (e, sqlexp), loc)) adamc@750: end) adamc@751: | fitem LEFT OUTER JOIN fitem ON sqlexp (let adamc@751: val loc = s (fitem1left, sqlexpright) adamc@751: adamc@751: val e = (EVar (["Basis"], "sql_left_join", Infer), loc) adamc@751: val e = (EApp (e, #2 fitem1), loc) adamc@751: val e = (EApp (e, #2 fitem2), loc) adamc@751: in adamc@751: (#1 fitem1 @ #1 fitem2, adamc@751: (EApp (e, sqlexp), loc)) adamc@751: end) adamc@751: | fitem RIGHT JOIN fitem ON sqlexp (let adamc@751: val loc = s (fitem1left, sqlexpright) adamc@751: adamc@751: val e = (EVar (["Basis"], "sql_right_join", Infer), loc) adamc@751: val e = (EApp (e, #2 fitem1), loc) adamc@751: val e = (EApp (e, #2 fitem2), loc) adamc@751: in adamc@751: (#1 fitem1 @ #1 fitem2, adamc@751: (EApp (e, sqlexp), loc)) adamc@751: end) adamc@751: | fitem RIGHT OUTER JOIN fitem ON sqlexp (let adamc@751: val loc = s (fitem1left, sqlexpright) adamc@751: adamc@751: val e = (EVar (["Basis"], "sql_right_join", Infer), loc) adamc@751: val e = (EApp (e, #2 fitem1), loc) adamc@751: val e = (EApp (e, #2 fitem2), loc) adamc@751: in adamc@751: (#1 fitem1 @ #1 fitem2, adamc@751: (EApp (e, sqlexp), loc)) adamc@751: end) adamc@751: | fitem FULL JOIN fitem ON sqlexp (let adamc@751: val loc = s (fitem1left, sqlexpright) adamc@751: adamc@751: val e = (EVar (["Basis"], "sql_full_join", Infer), loc) adamc@751: val e = (EApp (e, #2 fitem1), loc) adamc@751: val e = (EApp (e, #2 fitem2), loc) adamc@751: in adamc@751: (#1 fitem1 @ #1 fitem2, adamc@751: (EApp (e, sqlexp), loc)) adamc@751: end) adamc@751: | fitem FULL OUTER JOIN fitem ON sqlexp (let adamc@751: val loc = s (fitem1left, sqlexpright) adamc@751: adamc@751: val e = (EVar (["Basis"], "sql_full_join", Infer), loc) adamc@751: val e = (EApp (e, #2 fitem1), loc) adamc@751: val e = (EApp (e, #2 fitem2), loc) adamc@751: in adamc@751: (#1 fitem1 @ #1 fitem2, adamc@751: (EApp (e, sqlexp), loc)) adamc@751: end) adamc@1192: | LPAREN query RPAREN AS tname (let adamc@1192: val loc = s (LPARENleft, RPARENright) adamc@1192: adamc@1192: val e = (EVar (["Basis"], "sql_from_query", Infer), loc) adamc@1192: val e = (ECApp (e, tname), loc) adamc@1192: in adamc@1192: ([tname], (EApp (e, query), loc)) adamc@1192: end) adamc@749: adamc@204: tname : CSYMBOL (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright)) adamc@204: | LBRACE cexp RBRACE (cexp) adamc@204: adamc@243: table : SYMBOL ((CName (capitalize SYMBOL), s (SYMBOLleft, SYMBOLright)), adamc@403: (EVar ([], SYMBOL, Infer), s (SYMBOLleft, SYMBOLright))) adamc@403: | SYMBOL AS tname (tname, (EVar ([], SYMBOL, Infer), s (SYMBOLleft, SYMBOLright))) adamc@221: | LBRACE LBRACE eexp RBRACE RBRACE AS tname (tname, eexp) adamc@207: adamc@748: table' : table (let adamc@748: val loc = s (tableleft, tableright) adamc@748: val e = (EVar (["Basis"], "sql_from_table", Infer), loc) adamc@748: val e = (ECApp (e, #1 table), loc) adamc@748: in adamc@748: (#1 table, (EApp (e, #2 table), loc)) adamc@748: end) adamc@748: adamc@243: tident : SYMBOL (CName (capitalize SYMBOL), s (SYMBOLleft, SYMBOLright)) adamc@207: | CSYMBOL (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright)) adamc@221: | LBRACE LBRACE cexp RBRACE RBRACE (cexp) adamc@207: adamc@207: fident : CSYMBOL (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright)) adamc@207: | LBRACE cexp RBRACE (cexp) adamc@207: adamc@207: seli : tident DOT fident (Field (tident, fident)) adamc@1194: | sqlexp (Exp (NONE, sqlexp)) adamc@1194: | sqlexp AS fident (Exp (SOME fident, sqlexp)) adamc@341: | tident DOT LBRACE LBRACE cexp RBRACE RBRACE (Fields (tident, cexp)) adam@1627: | tident DOT STAR (StarFields tident) adamc@207: adamc@207: selis : seli ([seli]) adamc@207: | seli COMMA selis (seli :: selis) adamc@207: adamc@207: select : STAR (Star) adamc@207: | selis (Items selis) adamc@209: adamc@403: sqlexp : TRUE (sql_inject (EVar (["Basis"], "True", Infer), adamc@209: s (TRUEleft, TRUEright))) adamc@403: | FALSE (sql_inject (EVar (["Basis"], "False", Infer), adamc@209: s (FALSEleft, FALSEright))) adamc@209: adamc@222: | INT (sql_inject (EPrim (Prim.Int INT), adamc@222: s (INTleft, INTright))) adamc@222: | FLOAT (sql_inject (EPrim (Prim.Float FLOAT), adamc@222: s (FLOATleft, FLOATright))) adamc@229: | STRING (sql_inject (EPrim (Prim.String STRING), adamc@229: s (STRINGleft, STRINGright))) adamc@441: | CURRENT_TIMESTAMP (sql_nfunc ("current_timestamp", adamc@441: s (CURRENT_TIMESTAMPleft, CURRENT_TIMESTAMPright))) adamc@222: adamc@221: | tident DOT fident (let adamc@221: val loc = s (tidentleft, fidentright) adamc@403: val e = (EVar (["Basis"], "sql_field", Infer), loc) adamc@221: val e = (ECApp (e, tident), loc) adamc@221: in adamc@221: (ECApp (e, fident), loc) adamc@221: end) adamc@234: | CSYMBOL (let adamc@234: val loc = s (CSYMBOLleft, CSYMBOLright) adamc@310: in adamc@310: if !inDml then adamc@310: let adamc@403: val e = (EVar (["Basis"], "sql_field", Infer), loc) adamc@310: val e = (ECApp (e, (CName "T", loc)), loc) adamc@310: in adamc@310: (ECApp (e, (CName CSYMBOL, loc)), loc) adamc@310: end adamc@310: else adamc@310: let adamc@403: val e = (EVar (["Basis"], "sql_exp", Infer), loc) adamc@310: in adamc@310: (ECApp (e, (CName CSYMBOL, loc)), loc) adamc@310: end adamc@310: end) adamc@221: adamc@471: | LBRACE eexp RBRACE (eexp) adamc@470: adamc@559: | sqlexp EQ sqlexp (sql_binary ("eq", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) adamc@559: | sqlexp NE sqlexp (sql_binary ("ne", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) adamc@559: | sqlexp LT sqlexp (sql_binary ("lt", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) adamc@559: | sqlexp LE sqlexp (sql_binary ("le", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) adamc@559: | sqlexp GT sqlexp (sql_binary ("gt", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) adamc@559: | sqlexp GE sqlexp (sql_binary ("ge", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) adamc@559: adamc@559: | sqlexp PLUS sqlexp (sql_binary ("plus", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) adamc@559: | sqlexp MINUS sqlexp (sql_binary ("minus", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) adamc@559: | sqlexp STAR sqlexp (sql_binary ("times", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) adamc@559: | sqlexp DIVIDE sqlexp (sql_binary ("div", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) adamc@559: | sqlexp MOD sqlexp (sql_binary ("mod", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) adamc@219: adamc@220: | sqlexp CAND sqlexp (sql_binary ("and", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) adamc@220: | sqlexp OR sqlexp (sql_binary ("or", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) adamc@559: kkallio@1607: | sqlexp LIKE sqlexp (sql_binary ("like", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) kkallio@1607: adamc@220: | NOT sqlexp (sql_unary ("not", sqlexp, s (NOTleft, sqlexpright))) adamc@559: | MINUS sqlexp (sql_unary ("neg", sqlexp, s (MINUSleft, sqlexpright))) adamc@220: adamc@470: | sqlexp IS NULL (let adamc@470: val loc = s (sqlexpleft, NULLright) adamc@470: in adamc@470: (EApp ((EVar (["Basis"], "sql_is_null", Infer), loc), adamc@470: sqlexp), loc) adamc@470: end) adamc@470: kkallio@1572: | CIF sqlexp CTHEN sqlexp CELSE sqlexp (let kkallio@1572: val loc = s (CIFleft, sqlexp3right) kkallio@1572: val e = (EVar (["Basis"], "sql_if_then_else", Infer), loc) kkallio@1572: in kkallio@1572: (EApp ((EApp ((EApp (e, sqlexp1), loc), sqlexp2), loc), sqlexp3), loc) kkallio@1572: end) kkallio@1572: adamc@471: | LBRACE LBRACK eexp RBRACK RBRACE (sql_inject (#1 eexp, adamc@471: s (LBRACEleft, RBRACEright))) adamc@220: | LPAREN sqlexp RPAREN (sqlexp) adamc@210: adamc@467: | NULL (sql_inject ((EVar (["Basis"], "None", Infer), adamc@467: s (NULLleft, NULLright)))) adamc@467: adamc@235: | COUNT LPAREN STAR RPAREN (let adamc@235: val loc = s (COUNTleft, RPARENright) adamc@235: in adamc@544: (EVar (["Basis"], "sql_count", Infer), loc) adamc@235: end) adamc@1187: | COUNT LPAREN sqlexp RPAREN (let adamc@1187: val loc = s (COUNTleft, RPARENright) adamc@1187: adamc@1187: val e = (EVar (["Basis"], "sql_count_col", Infer), loc) adamc@1187: val e = (EApp ((EVar (["Basis"], "sql_aggregate", Infer), loc), adamc@1187: e), loc) adamc@1187: in adamc@1187: (EApp (e, sqlexp), loc) adamc@1187: end) adamc@236: | sqlagg LPAREN sqlexp RPAREN (let adamc@236: val loc = s (sqlaggleft, RPARENright) adamc@236: adamc@403: val e = (EVar (["Basis"], "sql_" ^ sqlagg, Infer), loc) adamc@403: val e = (EApp ((EVar (["Basis"], "sql_aggregate", Infer), loc), adamc@236: e), loc) adamc@236: in adamc@236: (EApp (e, sqlexp), loc) adamc@236: end) adam@1602: | COALESCE LPAREN sqlexp COMMA sqlexp RPAREN adam@1602: (let adam@1602: val loc = s (COALESCEright, sqlexp2right) adam@1602: val e = (EVar (["Basis"], "sql_coalesce", Infer), loc) adam@1602: val e = (EApp (e, sqlexp1), loc) adam@1602: in adam@1602: (EApp (e, sqlexp2), loc) adam@1602: end) adamc@746: | fname LPAREN sqlexp RPAREN (let adamc@746: val loc = s (fnameleft, RPARENright) adamc@746: adamc@746: val e = (EVar (["Basis"], "sql_ufunc", Infer), loc) adamc@746: val e = (EApp (e, fname), loc) adamc@746: in adamc@746: (EApp (e, sqlexp), loc) adamc@746: end) adamc@1191: | LPAREN query RPAREN (let adamc@1191: val loc = s (LPARENleft, RPARENright) adamc@1191: adamc@1191: val e = (EVar (["Basis"], "sql_subquery", Infer), loc) adamc@1191: in adamc@1191: (EApp (e, query), loc) adamc@1191: end) adamc@746: adamc@746: fname : SYMBOL (EVar (["Basis"], "sql_" ^ SYMBOL, Infer), s (SYMBOLleft, SYMBOLright)) adamc@746: | LBRACE eexp RBRACE (eexp) adamc@235: adamc@403: wopt : (sql_inject (EVar (["Basis"], "True", Infer), adamc@230: dummy)) adamc@209: | CWHERE sqlexp (sqlexp) adamc@226: adamc@226: groupi : tident DOT fident (GField (tident, fident)) adam@1425: | tident DOT LBRACE LBRACE cexp RBRACE RBRACE (GFields (tident, cexp)) adamc@226: adamc@226: groupis: groupi ([groupi]) adamc@226: | groupi COMMA groupis (groupi :: groupis) adamc@226: adamc@226: gopt : (NONE) adamc@226: | GROUP BY groupis (SOME groupis) adamc@227: adamc@403: hopt : (sql_inject (EVar (["Basis"], "True", Infer), adamc@230: dummy)) adamc@227: | HAVING sqlexp (sqlexp) adamc@230: adamc@403: obopt : (ECApp ((EVar (["Basis"], "sql_order_by_Nil", Infer), dummy), adamc@234: (CWild (KRecord (KType, dummy), dummy), dummy)), adamc@230: dummy) adamc@230: | ORDER BY obexps (obexps) adamc@230: adamc@268: obitem : sqlexp diropt (sqlexp, diropt) adamc@268: adamc@268: obexps : obitem (let adamc@268: val loc = s (obitemleft, obitemright) adamc@230: adamc@403: val e' = (ECApp ((EVar (["Basis"], "sql_order_by_Nil", Infer), loc), adamc@234: (CWild (KRecord (KType, loc), loc), loc)), adamc@230: loc) adamc@403: val e = (EApp ((EVar (["Basis"], "sql_order_by_Cons", Infer), loc), adamc@268: #1 obitem), loc) adamc@268: val e = (EApp (e, #2 obitem), loc) adamc@230: in adamc@230: (EApp (e, e'), loc) adamc@230: end) adamc@268: | obitem COMMA obexps (let adamc@268: val loc = s (obitemleft, obexpsright) adamc@230: adamc@403: val e = (EApp ((EVar (["Basis"], "sql_order_by_Cons", Infer), loc), adamc@268: #1 obitem), loc) adamc@268: val e = (EApp (e, #2 obitem), loc) adamc@230: in adamc@230: (EApp (e, obexps), loc) adamc@230: end) adam@1682: | RANDOM popt (EVar (["Basis"], "sql_order_by_random", Infer), s (RANDOMleft, poptright)) adam@1682: adam@1682: popt : () adam@1682: | LPAREN RPAREN () adam@1684: | UNIT () adamc@231: adamc@403: diropt : (EVar (["Basis"], "sql_asc", Infer), dummy) adamc@403: | ASC (EVar (["Basis"], "sql_asc", Infer), s (ASCleft, ASCright)) adamc@403: | DESC (EVar (["Basis"], "sql_desc", Infer), s (DESCleft, DESCright)) adam@1543: | LBRACE eexp RBRACE (eexp) adamc@268: adamc@403: lopt : (EVar (["Basis"], "sql_no_limit", Infer), dummy) adamc@403: | LIMIT ALL (EVar (["Basis"], "sql_no_limit", Infer), dummy) adamc@231: | LIMIT sqlint (let adamc@231: val loc = s (LIMITleft, sqlintright) adamc@231: in adamc@403: (EApp ((EVar (["Basis"], "sql_limit", Infer), loc), sqlint), loc) adamc@231: end) adamc@231: adamc@403: ofopt : (EVar (["Basis"], "sql_no_offset", Infer), dummy) adamc@232: | OFFSET sqlint (let adamc@232: val loc = s (OFFSETleft, sqlintright) adamc@232: in adamc@403: (EApp ((EVar (["Basis"], "sql_offset", Infer), loc), sqlint), loc) adamc@232: end) adamc@232: adamc@231: sqlint : INT (EPrim (Prim.Int INT), s (INTleft, INTright)) adamc@231: | LBRACE eexp RBRACE (eexp) adamc@236: adamc@236: sqlagg : AVG ("avg") adamc@236: | SUM ("sum") adamc@236: | MIN ("min") adamc@236: | MAX ("max")