diff options
Diffstat (limited to 'src/urweb.grm')
| -rw-r--r-- | src/urweb.grm | 1055 |
1 files changed, 1055 insertions, 0 deletions
diff --git a/src/urweb.grm b/src/urweb.grm new file mode 100644 index 00000000..aa062516 --- /dev/null +++ b/src/urweb.grm @@ -0,0 +1,1055 @@ +(* Copyright (c) 2008, Adam Chlipala + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * - Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * - Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * - The names of contributors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + *) + +(* Grammar for Ur/Web programs *) + +open Source + +val s = ErrorMsg.spanOf +val dummy = ErrorMsg.dummySpan + +fun capitalize "" = "" + | capitalize s = str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE) + +fun entable t = + case #1 t of + TRecord c => c + | _ => t + +datatype select_item = + Field of con * con + | Exp of con * exp + +datatype select = + Star + | Items of select_item list + +datatype group_item = + GField of con * con + +fun eqTnames ((c1, _), (c2, _)) = + case (c1, c2) of + (CVar (ms1, x1), CVar (ms2, x2)) => ms1 = ms2 andalso x1 = x2 + | (CName x1, CName x2) => x1 = x2 + | _ => false + +fun amend_select loc (si, (tabs, exps)) = + case si of + Field (tx, fx) => + let + val c = (CRecord ([(fx, (CWild (KType, loc), loc))]), loc) + + val (tabs, found) = ListUtil.foldlMap (fn ((tx', c'), found) => + if eqTnames (tx, tx') then + ((tx', (CConcat (c, c'), loc)), true) + else + ((tx', c'), found)) + false tabs + in + if found then + () + else + ErrorMsg.errorAt loc "Select of field from unbound table"; + + (tabs, exps) + end + | Exp (c, e) => (tabs, (c, e) :: exps) + +fun amend_group loc (gi, tabs) = + let + val (tx, c) = case gi of + GField (tx, fx) => (tx, (CRecord ([(fx, (CWild (KType, loc), loc))]), loc)) + + val (tabs, found) = ListUtil.foldlMap (fn ((tx', c'), found) => + if eqTnames (tx, tx') then + ((tx', (CConcat (c, c'), loc)), true) + else + ((tx', c'), found)) + false tabs + in + if found then + () + else + ErrorMsg.errorAt loc "Select of field from unbound table"; + + tabs + end + +fun sql_inject (v, t, loc) = + let + val e = (EApp ((EVar (["Basis"], "sql_inject"), loc), (t, loc)), loc) + in + (EApp (e, (v, loc)), loc) + end + +fun sql_compare (oper, sqlexp1, sqlexp2, loc) = + let + val e = (EVar (["Basis"], "sql_comparison"), loc) + val e = (EApp (e, (EVar (["Basis"], "sql_" ^ oper), loc)), loc) + val e = (EApp (e, sqlexp1), loc) + in + (EApp (e, sqlexp2), loc) + end + +fun sql_binary (oper, sqlexp1, sqlexp2, loc) = + let + val e = (EVar (["Basis"], "sql_binary"), loc) + val e = (EApp (e, (EVar (["Basis"], "sql_" ^ oper), loc)), loc) + val e = (EApp (e, sqlexp1), loc) + in + (EApp (e, sqlexp2), loc) + end + +fun sql_unary (oper, sqlexp, loc) = + let + val e = (EVar (["Basis"], "sql_unary"), loc) + val e = (EApp (e, (EVar (["Basis"], "sql_" ^ oper), loc)), loc) + in + (EApp (e, sqlexp), loc) + end + +fun sql_relop (oper, sqlexp1, sqlexp2, loc) = + let + val e = (EVar (["Basis"], "sql_relop"), loc) + val e = (EApp (e, (EVar (["Basis"], "sql_" ^ oper), loc)), loc) + val e = (EApp (e, sqlexp1), loc) + in + (EApp (e, sqlexp2), loc) + end + +%% +%header (functor UrwebLrValsFn(structure Token : TOKEN)) + +%term + EOF + | STRING of string | INT of Int64.int | FLOAT of Real64.real + | SYMBOL of string | CSYMBOL of string + | LPAREN | RPAREN | LBRACK | RBRACK | LBRACE | RBRACE + | EQ | COMMA | COLON | DCOLON | TCOLON | DOT | HASH | UNDER | UNDERUNDER | BAR + | DIVIDE | DOTDOTDOT + | CON | LTYPE | VAL | REC | AND | FUN | FOLD | UNIT | KUNIT | CLASS + | DATATYPE | OF + | TYPE | NAME + | ARROW | LARROW | DARROW | STAR | SEMI + | FN | PLUSPLUS | MINUSMINUS | DOLLAR | TWIDDLE + | STRUCTURE | SIGNATURE | STRUCT | SIG | END | FUNCTOR | WHERE | EXTERN + | INCLUDE | OPEN | CONSTRAINT | CONSTRAINTS | EXPORT | TABLE + | CASE | IF | THEN | ELSE + + | XML_BEGIN of string | XML_END + | NOTAGS of string + | BEGIN_TAG of string | END_TAG of string + + | SELECT | FROM | AS | CWHERE | GROUP | ORDER | BY | HAVING + | UNION | INTERSECT | EXCEPT + | LIMIT | OFFSET | ALL + | TRUE | FALSE | CAND | OR | NOT + | COUNT | AVG | SUM | MIN | MAX + | NE | LT | LE | GT | GE + +%nonterm + file of decl list + | decls of decl list + | decl of decl + | vali of string * con option * exp + | valis of (string * con option * exp) list + | copt of con option + + | dargs of string list + | barOpt of unit + | dcons of (string * con option) list + | dcon of string * con option + + | sgn of sgn + | sgntm of sgn + | sgi of sgn_item + | sgis of sgn_item list + + | str of str + + | kind of kind + | ktuple of kind list + | kcolon of explicitness + | kopt of kind option + + | path of string list * string + | cpath of string list * string + | spath of str + | mpath of string list + + | cexp of con + | capps of con + | cterm of con + | ctuple of con list + | ctuplev of con list + | ident of con + | idents of con list + | rcon of (con * con) list + | rconn of (con * con) list + | rcone of (con * con) list + | cargs of con * kind -> con * kind + | cargl of con * kind -> con * kind + | cargl2 of con * kind -> con * kind + | carg of con * kind -> con * kind + | cargp of con * kind -> con * kind + + | eexp of exp + | eapps of exp + | eterm of exp + | etuple of exp list + | rexp of (con * exp) list + | xml of exp + | xmlOne of exp + | tag of string * exp + | tagHead of string * exp + + | earg of exp * con -> exp * con + | eargp of exp * con -> exp * con + | eargs of exp * con -> exp * con + | eargl of exp * con -> exp * con + | eargl2 of exp * con -> exp * con + + | branch of pat * exp + | branchs of (pat * exp) list + | pat of pat + | pterm of pat + | rpat of (string * pat) list * bool + | ptuple of pat list + + | attrs of (con * exp) list + | attr of con * exp + | attrv of exp + + | query of exp + | query1 of exp + | tables of (con * exp) list + | tname of con + | table of con * exp + | tident of con + | fident of con + | seli of select_item + | selis of select_item list + | select of select + | sqlexp of exp + | wopt of exp + | groupi of group_item + | groupis of group_item list + | gopt of group_item list option + | hopt of exp + | obopt of exp + | obexps of exp + | lopt of exp + | ofopt of exp + | sqlint of exp + | sqlagg of string + + +%verbose (* print summary of errors *) +%pos int (* positions *) +%start file +%pure +%eop EOF +%noshift EOF + +%name Urweb + +%right SEMI +%nonassoc LARROW +%nonassoc IF THEN ELSE +%nonassoc DARROW +%nonassoc COLON +%nonassoc DCOLON TCOLON +%left UNION INTERSECT EXCEPT +%right COMMA +%right OR +%right CAND +%nonassoc EQ NE LT LE GT GE +%right ARROW +%right PLUSPLUS MINUSMINUS +%right STAR +%left NOT +%nonassoc TWIDDLE +%nonassoc DOLLAR +%left DOT +%nonassoc LBRACE RBRACE + +%% + +file : decls (decls) + | SIG sgis ([(DSgn ("?", (SgnConst sgis, s (SIGleft, sgisright))), + s (SIGleft, sgisright))]) + +decls : ([]) + | decl decls (decl :: decls) + +decl : CON SYMBOL cargl2 kopt EQ cexp (let + val loc = s (CONleft, cexpright) + + val k = Option.getOpt (kopt, (KWild, loc)) + val (c, k) = cargl2 (cexp, k) + in + (DCon (SYMBOL, SOME k, c), loc) + end) + | LTYPE SYMBOL EQ cexp (DCon (SYMBOL, SOME (KType, s (LTYPEleft, cexpright)), cexp), + s (LTYPEleft, cexpright)) + | DATATYPE SYMBOL dargs EQ barOpt dcons(DDatatype (SYMBOL, dargs, dcons), s (DATATYPEleft, dconsright)) + | DATATYPE SYMBOL dargs EQ DATATYPE CSYMBOL DOT path + (case dargs of + [] => (DDatatypeImp (SYMBOL, CSYMBOL :: #1 path, #2 path), s (DATATYPEleft, pathright)) + | _ => raise Fail "Arguments specified for imported datatype") + | VAL vali (DVal vali, s (VALleft, valiright)) + | VAL REC valis (DValRec valis, s (VALleft, valisright)) + | FUN valis (DValRec valis, s (FUNleft, valisright)) + + | SIGNATURE CSYMBOL EQ sgn (DSgn (CSYMBOL, sgn), s (SIGNATUREleft, sgnright)) + | STRUCTURE CSYMBOL EQ str (DStr (CSYMBOL, NONE, str), s (STRUCTUREleft, strright)) + | STRUCTURE CSYMBOL COLON sgn EQ str (DStr (CSYMBOL, SOME sgn, str), s (STRUCTUREleft, strright)) + | FUNCTOR CSYMBOL LPAREN CSYMBOL COLON sgn RPAREN EQ str + (DStr (CSYMBOL1, NONE, + (StrFun (CSYMBOL2, sgn1, NONE, str), s (FUNCTORleft, strright))), + s (FUNCTORleft, strright)) + | FUNCTOR CSYMBOL LPAREN CSYMBOL COLON sgn RPAREN COLON sgn EQ str + (DStr (CSYMBOL1, NONE, + (StrFun (CSYMBOL2, sgn1, SOME sgn2, str), s (FUNCTORleft, strright))), + s (FUNCTORleft, strright)) + | EXTERN STRUCTURE CSYMBOL COLON sgn (DFfiStr (CSYMBOL, sgn), s (EXTERNleft, sgnright)) + | OPEN mpath (case mpath of + [] => raise Fail "Impossible mpath parse [1]" + | m :: ms => (DOpen (m, ms), s (OPENleft, mpathright))) + | OPEN CONSTRAINTS mpath (case mpath of + [] => raise Fail "Impossible mpath parse [3]" + | m :: ms => (DOpenConstraints (m, ms), s (OPENleft, mpathright))) + | CONSTRAINT cterm TWIDDLE cterm (DConstraint (cterm1, cterm2), s (CONSTRAINTleft, ctermright)) + | EXPORT spath (DExport spath, s (EXPORTleft, spathright)) + | TABLE SYMBOL COLON cexp (DTable (SYMBOL, entable cexp), s (TABLEleft, cexpright)) + | CLASS SYMBOL EQ cexp (DClass (SYMBOL, cexp), s (CLASSleft, cexpright)) + | CLASS SYMBOL SYMBOL EQ cexp (let + val loc = s (CLASSleft, cexpright) + val k = (KType, loc) + val c = (CAbs (SYMBOL2, SOME k, cexp), loc) + in + (DClass (SYMBOL1, c), s (CLASSleft, cexpright)) + end) + +kopt : (NONE) + | DCOLON kind (SOME kind) + +dargs : ([]) + | SYMBOL dargs (SYMBOL :: dargs) + +barOpt : () + | BAR () + +dcons : dcon ([dcon]) + | dcon BAR dcons (dcon :: dcons) + +dcon : CSYMBOL (CSYMBOL, NONE) + | CSYMBOL OF cexp (CSYMBOL, SOME cexp) + +vali : SYMBOL eargl2 copt EQ eexp (let + val loc = s (SYMBOLleft, eexpright) + val t = Option.getOpt (copt, (CWild (KType, loc), loc)) + + val (e, t) = eargl2 (eexp, t) + in + (SYMBOL, SOME t, e) + end) + +copt : (NONE) + | COLON cexp (SOME cexp) + +valis : vali ([vali]) + | vali AND valis (vali :: valis) + +sgn : sgntm (sgntm) + | FUNCTOR LPAREN CSYMBOL COLON sgn RPAREN COLON sgn + (SgnFun (CSYMBOL, sgn1, sgn2), s (FUNCTORleft, sgn2right)) + +sgntm : SIG sgis END (SgnConst sgis, s (SIGleft, ENDright)) + | mpath (case mpath of + [] => raise Fail "Impossible mpath parse [2]" + | [x] => SgnVar x + | m :: ms => SgnProj (m, + List.take (ms, length ms - 1), + List.nth (ms, length ms - 1)), + s (mpathleft, mpathright)) + | sgntm WHERE CON SYMBOL EQ cexp (SgnWhere (sgntm, SYMBOL, cexp), s (sgntmleft, cexpright)) + | sgntm WHERE LTYPE SYMBOL EQ cexp(SgnWhere (sgntm, SYMBOL, cexp), s (sgntmleft, cexpright)) + | LPAREN sgn RPAREN (sgn) + +sgi : CON SYMBOL DCOLON kind (SgiConAbs (SYMBOL, kind), s (CONleft, kindright)) + | LTYPE SYMBOL (SgiConAbs (SYMBOL, (KType, s (LTYPEleft, SYMBOLright))), + s (LTYPEleft, SYMBOLright)) + | CON SYMBOL EQ cexp (SgiCon (SYMBOL, NONE, cexp), s (CONleft, cexpright)) + | CON SYMBOL DCOLON kind EQ cexp (SgiCon (SYMBOL, SOME kind, cexp), s (CONleft, cexpright)) + | LTYPE SYMBOL EQ cexp (SgiCon (SYMBOL, SOME (KType, s (LTYPEleft, cexpright)), cexp), + s (LTYPEleft, cexpright)) + | DATATYPE SYMBOL dargs EQ barOpt dcons(SgiDatatype (SYMBOL, dargs, dcons), s (DATATYPEleft, dconsright)) + | DATATYPE SYMBOL dargs EQ DATATYPE CSYMBOL DOT path + (case dargs of + [] => (SgiDatatypeImp (SYMBOL, CSYMBOL :: #1 path, #2 path), s (DATATYPEleft, pathright)) + | _ => raise Fail "Arguments specified for imported datatype") + | VAL SYMBOL COLON cexp (SgiVal (SYMBOL, cexp), s (VALleft, cexpright)) + + | STRUCTURE CSYMBOL COLON sgn (SgiStr (CSYMBOL, sgn), s (STRUCTUREleft, sgnright)) + | SIGNATURE CSYMBOL EQ sgn (SgiSgn (CSYMBOL, sgn), s (SIGNATUREleft, sgnright)) + | FUNCTOR CSYMBOL LPAREN CSYMBOL COLON sgn RPAREN COLON sgn + (SgiStr (CSYMBOL1, + (SgnFun (CSYMBOL2, sgn1, sgn2), s (FUNCTORleft, sgn2right))), + s (FUNCTORleft, sgn2right)) + | INCLUDE sgn (SgiInclude sgn, s (INCLUDEleft, sgnright)) + | CONSTRAINT cterm TWIDDLE cterm (SgiConstraint (cterm1, cterm2), s (CONSTRAINTleft, ctermright)) + | TABLE SYMBOL COLON cexp (SgiTable (SYMBOL, entable cexp), s (TABLEleft, cexpright)) + | CLASS SYMBOL (SgiClassAbs SYMBOL, s (CLASSleft, SYMBOLright)) + | CLASS SYMBOL EQ cexp (SgiClass (SYMBOL, cexp), s (CLASSleft, cexpright)) + | CLASS SYMBOL SYMBOL EQ cexp (let + val loc = s (CLASSleft, cexpright) + val k = (KType, loc) + val c = (CAbs (SYMBOL2, SOME k, cexp), loc) + in + (SgiClass (SYMBOL1, c), s (CLASSleft, cexpright)) + end) + +sgis : ([]) + | sgi sgis (sgi :: sgis) + +str : STRUCT decls END (StrConst decls, s (STRUCTleft, ENDright)) + | spath (spath) + | FUNCTOR LPAREN CSYMBOL COLON sgn RPAREN DARROW str + (StrFun (CSYMBOL, sgn, NONE, str), s (FUNCTORleft, strright)) + | FUNCTOR LPAREN CSYMBOL COLON sgn RPAREN COLON sgn DARROW str + (StrFun (CSYMBOL, sgn1, SOME sgn2, str), s (FUNCTORleft, strright)) + | spath LPAREN str RPAREN (StrApp (spath, str), s (spathleft, RPARENright)) + +spath : CSYMBOL (StrVar CSYMBOL, s (CSYMBOLleft, CSYMBOLright)) + | spath DOT CSYMBOL (StrProj (spath, CSYMBOL), s (spathleft, CSYMBOLright)) + +kind : TYPE (KType, s (TYPEleft, TYPEright)) + | NAME (KName, s (NAMEleft, NAMEright)) + | LBRACE kind RBRACE (KRecord kind, s (LBRACEleft, RBRACEright)) + | kind ARROW kind (KArrow (kind1, kind2), s (kind1left, kind2right)) + | LPAREN kind RPAREN (#1 kind, s (LPARENleft, RPARENright)) + | KUNIT (KUnit, s (KUNITleft, KUNITright)) + | UNDERUNDER (KWild, s (UNDERUNDERleft, UNDERUNDERright)) + | LPAREN ktuple RPAREN (KTuple ktuple, s (LPARENleft, RPARENright)) + +ktuple : kind STAR kind ([kind1, kind2]) + | kind STAR ktuple (kind :: ktuple) + +capps : cterm (cterm) + | capps cterm (CApp (capps, cterm), s (cappsleft, ctermright)) + +cexp : capps (capps) + | cexp ARROW cexp (TFun (cexp1, cexp2), s (cexp1left, cexp2right)) + | SYMBOL kcolon kind ARROW cexp (TCFun (kcolon, SYMBOL, kind, cexp), s (SYMBOLleft, cexpright)) + + | cexp PLUSPLUS cexp (CConcat (cexp1, cexp2), s (cexp1left, cexp1right)) + + | FN cargs DARROW cexp (#1 (cargs (cexp, (KWild, s (FNleft, cexpright))))) + | cterm TWIDDLE cterm DARROW cexp(CDisjoint (cterm1, cterm2, cexp), s (cterm1left, cexpright)) + | cterm TWIDDLE cterm ARROW cexp (TDisjoint (cterm1, cterm2, cexp), s (cterm1left, cexpright)) + + | LPAREN cexp RPAREN DCOLON kind (CAnnot (cexp, kind), s (LPARENleft, kindright)) + + | UNDER DCOLON kind (CWild kind, s (UNDERleft, UNDERright)) + | ctuple (let + val loc = s (ctupleleft, ctupleright) + in + (TRecord (CRecord (ListUtil.mapi (fn (i, c) => + ((CName (Int.toString (i + 1)), loc), + c)) ctuple), + loc), loc) + end) + +kcolon : DCOLON (Explicit) + | TCOLON (Implicit) + +cargs : carg (carg) + | cargl (cargl) + +cargl : cargp cargp (cargp1 o cargp2) + | cargp cargl (cargp o cargl) + +cargl2 : (fn x => x) + | cargp cargl2 (cargp o cargl2) + +carg : SYMBOL DCOLON kind (fn (c, k) => + let + val loc = s (SYMBOLleft, kindright) + in + ((CAbs (SYMBOL, SOME kind, c), loc), + (KArrow (kind, k), loc)) + end) + | cargp (cargp) + +cargp : SYMBOL (fn (c, k) => + let + val loc = s (SYMBOLleft, SYMBOLright) + in + ((CAbs (SYMBOL, NONE, c), loc), + (KArrow ((KWild, loc), k), loc)) + end) + | LPAREN SYMBOL DCOLON kind RPAREN (fn (c, k) => + let + val loc = s (LPARENleft, RPARENright) + in + ((CAbs (SYMBOL, SOME kind, c), loc), + (KArrow (kind, k), loc)) + end) + +path : SYMBOL ([], SYMBOL) + | CSYMBOL DOT path (let val (ms, x) = path in (CSYMBOL :: ms, x) end) + +cpath : CSYMBOL ([], CSYMBOL) + | CSYMBOL DOT cpath (let val (ms, x) = cpath in (CSYMBOL :: ms, x) end) + +mpath : CSYMBOL ([CSYMBOL]) + | CSYMBOL DOT mpath (CSYMBOL :: mpath) + +cterm : LPAREN cexp RPAREN (#1 cexp, s (LPARENleft, RPARENright)) + | LBRACK rcon RBRACK (CRecord rcon, s (LBRACKleft, RBRACKright)) + | LBRACK rconn RBRACK (CRecord rconn, s (LBRACKleft, RBRACKright)) + | LBRACE rcone RBRACE (TRecord (CRecord rcone, s (LBRACEleft, RBRACEright)), + s (LBRACEleft, RBRACEright)) + | DOLLAR cterm (TRecord cterm, s (DOLLARleft, ctermright)) + | HASH CSYMBOL (CName CSYMBOL, s (HASHleft, CSYMBOLright)) + | HASH INT (CName (Int64.toString INT), s (HASHleft, INTright)) + + | path (CVar path, s (pathleft, pathright)) + | path DOT INT (CProj ((CVar path, s (pathleft, pathright)), Int64.toInt INT), + s (pathleft, INTright)) + | UNDER (CWild (KWild, s (UNDERleft, UNDERright)), s (UNDERleft, UNDERright)) + | FOLD (CFold, s (FOLDleft, FOLDright)) + | UNIT (CUnit, s (UNITleft, UNITright)) + | LPAREN ctuplev RPAREN (CTuple ctuplev, s (LPARENleft, RPARENright)) + +ctuplev: cexp COMMA cexp ([cexp1, cexp2]) + | cexp COMMA ctuplev (cexp :: ctuplev) + +ctuple : capps STAR capps ([capps1, capps2]) + | capps STAR ctuple (capps :: ctuple) + +rcon : ([]) + | ident EQ cexp ([(ident, cexp)]) + | ident EQ cexp COMMA rcon ((ident, cexp) :: rcon) + +rconn : ident ([(ident, (CUnit, s (identleft, identright)))]) + | ident COMMA rconn ((ident, (CUnit, s (identleft, identright))) :: rconn) + +rcone : ([]) + | ident COLON cexp ([(ident, cexp)]) + | ident COLON cexp COMMA rcone ((ident, cexp) :: rcone) + +ident : CSYMBOL (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright)) + | INT (CName (Int64.toString INT), s (INTleft, INTright)) + | SYMBOL (CVar ([], SYMBOL), s (SYMBOLleft, SYMBOLright)) + +eapps : eterm (eterm) + | eapps eterm (EApp (eapps, eterm), s (eappsleft, etermright)) + | eapps LBRACK cexp RBRACK (ECApp (eapps, cexp), s (eappsleft, RBRACKright)) + +eexp : eapps (eapps) + | FN eargs DARROW eexp (let + val loc = s (FNleft, eexpright) + in + #1 (eargs (eexp, (CWild (KType, loc), loc))) + end) + | LBRACK cterm TWIDDLE cterm RBRACK DARROW eexp(EDisjoint (cterm1, cterm2, eexp), s (LBRACKleft, RBRACKright)) + | eexp COLON cexp (EAnnot (eexp, cexp), s (eexpleft, cexpright)) + | eexp MINUSMINUS cexp (ECut (eexp, cexp), s (eexpleft, cexpright)) + | CASE eexp OF barOpt branch branchs (ECase (eexp, branch :: branchs), s (CASEleft, branchsright)) + | IF eexp THEN eexp ELSE eexp (let + val loc = s (IFleft, eexp3right) + in + (ECase (eexp1, [((PCon (["Basis"], "True", NONE), loc), eexp2), + ((PCon (["Basis"], "False", NONE), loc), eexp3)]), loc) + end) + | SYMBOL LARROW eexp SEMI eexp (let + val loc = s (SYMBOLleft, eexp2right) + val e = (EVar (["Basis"], "bind"), loc) + val e = (EApp (e, eexp1), loc) + in + (EApp (e, (EAbs (SYMBOL, NONE, eexp2), loc)), loc) + end) + +eargs : earg (earg) + | eargl (eargl) + +eargl : eargp eargp (eargp1 o eargp2) + | eargp eargl (eargp o eargl) + +eargl2 : (fn x => x) + | eargp eargl2 (eargp o eargl2) + +earg : SYMBOL kcolon kind (fn (e, t) => + let + val loc = s (SYMBOLleft, kindright) + in + ((ECAbs (kcolon, SYMBOL, kind, e), loc), + (TCFun (kcolon, SYMBOL, kind, t), loc)) + end) + | SYMBOL COLON cexp (fn (e, t) => + let + val loc = s (SYMBOLleft, cexpright) + in + ((EAbs (SYMBOL, SOME cexp, e), loc), + (TFun (cexp, t), loc)) + end) + | UNDER COLON cexp (fn (e, t) => + let + val loc = s (UNDERleft, cexpright) + in + ((EAbs ("_", SOME cexp, e), loc), + (TFun (cexp, t), loc)) + end) + | eargp (eargp) + +eargp : SYMBOL (fn (e, t) => + let + val loc = s (SYMBOLleft, SYMBOLright) + in + ((EAbs (SYMBOL, NONE, e), loc), + (TFun ((CWild (KType, loc), loc), t), loc)) + end) + | UNIT (fn (e, t) => + let + val loc = s (UNITleft, UNITright) + val t' = (TRecord (CRecord [], loc), loc) + in + ((EAbs ("_", SOME t', e), loc), + (TFun (t', t), loc)) + end) + | UNDER (fn (e, t) => + let + val loc = s (UNDERleft, UNDERright) + in + ((EAbs ("_", NONE, e), loc), + (TFun ((CWild (KType, loc), loc), t), loc)) + end) + | LPAREN SYMBOL kcolon kind RPAREN(fn (e, t) => + let + val loc = s (LPARENleft, RPARENright) + in + ((ECAbs (kcolon, SYMBOL, kind, e), loc), + (TCFun (kcolon, SYMBOL, kind, t), loc)) + end) + | LPAREN SYMBOL COLON cexp RPAREN (fn (e, t) => + let + val loc = s (LPARENleft, RPARENright) + in + ((EAbs (SYMBOL, SOME cexp, e), loc), + (TFun (cexp, t), loc)) + end) + | LPAREN UNDER COLON cexp RPAREN (fn (e, t) => + let + val loc = s (LPARENleft, RPARENright) + in + ((EAbs ("_", SOME cexp, e), loc), + (TFun (cexp, t), loc)) + end) + +eterm : LPAREN eexp RPAREN (#1 eexp, s (LPARENleft, RPARENright)) + | LPAREN etuple RPAREN (let + val loc = s (LPARENleft, RPARENright) + in + (ERecord (ListUtil.mapi (fn (i, e) => + ((CName (Int.toString (i + 1)), loc), + e)) etuple), loc) + end) + + | path (EVar path, s (pathleft, pathright)) + | cpath (EVar cpath, s (cpathleft, cpathright)) + | LBRACE rexp RBRACE (ERecord rexp, s (LBRACEleft, RBRACEright)) + | UNIT (ERecord [], s (UNITleft, UNITright)) + + | INT (EPrim (Prim.Int INT), s (INTleft, INTright)) + | FLOAT (EPrim (Prim.Float FLOAT), s (FLOATleft, FLOATright)) + | STRING (EPrim (Prim.String STRING), s (STRINGleft, STRINGright)) + + | path DOT idents (let + val loc = s (pathleft, identsright) + in + foldl (fn (ident, e) => + (EField (e, ident), loc)) + (EVar path, s (pathleft, pathright)) idents + end) + | FOLD (EFold, s (FOLDleft, FOLDright)) + + | XML_BEGIN xml XML_END (xml) + | XML_BEGIN XML_END (EApp ((EVar (["Basis"], "cdata"), s (XML_BEGINleft, XML_ENDright)), + (EPrim (Prim.String ""), s (XML_BEGINleft, XML_ENDright))), + s (XML_BEGINleft, XML_ENDright)) + | LPAREN query RPAREN (query) + | UNDER (EWild, s (UNDERleft, UNDERright)) + +idents : ident ([ident]) + | ident DOT idents (ident :: idents) + +etuple : eexp COMMA eexp ([eexp1, eexp2]) + | eexp COMMA etuple (eexp :: etuple) + +branch : pat DARROW eexp (pat, eexp) + +branchs: ([]) + | BAR branch branchs (branch :: branchs) + +pat : pterm (pterm) + | cpath pterm (PCon (#1 cpath, #2 cpath, SOME pterm), s (cpathleft, ptermright)) + +pterm : SYMBOL (PVar SYMBOL, s (SYMBOLleft, SYMBOLright)) + | cpath (PCon (#1 cpath, #2 cpath, NONE), s (cpathleft, cpathright)) + | UNDER (PWild, s (UNDERleft, UNDERright)) + | INT (PPrim (Prim.Int INT), s (INTleft, INTright)) + | STRING (PPrim (Prim.String STRING), s (STRINGleft, STRINGright)) + | LPAREN pat RPAREN (pat) + | LBRACE RBRACE (PRecord ([], false), s (LBRACEleft, RBRACEright)) + | UNIT (PRecord ([], false), s (UNITleft, UNITright)) + | LBRACE rpat RBRACE (PRecord rpat, s (LBRACEleft, RBRACEright)) + | LPAREN ptuple RPAREN (PRecord (ListUtil.mapi (fn (i, p) => (Int.toString (i + 1), p)) ptuple, + false), + s (LPARENleft, RPARENright)) + +rpat : CSYMBOL EQ pat ([(CSYMBOL, pat)], false) + | INT EQ pat ([(Int64.toString INT, pat)], false) + | DOTDOTDOT ([], true) + | CSYMBOL EQ pat COMMA rpat ((CSYMBOL, pat) :: #1 rpat, #2 rpat) + | INT EQ pat COMMA rpat ((Int64.toString INT, pat) :: #1 rpat, #2 rpat) + +ptuple : pat COMMA pat ([pat1, pat2]) + | pat COMMA ptuple (pat :: ptuple) + +rexp : ([]) + | ident EQ eexp ([(ident, eexp)]) + | ident EQ eexp COMMA rexp ((ident, eexp) :: rexp) + +xml : xmlOne xml (let + val pos = s (xmlOneleft, xmlright) + in + (EApp ((EApp ( + (EVar (["Basis"], "join"), pos), + xmlOne), pos), + xml), pos) + end) + | xmlOne (xmlOne) + +xmlOne : NOTAGS (EApp ((EVar (["Basis"], "cdata"), s (NOTAGSleft, NOTAGSright)), + (EPrim (Prim.String NOTAGS), s (NOTAGSleft, NOTAGSright))), + s (NOTAGSleft, NOTAGSright)) + | tag DIVIDE GT (let + val pos = s (tagleft, GTright) + in + (EApp (#2 tag, + (EApp ((EVar (["Basis"], "cdata"), pos), + (EPrim (Prim.String ""), pos)), + pos)), pos) + end) + + | tag GT xml END_TAG (let + val pos = s (tagleft, GTright) + in + if #1 tag = END_TAG then + if END_TAG = "lform" then + (EApp ((EVar (["Basis"], "lform"), pos), + xml), pos) + else + (EApp (#2 tag, xml), pos) + else + (ErrorMsg.errorAt pos "Begin and end tags don't match."; + (EFold, pos)) + end) + | LBRACE eexp RBRACE (eexp) + +tag : tagHead attrs (let + val pos = s (tagHeadleft, attrsright) + in + (#1 tagHead, + (EApp ((EApp ((EVar (["Basis"], "tag"), pos), + (ERecord attrs, pos)), pos), + (EApp (#2 tagHead, + (ERecord [], pos)), pos)), + pos)) + end) + +tagHead: BEGIN_TAG (let + val pos = s (BEGIN_TAGleft, BEGIN_TAGright) + in + (BEGIN_TAG, + (EVar ([], BEGIN_TAG), pos)) + end) + | tagHead LBRACE cexp RBRACE (#1 tagHead, (ECApp (#2 tagHead, cexp), s (tagHeadleft, RBRACEright))) + +attrs : ([]) + | attr attrs (attr :: attrs) + +attr : SYMBOL EQ attrv ((CName (capitalize SYMBOL), s (SYMBOLleft, SYMBOLright)), attrv) + +attrv : INT (EPrim (Prim.Int INT), s (INTleft, INTright)) + | FLOAT (EPrim (Prim.Float FLOAT), s (FLOATleft, FLOATright)) + | STRING (EPrim (Prim.String STRING), s (STRINGleft, STRINGright)) + | LBRACE eexp RBRACE (eexp) + +query : query1 obopt lopt ofopt (let + val loc = s (query1left, query1right) + + val re = (ERecord [((CName "Rows", loc), + query1), + ((CName "OrderBy", loc), + obopt), + ((CName "Limit", loc), + lopt), + ((CName "Offset", loc), + ofopt)], loc) + in + (EApp ((EVar (["Basis"], "sql_query"), loc), re), loc) + end) + +query1 : SELECT select FROM tables wopt gopt hopt + (let + val loc = s (SELECTleft, tablesright) + + val (sel, exps) = + case select of + Star => (map (fn (nm, _) => + (nm, (CTuple [(CWild (KRecord (KType, loc), loc), + loc), + (CRecord [], loc)], + loc))) tables, + []) + | Items sis => + let + val tabs = map (fn (nm, _) => (nm, (CRecord [], loc))) tables + val (tabs, exps) = foldl (amend_select loc) (tabs, []) sis + in + (map (fn (nm, c) => (nm, + (CTuple [c, + (CWild (KRecord (KType, loc), loc), + loc)], loc))) tabs, + exps) + end + + val sel = (CRecord sel, loc) + + val grp = case gopt of + NONE => (ECApp ((EVar (["Basis"], "sql_subset_all"), loc), + (CWild (KRecord (KRecord (KType, loc), loc), + loc), loc)), loc) + | SOME gis => + let + val tabs = map (fn (nm, _) => + (nm, (CRecord [], loc))) tables + val tabs = foldl (amend_group loc) tabs gis + + val tabs = map (fn (nm, c) => + (nm, + (CTuple [c, + (CWild (KRecord (KType, loc), + loc), + loc)], loc))) tabs + in + (ECApp ((EVar (["Basis"], "sql_subset"), loc), + (CRecord tabs, loc)), loc) + end + + val e = (EVar (["Basis"], "sql_query1"), loc) + val re = (ERecord [((CName "From", loc), + (ERecord tables, loc)), + ((CName "Where", loc), + wopt), + ((CName "GroupBy", loc), + grp), + ((CName "Having", loc), + hopt), + ((CName "SelectFields", loc), + (ECApp ((EVar (["Basis"], "sql_subset"), loc), + sel), loc)), + ((CName "SelectExps", loc), + (ERecord exps, loc))], loc) + + val e = (EApp (e, re), loc) + in + e + end) + | query1 UNION query1 (sql_relop ("union", query11, query12, s (query11left, query12right))) + | query1 INTERSECT query1 (sql_relop ("intersect", query11, query12, s (query11left, query12right))) + | query1 EXCEPT query1 (sql_relop ("except", query11, query12, s (query11left, query12right))) + +tables : table ([table]) + | table COMMA tables (table :: tables) + +tname : CSYMBOL (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright)) + | LBRACE cexp RBRACE (cexp) + +table : SYMBOL ((CName (capitalize SYMBOL), s (SYMBOLleft, SYMBOLright)), + (EVar ([], SYMBOL), s (SYMBOLleft, SYMBOLright))) + | SYMBOL AS tname (tname, (EVar ([], SYMBOL), s (SYMBOLleft, SYMBOLright))) + | LBRACE LBRACE eexp RBRACE RBRACE AS tname (tname, eexp) + +tident : SYMBOL (CName (capitalize SYMBOL), s (SYMBOLleft, SYMBOLright)) + | CSYMBOL (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright)) + | LBRACE LBRACE cexp RBRACE RBRACE (cexp) + +fident : CSYMBOL (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright)) + | LBRACE cexp RBRACE (cexp) + +seli : tident DOT fident (Field (tident, fident)) + | sqlexp AS fident (Exp (fident, sqlexp)) + +selis : seli ([seli]) + | seli COMMA selis (seli :: selis) + +select : STAR (Star) + | selis (Items selis) + +sqlexp : TRUE (sql_inject (EVar (["Basis"], "True"), + EVar (["Basis"], "sql_bool"), + s (TRUEleft, TRUEright))) + | FALSE (sql_inject (EVar (["Basis"], "False"), + EVar (["Basis"], "sql_bool"), + s (FALSEleft, FALSEright))) + + | INT (sql_inject (EPrim (Prim.Int INT), + EVar (["Basis"], "sql_int"), + s (INTleft, INTright))) + | FLOAT (sql_inject (EPrim (Prim.Float FLOAT), + EVar (["Basis"], "sql_float"), + s (FLOATleft, FLOATright))) + | STRING (sql_inject (EPrim (Prim.String STRING), + EVar (["Basis"], "sql_string"), + s (STRINGleft, STRINGright))) + + | tident DOT fident (let + val loc = s (tidentleft, fidentright) + val e = (EVar (["Basis"], "sql_field"), loc) + val e = (ECApp (e, tident), loc) + in + (ECApp (e, fident), loc) + end) + | CSYMBOL (let + val loc = s (CSYMBOLleft, CSYMBOLright) + val e = (EVar (["Basis"], "sql_exp"), loc) + in + (ECApp (e, (CName CSYMBOL, loc)), loc) + end) + + | sqlexp EQ sqlexp (sql_compare ("eq", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) + | sqlexp NE sqlexp (sql_compare ("ne", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) + | sqlexp LT sqlexp (sql_compare ("lt", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) + | sqlexp LE sqlexp (sql_compare ("le", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) + | sqlexp GT sqlexp (sql_compare ("gt", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) + | sqlexp GE sqlexp (sql_compare ("ge", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) + + | sqlexp CAND sqlexp (sql_binary ("and", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) + | sqlexp OR sqlexp (sql_binary ("or", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) + | NOT sqlexp (sql_unary ("not", sqlexp, s (NOTleft, sqlexpright))) + + | LBRACE eexp RBRACE (sql_inject (#1 eexp, + EWild, + s (LBRACEleft, RBRACEright))) + | LPAREN sqlexp RPAREN (sqlexp) + + | COUNT LPAREN STAR RPAREN (let + val loc = s (COUNTleft, RPARENright) + in + (EApp ((EVar (["Basis"], "sql_count"), loc), + (ERecord [], loc)), loc) + end) + | sqlagg LPAREN sqlexp RPAREN (let + val loc = s (sqlaggleft, RPARENright) + + val e = (EApp ((EVar (["Basis"], "sql_" ^ sqlagg), loc), + (EWild, loc)), loc) + val e = (EApp ((EVar (["Basis"], "sql_aggregate"), loc), + e), loc) + in + (EApp (e, sqlexp), loc) + end) + +wopt : (sql_inject (EVar (["Basis"], "True"), + EVar (["Basis"], "sql_bool"), + dummy)) + | CWHERE sqlexp (sqlexp) + +groupi : tident DOT fident (GField (tident, fident)) + +groupis: groupi ([groupi]) + | groupi COMMA groupis (groupi :: groupis) + +gopt : (NONE) + | GROUP BY groupis (SOME groupis) + +hopt : (sql_inject (EVar (["Basis"], "True"), + EVar (["Basis"], "sql_bool"), + dummy)) + | HAVING sqlexp (sqlexp) + +obopt : (ECApp ((EVar (["Basis"], "sql_order_by_Nil"), dummy), + (CWild (KRecord (KType, dummy), dummy), dummy)), + dummy) + | ORDER BY obexps (obexps) + +obexps : sqlexp (let + val loc = s (sqlexpleft, sqlexpright) + + val e' = (ECApp ((EVar (["Basis"], "sql_order_by_Nil"), loc), + (CWild (KRecord (KType, loc), loc), loc)), + loc) + val e = (EApp ((EVar (["Basis"], "sql_order_by_Cons"), loc), + sqlexp), loc) + in + (EApp (e, e'), loc) + end) + | sqlexp COMMA obexps (let + val loc = s (sqlexpleft, obexpsright) + + val e = (EApp ((EVar (["Basis"], "sql_order_by_Cons"), loc), + sqlexp), loc) + in + (EApp (e, obexps), loc) + end) + +lopt : (EVar (["Basis"], "sql_no_limit"), dummy) + | LIMIT ALL (EVar (["Basis"], "sql_no_limit"), dummy) + | LIMIT sqlint (let + val loc = s (LIMITleft, sqlintright) + in + (EApp ((EVar (["Basis"], "sql_limit"), loc), sqlint), loc) + end) + +ofopt : (EVar (["Basis"], "sql_no_offset"), dummy) + | OFFSET sqlint (let + val loc = s (OFFSETleft, sqlintright) + in + (EApp ((EVar (["Basis"], "sql_offset"), loc), sqlint), loc) + end) + +sqlint : INT (EPrim (Prim.Int INT), s (INTleft, INTright)) + | LBRACE eexp RBRACE (eexp) + +sqlagg : AVG ("avg") + | SUM ("sum") + | MIN ("min") + | MAX ("max") |