path: root/src/urweb.grm

(* 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 SOFTARE 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
       | Fields of con * con

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
      | Fields (tx, fs) =>
        let
            val (tabs, found) = ListUtil.foldlMap (fn ((tx', c'), found) =>
                                                      if eqTnames (tx, tx') then
                                                          ((tx', (CConcat (fs, 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

fun native_op (oper, e1, e2, loc) =
    let
        val e = (EVar (["Basis"], oper), loc)
        val e = (EApp (e, (EWild, loc)), loc)
        val e = (EApp (e, e1), loc)
    in
        (EApp (e, e2), loc)
    end

val inDml = ref false

fun tagIn bt =
    case bt of
        "table" => "tabl"
      | _ => bt

%%
%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 | WITH | SQL
 | INCLUDE | OPEN | CONSTRAINT | CONSTRAINTS | EXPORT | TABLE | SEQUENCE
 | CASE | IF | THEN | ELSE

 | XML_BEGIN of string | XML_END | XML_BEGIN_END of string
 | 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
 | ASC | DESC
 | INSERT | INTO | VALUES | UPDATE | SET | DELETE
 | NE | LT | LE | GT | GE

%nonterm
   file of decl list
 | decls of decl list
 | decl of decl list
 | 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
 | obitem of exp * exp
 | obexps of exp
 | diropt of exp
 | lopt of exp
 | ofopt of exp
 | sqlint of exp
 | sqlagg of string

 | texp of exp
 | fields of con list
 | sqlexps of exp list
 | fsets of (con * exp) list
 | enterDml of unit
 | leaveDml of unit


%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
%left WITH
%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 mpath LPAREN str RPAREN   (let
                                             val loc = s (OPENleft, RPARENright)

                                             val m = case mpath of
                                                         [] => raise Fail "Impossible mpath parse [4]"
                                                       | m :: ms =>
                                                         foldl (fn (m, str) => (StrProj (str, m), loc))
                                                         (StrVar m, loc) ms
                                         in
                                             [(DStr ("anon", NONE, (StrApp (m, str), loc)), loc),
                                              (DOpen ("anon", []), loc)]
                                         end)
       | 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))])
       | SEQUENCE SYMBOL                ([(DSequence SYMBOL, s (SEQUENCEleft, SYMBOLright))])
       | 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))
       | SEQUENCE SYMBOL                (SgiSequence SYMBOL, s (SEQUENCEleft, SYMBOLright))
       | 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)))))

       | 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)
       | UNDER DCOLON kind              (fn (c, k) =>
                                            let
                                                val loc = s (UNDERleft, kindright)
                                            in
                                                ((CAbs ("_", 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)
       | UNDER                          (fn (c, k) =>
                                            let
                                                val loc = s (UNDERleft, UNDERright)
                                            in
                                                ((CAbs ("_", 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)
       | LBRACK cterm TWIDDLE cterm RBRACK (fn (c, k) =>
                                            let
                                                val loc = s (LBRACKleft, RBRACKright)
                                            in
                                                ((CDisjoint (cterm1, cterm2, c), loc),
                                                 k)
                                            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)
       | 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)
       | UNIT LARROW eexp SEMI eexp     (let
                                             val loc = s (UNITleft, eexp2right)
                                             val e = (EVar (["Basis"], "bind"), loc)
                                             val e = (EApp (e, eexp1), loc)
                                             val t = (TRecord (CRecord [], loc), loc)
                                         in
                                             (EApp (e, (EAbs ("_", SOME t, eexp2), loc)), loc)
                                         end)
       | eexp EQ eexp                   (native_op ("eq", eexp1, eexp2, s (eexp1left, eexp2right)))
       | eexp NE eexp                   (native_op ("ne", eexp1, eexp2, s (eexp1left, eexp2right)))
       | eexp WITH cterm EQ eexp        (EWith (eexp1, cterm, eexp2), s (eexp1left, eexp2right))

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)
       | LPAREN cterm TWIDDLE cterm RPAREN(fn (e, t) =>
                                            let
                                                val loc = s (LPARENleft, RPARENright)
                                            in
                                                ((EDisjoint (cterm1, cterm2, e), loc),
                                                 (CDisjoint (cterm1, cterm2, t), loc))
                                            end)
       | LBRACK cterm TWIDDLE cterm RBRACK(fn (e, t) =>
                                            let
                                                val loc = s (LBRACKleft, RBRACKright)
                                            in
                                                ((EDisjoint (cterm1, cterm2, e), loc),
                                                 (CDisjoint (cterm1, cterm2, 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          (let
                                             val loc = s (XML_BEGINleft, XML_ENDright)
                                         in
                                             if XML_BEGIN = "xml" then
                                                 ()
                                             else
                                                 ErrorMsg.errorAt loc "Initial XML tag pair aren't both tagged \"xml\".";
                                             xml
                                         end)
       | XML_BEGIN XML_END              (let
                                             val loc = s (XML_BEGINleft, XML_ENDright)
                                         in
                                             if XML_BEGIN = "xml" then
                                                 ()
                                             else
                                                 ErrorMsg.errorAt loc "Initial XML tag pair aren't both tagged \"xml\".";
                                             (EApp ((EVar (["Basis"], "cdata"), loc),
                                                    (EPrim (Prim.String ""), loc)),
                                              loc)
                                         end)
       | XML_BEGIN_END                  (let
                                             val loc = s (XML_BEGIN_ENDleft, XML_BEGIN_ENDright)
                                         in
                                             if XML_BEGIN_END = "xml" then
                                                 ()
                                             else
                                                 ErrorMsg.errorAt loc "Initial XML tag pair aren't both tagged \"xml\".";
                                             (EApp ((EVar (["Basis"], "cdata"), loc),
                                                    (EPrim (Prim.String ""), loc)),
                                              loc)
                                         end)

       | LPAREN query RPAREN            (query)
       | LPAREN CWHERE sqlexp RPAREN    (sqlexp)
       | LPAREN SQL sqlexp RPAREN       (sqlexp)

       | LPAREN INSERT INTO texp LPAREN fields RPAREN VALUES LPAREN sqlexps RPAREN RPAREN
                                        (let
                                             val loc = s (LPAREN1left, RPAREN3right)

                                             val e = (EVar (["Basis"], "insert"), loc)
                                             val e = (EApp (e, texp), loc)
                                         in
                                             if length fields <> length sqlexps then
                                                 ErrorMsg.errorAt loc "Length mismatch in INSERT field specification"
                                             else
                                                 ();
                                             (EApp (e, (ERecord (ListPair.zip (fields, sqlexps)), loc)), loc)
                                         end)
       | LPAREN enterDml UPDATE texp SET fsets CWHERE sqlexp leaveDml RPAREN
                                        (let
                                             val loc = s (LPARENleft, RPARENright)

                                             val e = (EVar (["Basis"], "update"), loc)
                                             val e = (ECApp (e, (CWild (KRecord (KType, loc), loc), loc)), loc)
                                             val e = (EApp (e, (ERecord fsets, loc)), loc)
                                             val e = (EApp (e, texp), loc)
                                         in
                                             (EApp (e, sqlexp), loc)
                                         end)
       | LPAREN enterDml DELETE FROM texp CWHERE sqlexp leaveDml RPAREN
                                        (let
                                             val loc = s (LPARENleft, RPARENright)

                                             val e = (EVar (["Basis"], "delete"), loc)
                                             val e = (EApp (e, texp), loc)
                                         in
                                             (EApp (e, sqlexp), loc)
                                         end)

       | UNDER                          (EWild, s (UNDERleft, UNDERright))

enterDml :                              (inDml := true)
leaveDml :                              (inDml := false)

texp   : SYMBOL                         (EVar ([], SYMBOL), s (SYMBOLleft, SYMBOLright))
       | LBRACE LBRACE eexp RBRACE RBRACE (eexp)

fields : fident                         ([fident])
       | fident COMMA fields            (fident :: fields)

sqlexps: sqlexp                         ([sqlexp])
       | sqlexp COMMA sqlexps           (sqlexp :: sqlexps)

fsets  : fident EQ sqlexp               ([(fident, sqlexp)])
       | fident EQ sqlexp COMMA fsets   ((fident, sqlexp) :: fsets)

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)
                                             val et = tagIn END_TAG
                                         in
                                             if #1 tag = et then
                                                 if et = "lform" then
                                                     (EApp ((EVar (["Basis"], "lform"), pos),
                                                            xml), pos)
                                                 else
                                                     (EApp (#2 tag, xml), pos)
                                             else
                                                 (if ErrorMsg.anyErrors () then
                                                      ()
                                                  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 bt = tagIn BEGIN_TAG
                                             val pos = s (BEGIN_TAGleft, BEGIN_TAGright)
                                         in
                                             (bt,
                                              (EVar ([], bt), 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))
       | tident DOT LBRACE LBRACE cexp RBRACE RBRACE (Fields (tident, cexp))

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)
                                          in
                                              if !inDml then
                                                  let
                                                      val e = (EVar (["Basis"], "sql_field"), loc)
                                                      val e = (ECApp (e, (CName "T", loc)), loc)
                                                  in
                                                      (ECApp (e, (CName CSYMBOL, loc)), loc)
                                                  end
                                              else
                                                  let
                                                      val e = (EVar (["Basis"], "sql_exp"), loc)
                                                  in
                                                      (ECApp (e, (CName CSYMBOL, loc)), loc)
                                                  end
                                          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)

obitem : sqlexp diropt                  (sqlexp, diropt)

obexps : obitem                         (let
                                             val loc = s (obitemleft, obitemright)

                                             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),
                                                            #1 obitem), loc)
                                             val e = (EApp (e, #2 obitem), loc)
                                         in
                                             (EApp (e, e'), loc)
                                         end)
       | obitem COMMA obexps            (let
                                             val loc = s (obitemleft, obexpsright)

                                             val e = (EApp ((EVar (["Basis"], "sql_order_by_Cons"), loc),
                                                            #1 obitem), loc)
                                             val e = (EApp (e, #2 obitem), loc)
                                         in
                                             (EApp (e, obexps), loc)
                                         end)

diropt :                                (EVar (["Basis"], "sql_asc"), dummy)
       | ASC                            (EVar (["Basis"], "sql_asc"), s (ASCleft, ASCright))
       | DESC                           (EVar (["Basis"], "sql_desc"), s (DESCleft, DESCright))

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")