summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/iflow.sml418
-rw-r--r--src/sources2
-rw-r--r--src/sql.sml428
3 files changed, 431 insertions, 417 deletions
diff --git a/src/iflow.sml b/src/iflow.sml
index c65271b3..fe0be731 100644
--- a/src/iflow.sml
+++ b/src/iflow.sml
@@ -28,6 +28,7 @@
structure Iflow :> IFLOW = struct
open Mono
+open Sql
structure IS = IntBinarySet
structure IM = IntBinaryMap
@@ -57,43 +58,6 @@ val writers = ["htmlifyInt_w",
val writers = SS.addList (SS.empty, writers)
-type lvar = int
-
-datatype func =
- DtCon0 of string
- | DtCon1 of string
- | UnCon of string
- | Other of string
-
-datatype exp =
- Const of Prim.t
- | Var of int
- | Lvar of lvar
- | Func of func * exp list
- | Recd of (string * exp) list
- | Proj of exp * string
-
-datatype reln =
- Known
- | Sql of string
- | PCon0 of string
- | PCon1 of string
- | Eq
- | Ne
- | Lt
- | Le
- | Gt
- | Ge
-
-datatype prop =
- True
- | False
- | Unknown
- | And of prop * prop
- | Or of prop * prop
- | Reln of reln * exp list
- | Cond of exp * prop
-
local
open Print
val string = PD.string
@@ -226,8 +190,6 @@ fun p_atom a =
AReln x => Reln x
| ACond x => Cond x)
-val debug = ref false
-
(* Congruence closure *)
structure Cc :> sig
type database
@@ -828,384 +790,6 @@ fun patCon pc =
PConVar n => "C" ^ Int.toString n
| PConFfi {mod = m, datatyp = d, con = c, ...} => m ^ "." ^ d ^ "." ^ c
-datatype chunk =
- String of string
- | Exp of Mono.exp
-
-fun chunkify e =
- case #1 e of
- EPrim (Prim.String s) => [String s]
- | EStrcat (e1, e2) =>
- let
- val chs1 = chunkify e1
- val chs2 = chunkify e2
- in
- case chs2 of
- String s2 :: chs2' =>
- (case List.last chs1 of
- String s1 => List.take (chs1, length chs1 - 1) @ String (s1 ^ s2) :: chs2'
- | _ => chs1 @ chs2)
- | _ => chs1 @ chs2
- end
- | _ => [Exp e]
-
-type 'a parser = chunk list -> ('a * chunk list) option
-
-fun always v chs = SOME (v, chs)
-
-fun parse p s =
- case p (chunkify s) of
- SOME (v, []) => SOME v
- | _ => NONE
-
-fun const s chs =
- case chs of
- String s' :: chs => if String.isPrefix s s' then
- SOME ((), if size s = size s' then
- chs
- else
- String (String.extract (s', size s, NONE)) :: chs)
- else
- NONE
- | _ => NONE
-
-fun follow p1 p2 chs =
- case p1 chs of
- NONE => NONE
- | SOME (v1, chs) =>
- case p2 chs of
- NONE => NONE
- | SOME (v2, chs) => SOME ((v1, v2), chs)
-
-fun wrap p f chs =
- case p chs of
- NONE => NONE
- | SOME (v, chs) => SOME (f v, chs)
-
-fun wrapP p f chs =
- case p chs of
- NONE => NONE
- | SOME (v, chs) =>
- case f v of
- NONE => NONE
- | SOME r => SOME (r, chs)
-
-fun alt p1 p2 chs =
- case p1 chs of
- NONE => p2 chs
- | v => v
-
-fun altL ps =
- case rev ps of
- [] => (fn _ => NONE)
- | p :: ps =>
- foldl (fn (p1, p2) => alt p1 p2) p ps
-
-fun opt p chs =
- case p chs of
- NONE => SOME (NONE, chs)
- | SOME (v, chs) => SOME (SOME v, chs)
-
-fun skip cp chs =
- case chs of
- String "" :: chs => skip cp chs
- | String s :: chs' => if cp (String.sub (s, 0)) then
- skip cp (String (String.extract (s, 1, NONE)) :: chs')
- else
- SOME ((), chs)
- | _ => SOME ((), chs)
-
-fun keep cp chs =
- case chs of
- String "" :: chs => keep cp chs
- | String s :: chs' =>
- let
- val (befor, after) = Substring.splitl cp (Substring.full s)
- in
- if Substring.isEmpty befor then
- NONE
- else
- SOME (Substring.string befor,
- if Substring.isEmpty after then
- chs'
- else
- String (Substring.string after) :: chs')
- end
- | _ => NONE
-
-fun ws p = wrap (follow (skip (fn ch => ch = #" "))
- (follow p (skip (fn ch => ch = #" ")))) (#1 o #2)
-
-fun log name p chs =
- (if !debug then
- (print (name ^ ": ");
- app (fn String s => print s
- | _ => print "???") chs;
- print "\n")
- else
- ();
- p chs)
-
-fun list p chs =
- altL [wrap (follow p (follow (ws (const ",")) (list p)))
- (fn (v, ((), ls)) => v :: ls),
- wrap (ws p) (fn v => [v]),
- always []] chs
-
-val ident = keep (fn ch => Char.isAlphaNum ch orelse ch = #"_")
-
-val t_ident = wrapP ident (fn s => if String.isPrefix "T_" s then
- SOME (String.extract (s, 2, NONE))
- else
- NONE)
-val uw_ident = wrapP ident (fn s => if String.isPrefix "uw_" s andalso size s >= 4 then
- SOME (str (Char.toUpper (String.sub (s, 3)))
- ^ String.extract (s, 4, NONE))
- else
- NONE)
-
-val field = wrap (follow t_ident
- (follow (const ".")
- uw_ident))
- (fn (t, ((), f)) => (t, f))
-
-datatype Rel =
- Exps of exp * exp -> prop
- | Props of prop * prop -> prop
-
-datatype sqexp =
- SqConst of Prim.t
- | SqTrue
- | SqFalse
- | SqNot of sqexp
- | Field of string * string
- | Computed of string
- | Binop of Rel * sqexp * sqexp
- | SqKnown of sqexp
- | Inj of Mono.exp
- | SqFunc of string * sqexp
- | Unmodeled
- | Null
-
-fun cmp s r = wrap (const s) (fn () => Exps (fn (e1, e2) => Reln (r, [e1, e2])))
-
-val sqbrel = altL [cmp "=" Eq,
- cmp "<>" Ne,
- cmp "<=" Le,
- cmp "<" Lt,
- cmp ">=" Ge,
- cmp ">" Gt,
- wrap (const "AND") (fn () => Props And),
- wrap (const "OR") (fn () => Props Or)]
-
-datatype ('a, 'b) sum = inl of 'a | inr of 'b
-
-fun string chs =
- case chs of
- String s :: chs =>
- if size s >= 2 andalso String.sub (s, 0) = #"'" then
- let
- fun loop (cs, acc) =
- case cs of
- [] => NONE
- | c :: cs =>
- if c = #"'" then
- SOME (String.implode (rev acc), cs)
- else if c = #"\\" then
- case cs of
- c :: cs => loop (cs, c :: acc)
- | _ => raise Fail "Iflow.string: Unmatched backslash escape"
- else
- loop (cs, c :: acc)
- in
- case loop (String.explode (String.extract (s, 1, NONE)), []) of
- NONE => NONE
- | SOME (s, []) => SOME (s, chs)
- | SOME (s, cs) => SOME (s, String (String.implode cs) :: chs)
- end
- else
- NONE
- | _ => NONE
-
-val prim =
- altL [wrap (follow (wrapP (follow (keep Char.isDigit) (follow (const ".") (keep Char.isDigit)))
- (fn (x, ((), y)) => Option.map Prim.Float (Real64.fromString (x ^ "." ^ y))))
- (opt (const "::float8"))) #1,
- wrap (follow (wrapP (keep Char.isDigit)
- (Option.map Prim.Int o Int64.fromString))
- (opt (const "::int8"))) #1,
- wrap (follow (opt (const "E")) (follow string (opt (const "::text"))))
- (Prim.String o #1 o #2)]
-
-fun known' chs =
- case chs of
- Exp (EFfi ("Basis", "sql_known"), _) :: chs => SOME ((), chs)
- | _ => NONE
-
-fun sqlify chs =
- case chs of
- Exp (EFfiApp ("Basis", f, [(e, _)]), _) :: chs =>
- if String.isPrefix "sqlify" f then
- SOME (e, chs)
- else
- NONE
- | Exp (ECase (e, [((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, NONE), _),
- (EPrim (Prim.String "TRUE"), _)),
- ((PCon (_, PConFfi {mod = "Basis", con = "False", ...}, NONE), _),
- (EPrim (Prim.String "FALSE"), _))], _), _) :: chs =>
- SOME (e, chs)
-
- | _ => NONE
-
-fun constK s = wrap (const s) (fn () => s)
-
-val funcName = altL [constK "COUNT",
- constK "MIN",
- constK "MAX",
- constK "SUM",
- constK "AVG"]
-
-val unmodeled = altL [const "COUNT(*)",
- const "CURRENT_TIMESTAMP"]
-
-fun sqexp chs =
- log "sqexp"
- (altL [wrap prim SqConst,
- wrap (const "TRUE") (fn () => SqTrue),
- wrap (const "FALSE") (fn () => SqFalse),
- wrap (const "NULL") (fn () => Null),
- wrap field Field,
- wrap uw_ident Computed,
- wrap known SqKnown,
- wrap func SqFunc,
- wrap unmodeled (fn () => Unmodeled),
- wrap sqlify Inj,
- wrap (follow (const "COALESCE(") (follow sqexp (follow (const ",")
- (follow (keep (fn ch => ch <> #")")) (const ")")))))
- (fn ((), (e, _)) => e),
- wrap (follow (const "(NOT ") (follow sqexp (const ")")))
- (fn ((), (e, _)) => SqNot e),
- wrap (follow (ws (const "("))
- (follow (wrap
- (follow sqexp
- (alt
- (wrap
- (follow (ws sqbrel)
- (ws sqexp))
- inl)
- (always (inr ()))))
- (fn (e1, sm) =>
- case sm of
- inl (bo, e2) => Binop (bo, e1, e2)
- | inr () => e1))
- (const ")")))
- (fn ((), (e, ())) => e)])
- chs
-
-and known chs = wrap (follow known' (follow (const "(") (follow sqexp (const ")"))))
- (fn ((), ((), (e, ()))) => e) chs
-
-and func chs = wrap (follow funcName (follow (const "(") (follow sqexp (const ")"))))
- (fn (f, ((), (e, ()))) => (f, e)) chs
-
-datatype sitem =
- SqField of string * string
- | SqExp of sqexp * string
-
-val sitem = alt (wrap (follow sqexp (follow (const " AS ") uw_ident))
- (fn (e, ((), s)) => SqExp (e, s)))
- (wrap field SqField)
-
-val select = log "select"
- (wrap (follow (const "SELECT ") (list sitem))
- (fn ((), ls) => ls))
-
-val fitem = wrap (follow uw_ident
- (follow (const " AS ")
- t_ident))
- (fn (t, ((), f)) => (t, f))
-
-val from = log "from"
- (wrap (follow (const "FROM ") (list fitem))
- (fn ((), ls) => ls))
-
-val wher = wrap (follow (ws (const "WHERE ")) sqexp)
- (fn ((), ls) => ls)
-
-type query1 = {Select : sitem list,
- From : (string * string) list,
- Where : sqexp option}
-
-val query1 = log "query1"
- (wrap (follow (follow select from) (opt wher))
- (fn ((fs, ts), wher) => {Select = fs, From = ts, Where = wher}))
-
-datatype query =
- Query1 of query1
- | Union of query * query
-
-val orderby = log "orderby"
- (wrap (follow (ws (const "ORDER BY "))
- (follow (list sqexp)
- (opt (ws (const "DESC")))))
- ignore)
-
-fun query chs = log "query"
- (wrap
- (follow
- (alt (wrap (follow (const "((")
- (follow query
- (follow (const ") UNION (")
- (follow query (const "))")))))
- (fn ((), (q1, ((), (q2, ())))) => Union (q1, q2)))
- (wrap query1 Query1))
- (opt orderby))
- #1)
- chs
-
-datatype dml =
- Insert of string * (string * sqexp) list
- | Delete of string * sqexp
- | Update of string * (string * sqexp) list * sqexp
-
-val insert = log "insert"
- (wrapP (follow (const "INSERT INTO ")
- (follow uw_ident
- (follow (const " (")
- (follow (list uw_ident)
- (follow (const ") VALUES (")
- (follow (list sqexp)
- (const ")")))))))
- (fn ((), (tab, ((), (fs, ((), (es, ())))))) =>
- (SOME (tab, ListPair.zipEq (fs, es)))
- handle ListPair.UnequalLengths => NONE))
-
-val delete = log "delete"
- (wrap (follow (const "DELETE FROM ")
- (follow uw_ident
- (follow (const " AS T_T WHERE ")
- sqexp)))
- (fn ((), (tab, ((), es))) => (tab, es)))
-
-val setting = log "setting"
- (wrap (follow uw_ident (follow (const " = ") sqexp))
- (fn (f, ((), e)) => (f, e)))
-
-val update = log "update"
- (wrap (follow (const "UPDATE ")
- (follow uw_ident
- (follow (const " AS T_T SET ")
- (follow (list setting)
- (follow (ws (const "WHERE "))
- sqexp)))))
- (fn ((), (tab, ((), (fs, ((), e))))) =>
- (tab, fs, e)))
-
-val dml = log "dml"
- (altL [wrap insert Insert,
- wrap delete Delete,
- wrap update Update])
-
type check = exp * ErrorMsg.span
structure St :> sig
diff --git a/src/sources b/src/sources
index aebe9de6..4011ce3b 100644
--- a/src/sources
+++ b/src/sources
@@ -180,6 +180,8 @@ mono_shake.sml
fuse.sig
fuse.sml
+sql.sml
+
iflow.sig
iflow.sml
diff --git a/src/sql.sml b/src/sql.sml
new file mode 100644
index 00000000..c314eb3d
--- /dev/null
+++ b/src/sql.sml
@@ -0,0 +1,428 @@
+structure Sql = struct
+
+open Mono
+
+val debug = ref false
+
+type lvar = int
+
+datatype func =
+ DtCon0 of string
+ | DtCon1 of string
+ | UnCon of string
+ | Other of string
+
+datatype exp =
+ Const of Prim.t
+ | Var of int
+ | Lvar of lvar
+ | Func of func * exp list
+ | Recd of (string * exp) list
+ | Proj of exp * string
+
+datatype reln =
+ Known
+ | Sql of string
+ | PCon0 of string
+ | PCon1 of string
+ | Eq
+ | Ne
+ | Lt
+ | Le
+ | Gt
+ | Ge
+
+datatype prop =
+ True
+ | False
+ | Unknown
+ | And of prop * prop
+ | Or of prop * prop
+ | Reln of reln * exp list
+ | Cond of exp * prop
+
+datatype chunk =
+ String of string
+ | Exp of Mono.exp
+
+fun chunkify e =
+ case #1 e of
+ EPrim (Prim.String s) => [String s]
+ | EStrcat (e1, e2) =>
+ let
+ val chs1 = chunkify e1
+ val chs2 = chunkify e2
+ in
+ case chs2 of
+ String s2 :: chs2' =>
+ (case List.last chs1 of
+ String s1 => List.take (chs1, length chs1 - 1) @ String (s1 ^ s2) :: chs2'
+ | _ => chs1 @ chs2)
+ | _ => chs1 @ chs2
+ end
+ | _ => [Exp e]
+
+type 'a parser = chunk list -> ('a * chunk list) option
+
+fun always v chs = SOME (v, chs)
+
+fun parse p s =
+ case p (chunkify s) of
+ SOME (v, []) => SOME v
+ | _ => NONE
+
+fun const s chs =
+ case chs of
+ String s' :: chs => if String.isPrefix s s' then
+ SOME ((), if size s = size s' then
+ chs
+ else
+ String (String.extract (s', size s, NONE)) :: chs)
+ else
+ NONE
+ | _ => NONE
+
+fun follow p1 p2 chs =
+ case p1 chs of
+ NONE => NONE
+ | SOME (v1, chs) =>
+ case p2 chs of
+ NONE => NONE
+ | SOME (v2, chs) => SOME ((v1, v2), chs)
+
+fun wrap p f chs =
+ case p chs of
+ NONE => NONE
+ | SOME (v, chs) => SOME (f v, chs)
+
+fun wrapP p f chs =
+ case p chs of
+ NONE => NONE
+ | SOME (v, chs) =>
+ case f v of
+ NONE => NONE
+ | SOME r => SOME (r, chs)
+
+fun alt p1 p2 chs =
+ case p1 chs of
+ NONE => p2 chs
+ | v => v
+
+fun altL ps =
+ case rev ps of
+ [] => (fn _ => NONE)
+ | p :: ps =>
+ foldl (fn (p1, p2) => alt p1 p2) p ps
+
+fun opt p chs =
+ case p chs of
+ NONE => SOME (NONE, chs)
+ | SOME (v, chs) => SOME (SOME v, chs)
+
+fun skip cp chs =
+ case chs of
+ String "" :: chs => skip cp chs
+ | String s :: chs' => if cp (String.sub (s, 0)) then
+ skip cp (String (String.extract (s, 1, NONE)) :: chs')
+ else
+ SOME ((), chs)
+ | _ => SOME ((), chs)
+
+fun keep cp chs =
+ case chs of
+ String "" :: chs => keep cp chs
+ | String s :: chs' =>
+ let
+ val (befor, after) = Substring.splitl cp (Substring.full s)
+ in
+ if Substring.isEmpty befor then
+ NONE
+ else
+ SOME (Substring.string befor,
+ if Substring.isEmpty after then
+ chs'
+ else
+ String (Substring.string after) :: chs')
+ end
+ | _ => NONE
+
+fun ws p = wrap (follow (skip (fn ch => ch = #" "))
+ (follow p (skip (fn ch => ch = #" ")))) (#1 o #2)
+
+fun log name p chs =
+ (if !debug then
+ (print (name ^ ": ");
+ app (fn String s => print s
+ | _ => print "???") chs;
+ print "\n")
+ else
+ ();
+ p chs)
+
+fun list p chs =
+ altL [wrap (follow p (follow (ws (const ",")) (list p)))
+ (fn (v, ((), ls)) => v :: ls),
+ wrap (ws p) (fn v => [v]),
+ always []] chs
+
+val ident = keep (fn ch => Char.isAlphaNum ch orelse ch = #"_")
+
+val t_ident = wrapP ident (fn s => if String.isPrefix "T_" s then
+ SOME (String.extract (s, 2, NONE))
+ else
+ NONE)
+val uw_ident = wrapP ident (fn s => if String.isPrefix "uw_" s andalso size s >= 4 then
+ SOME (str (Char.toUpper (String.sub (s, 3)))
+ ^ String.extract (s, 4, NONE))
+ else
+ NONE)
+
+val field = wrap (follow t_ident
+ (follow (const ".")
+ uw_ident))
+ (fn (t, ((), f)) => (t, f))
+
+datatype Rel =
+ Exps of exp * exp -> prop
+ | Props of prop * prop -> prop
+
+datatype sqexp =
+ SqConst of Prim.t
+ | SqTrue
+ | SqFalse
+ | SqNot of sqexp
+ | Field of string * string
+ | Computed of string
+ | Binop of Rel * sqexp * sqexp
+ | SqKnown of sqexp
+ | Inj of Mono.exp
+ | SqFunc of string * sqexp
+ | Unmodeled
+ | Null
+
+fun cmp s r = wrap (const s) (fn () => Exps (fn (e1, e2) => Reln (r, [e1, e2])))
+
+val sqbrel = altL [cmp "=" Eq,
+ cmp "<>" Ne,
+ cmp "<=" Le,
+ cmp "<" Lt,
+ cmp ">=" Ge,
+ cmp ">" Gt,
+ wrap (const "AND") (fn () => Props And),
+ wrap (const "OR") (fn () => Props Or)]
+
+datatype ('a, 'b) sum = inl of 'a | inr of 'b
+
+fun string chs =
+ case chs of
+ String s :: chs =>
+ if size s >= 2 andalso String.sub (s, 0) = #"'" then
+ let
+ fun loop (cs, acc) =
+ case cs of
+ [] => NONE
+ | c :: cs =>
+ if c = #"'" then
+ SOME (String.implode (rev acc), cs)
+ else if c = #"\\" then
+ case cs of
+ c :: cs => loop (cs, c :: acc)
+ | _ => raise Fail "Iflow.string: Unmatched backslash escape"
+ else
+ loop (cs, c :: acc)
+ in
+ case loop (String.explode (String.extract (s, 1, NONE)), []) of
+ NONE => NONE
+ | SOME (s, []) => SOME (s, chs)
+ | SOME (s, cs) => SOME (s, String (String.implode cs) :: chs)
+ end
+ else
+ NONE
+ | _ => NONE
+
+val prim =
+ altL [wrap (follow (wrapP (follow (keep Char.isDigit) (follow (const ".") (keep Char.isDigit)))
+ (fn (x, ((), y)) => Option.map Prim.Float (Real64.fromString (x ^ "." ^ y))))
+ (opt (const "::float8"))) #1,
+ wrap (follow (wrapP (keep Char.isDigit)
+ (Option.map Prim.Int o Int64.fromString))
+ (opt (const "::int8"))) #1,
+ wrap (follow (opt (const "E")) (follow string (opt (const "::text"))))
+ (Prim.String o #1 o #2)]
+
+fun known' chs =
+ case chs of
+ Exp (EFfi ("Basis", "sql_known"), _) :: chs => SOME ((), chs)
+ | _ => NONE
+
+fun sqlify chs =
+ case chs of
+ Exp (EFfiApp ("Basis", f, [(e, _)]), _) :: chs =>
+ if String.isPrefix "sqlify" f then
+ SOME (e, chs)
+ else
+ NONE
+ | Exp (ECase (e, [((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, NONE), _),
+ (EPrim (Prim.String "TRUE"), _)),
+ ((PCon (_, PConFfi {mod = "Basis", con = "False", ...}, NONE), _),
+ (EPrim (Prim.String "FALSE"), _))], _), _) :: chs =>
+ SOME (e, chs)
+
+ | _ => NONE
+
+fun constK s = wrap (const s) (fn () => s)
+
+val funcName = altL [constK "COUNT",
+ constK "MIN",
+ constK "MAX",
+ constK "SUM",
+ constK "AVG"]
+
+val unmodeled = altL [const "COUNT(*)",
+ const "CURRENT_TIMESTAMP"]
+
+fun sqexp chs =
+ log "sqexp"
+ (altL [wrap prim SqConst,
+ wrap (const "TRUE") (fn () => SqTrue),
+ wrap (const "FALSE") (fn () => SqFalse),
+ wrap (const "NULL") (fn () => Null),
+ wrap field Field,
+ wrap uw_ident Computed,
+ wrap known SqKnown,
+ wrap func SqFunc,
+ wrap unmodeled (fn () => Unmodeled),
+ wrap sqlify Inj,
+ wrap (follow (const "COALESCE(") (follow sqexp (follow (const ",")
+ (follow (keep (fn ch => ch <> #")")) (const ")")))))
+ (fn ((), (e, _)) => e),
+ wrap (follow (const "(NOT ") (follow sqexp (const ")")))
+ (fn ((), (e, _)) => SqNot e),
+ wrap (follow (ws (const "("))
+ (follow (wrap
+ (follow sqexp
+ (alt
+ (wrap
+ (follow (ws sqbrel)
+ (ws sqexp))
+ inl)
+ (always (inr ()))))
+ (fn (e1, sm) =>
+ case sm of
+ inl (bo, e2) => Binop (bo, e1, e2)
+ | inr () => e1))
+ (const ")")))
+ (fn ((), (e, ())) => e)])
+ chs
+
+and known chs = wrap (follow known' (follow (const "(") (follow sqexp (const ")"))))
+ (fn ((), ((), (e, ()))) => e) chs
+
+and func chs = wrap (follow funcName (follow (const "(") (follow sqexp (const ")"))))
+ (fn (f, ((), (e, ()))) => (f, e)) chs
+
+datatype sitem =
+ SqField of string * string
+ | SqExp of sqexp * string
+
+val sitem = alt (wrap (follow sqexp (follow (const " AS ") uw_ident))
+ (fn (e, ((), s)) => SqExp (e, s)))
+ (wrap field SqField)
+
+val select = log "select"
+ (wrap (follow (const "SELECT ") (list sitem))
+ (fn ((), ls) => ls))
+
+val fitem = wrap (follow uw_ident
+ (follow (const " AS ")
+ t_ident))
+ (fn (t, ((), f)) => (t, f))
+
+val from = log "from"
+ (wrap (follow (const "FROM ") (list fitem))
+ (fn ((), ls) => ls))
+
+val wher = wrap (follow (ws (const "WHERE ")) sqexp)
+ (fn ((), ls) => ls)
+
+type query1 = {Select : sitem list,
+ From : (string * string) list,
+ Where : sqexp option}
+
+val query1 = log "query1"
+ (wrap (follow (follow select from) (opt wher))
+ (fn ((fs, ts), wher) => {Select = fs, From = ts, Where = wher}))
+
+datatype query =
+ Query1 of query1
+ | Union of query * query
+
+val orderby = log "orderby"
+ (wrap (follow (ws (const "ORDER BY "))
+ (follow (list sqexp)
+ (opt (ws (const "DESC")))))
+ ignore)
+
+fun query chs = log "query"
+ (wrap
+ (follow
+ (alt (wrap (follow (const "((")
+ (follow query
+ (follow (const ") UNION (")
+ (follow query (const "))")))))
+ (fn ((), (q1, ((), (q2, ())))) => Union (q1, q2)))
+ (wrap query1 Query1))
+ (opt orderby))
+ #1)
+ chs
+
+datatype dml =
+ Insert of string * (string * sqexp) list
+ | Delete of string * sqexp
+ | Update of string * (string * sqexp) list * sqexp
+
+val insert = log "insert"
+ (wrapP (follow (const "INSERT INTO ")
+ (follow uw_ident
+ (follow (const " (")
+ (follow (list uw_ident)
+ (follow (const ") VALUES (")
+ (follow (list sqexp)
+ (const ")")))))))
+ (fn ((), (tab, ((), (fs, ((), (es, ())))))) =>
+ (SOME (tab, ListPair.zipEq (fs, es)))
+ handle ListPair.UnequalLengths => NONE))
+
+val delete = log "delete"
+ (wrap (follow (const "DELETE FROM ")
+ (follow uw_ident
+ (follow (const " AS T_T WHERE ")
+ sqexp)))
+ (fn ((), (tab, ((), es))) => (tab, es)))
+
+val setting = log "setting"
+ (wrap (follow uw_ident (follow (const " = ") sqexp))
+ (fn (f, ((), e)) => (f, e)))
+
+val update = log "update"
+ (wrap (follow (const "UPDATE ")
+ (follow uw_ident
+ (follow (const " AS T_T SET ")
+ (follow (list setting)
+ (follow (ws (const "WHERE "))
+ sqexp)))))
+ (fn ((), (tab, ((), (fs, ((), e))))) =>
+ (tab, fs, e)))
+
+val dml = log "dml"
+ (altL [wrap insert Insert,
+ wrap delete Delete,
+ wrap update Update])
+
+datatype querydml =
+ Query of query
+ | Dml of dml
+
+val querydml = log "querydml" (altL [wrap dml Dml, wrap query Query])
+
+end