diff options
Diffstat (limited to 'src/lacweb.grm')
-rw-r--r-- | src/lacweb.grm | 1055 |
1 files changed, 0 insertions, 1055 deletions
diff --git a/src/lacweb.grm b/src/lacweb.grm deleted file mode 100644 index feff82df..00000000 --- a/src/lacweb.grm +++ /dev/null @@ -1,1055 +0,0 @@ -(* 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 Laconic/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 LacwebLrValsFn(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 Lacweb - -%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") |