ziv@2204: structure Sql :> SQL = struct
ezyang@1697: 
ezyang@1697: open Mono
ezyang@1697: 
ezyang@1697: val debug = ref false
ezyang@1697: 
ezyang@1697: type lvar = int
ezyang@1697: 
ezyang@1697: datatype func =
ezyang@1697:          DtCon0 of string
ezyang@1697:        | DtCon1 of string
ezyang@1697:        | UnCon of string
ezyang@1697:        | Other of string
ezyang@1697: 
ezyang@1697: datatype exp =
ezyang@1697:          Const of Prim.t
ezyang@1697:        | Var of int
ezyang@1697:        | Lvar of lvar
ezyang@1697:        | Func of func * exp list
ezyang@1697:        | Recd of (string * exp) list
ezyang@1697:        | Proj of exp * string
ezyang@1697: 
ziv@2216: datatype cmp =
ziv@2216:          Eq
ezyang@1697:        | Ne
ezyang@1697:        | Lt
ezyang@1697:        | Le
ezyang@1697:        | Gt
ezyang@1697:        | Ge
ezyang@1697: 
ziv@2216: datatype reln =
ziv@2216:          Known
ziv@2216:        | Sql of string
ziv@2216:        | PCon0 of string
ziv@2216:        | PCon1 of string
ziv@2216:        | Cmp of cmp
ziv@2216: 
ziv@2216: datatype lop =
ziv@2216:          And
ziv@2216:        | Or
ziv@2216: 
ezyang@1697: datatype prop =
ezyang@1697:          True
ezyang@1697:        | False
ezyang@1697:        | Unknown
ziv@2216:        | Lop of lop * prop * prop
ezyang@1697:        | Reln of reln * exp list
ezyang@1697:        | Cond of exp * prop
ezyang@1697: 
ezyang@1697: datatype chunk =
ezyang@1697:          String of string
ezyang@1697:        | Exp of Mono.exp
ezyang@1697: 
ezyang@1697: fun chunkify e =
ezyang@1697:     case #1 e of
adam@2048:         EPrim (Prim.String (_, s)) => [String s]
ezyang@1697:       | EStrcat (e1, e2) =>
ezyang@1697:         let
ezyang@1697:             val chs1 = chunkify e1
ezyang@1697:             val chs2 = chunkify e2
ezyang@1697:         in
ezyang@1697:             case chs2 of
ezyang@1697:                 String s2 :: chs2' =>
ezyang@1697:                 (case List.last chs1 of
ezyang@1697:                      String s1 => List.take (chs1, length chs1 - 1) @ String (s1 ^ s2) :: chs2'
ezyang@1697:                    | _ => chs1 @ chs2)
ezyang@1697:               | _ => chs1 @ chs2
ezyang@1697:         end
ezyang@1697:       | _ => [Exp e]
ezyang@1697: 
ezyang@1697: type 'a parser = chunk list -> ('a * chunk list) option
ezyang@1697: 
ezyang@1697: fun always v chs = SOME (v, chs)
ezyang@1697: 
ezyang@1697: fun parse p s =
ezyang@1697:     case p (chunkify s) of
ezyang@1697:         SOME (v, []) => SOME v
ezyang@1697:       | _ => NONE
ezyang@1697: 
ezyang@1697: fun const s chs =
ezyang@1697:     case chs of
ezyang@1697:         String s' :: chs => if String.isPrefix s s' then
ezyang@1697:                                 SOME ((), if size s = size s' then
ezyang@1697:                                               chs
ezyang@1697:                                           else
ezyang@1697:                                               String (String.extract (s', size s, NONE)) :: chs)
ezyang@1697:                             else
ezyang@1697:                                 NONE
ezyang@1697:       | _ => NONE
ezyang@1697: 
ezyang@1697: fun follow p1 p2 chs =
ezyang@1697:     case p1 chs of
ezyang@1697:         NONE => NONE
ezyang@1697:       | SOME (v1, chs) =>
ezyang@1697:         case p2 chs of
ezyang@1697:             NONE => NONE
ezyang@1697:           | SOME (v2, chs) => SOME ((v1, v2), chs)
ezyang@1697: 
ezyang@1697: fun wrap p f chs =
ezyang@1697:     case p chs of
ezyang@1697:         NONE => NONE
ezyang@1697:       | SOME (v, chs) => SOME (f v, chs)
ezyang@1697: 
ezyang@1697: fun wrapP p f chs =
ezyang@1697:     case p chs of
ezyang@1697:         NONE => NONE
ezyang@1697:       | SOME (v, chs) =>
ezyang@1697:         case f v of
ezyang@1697:             NONE => NONE
ezyang@1697:           | SOME r => SOME (r, chs)
ezyang@1697: 
ezyang@1697: fun alt p1 p2 chs =
ezyang@1697:     case p1 chs of
ezyang@1697:         NONE => p2 chs
ezyang@1697:       | v => v
ezyang@1697: 
ezyang@1697: fun altL ps =
ezyang@1697:     case rev ps of
ezyang@1697:         [] => (fn _ => NONE)
ezyang@1697:       | p :: ps =>
ezyang@1697:         foldl (fn (p1, p2) => alt p1 p2) p ps
ezyang@1697: 
ezyang@1697: fun opt p chs =
ezyang@1697:     case p chs of
ezyang@1697:         NONE => SOME (NONE, chs)
ezyang@1697:       | SOME (v, chs) => SOME (SOME v, chs)
ezyang@1697: 
ezyang@1697: fun skip cp chs =
ezyang@1697:     case chs of
ezyang@1697:         String "" :: chs => skip cp chs
ezyang@1697:       | String s :: chs' => if cp (String.sub (s, 0)) then
ezyang@1697:                                 skip cp (String (String.extract (s, 1, NONE)) :: chs')
ezyang@1697:                             else
ezyang@1697:                                 SOME ((), chs)
ezyang@1697:       | _ => SOME ((), chs)
ezyang@1697: 
ezyang@1697: fun keep cp chs =
ezyang@1697:     case chs of
ezyang@1697:         String "" :: chs => keep cp chs
ezyang@1697:       | String s :: chs' =>
ezyang@1697:         let
ezyang@1697:             val (befor, after) = Substring.splitl cp (Substring.full s)
ezyang@1697:         in
ezyang@1697:             if Substring.isEmpty befor then
ezyang@1697:                 NONE
ezyang@1697:             else
ezyang@1697:                 SOME (Substring.string befor,
ezyang@1697:                       if Substring.isEmpty after then
ezyang@1697:                           chs'
ezyang@1697:                       else
ezyang@1697:                           String (Substring.string after) :: chs')
ezyang@1697:         end
ezyang@1697:       | _ => NONE
ezyang@1697: 
ezyang@1697: fun ws p = wrap (follow (skip (fn ch => ch = #" "))
ezyang@1697:                         (follow p (skip (fn ch => ch = #" ")))) (#1 o #2)
ezyang@1697: 
ezyang@1697: fun log name p chs =
ezyang@1697:     (if !debug then
ezyang@1697:          (print (name ^ ": ");
ezyang@1697:           app (fn String s => print s
ezyang@1697:                 | _ => print "???") chs;
ezyang@1697:           print "\n")
ezyang@1697:      else
ezyang@1697:          ();
ezyang@1697:      p chs)
ezyang@1697: 
ezyang@1697: fun list p chs =
ezyang@1697:     altL [wrap (follow p (follow (ws (const ",")) (list p)))
ezyang@1697:                (fn (v, ((), ls)) => v :: ls),
ezyang@1697:           wrap (ws p) (fn v => [v]),
ezyang@1697:           always []] chs
ezyang@1697: 
ezyang@1697: val ident = keep (fn ch => Char.isAlphaNum ch orelse ch = #"_")
ezyang@1697: 
ezyang@1697: val t_ident = wrapP ident (fn s => if String.isPrefix "T_" s then
ezyang@1697:                                        SOME (String.extract (s, 2, NONE))
ezyang@1697:                                    else
ezyang@1697:                                        NONE)
ezyang@1697: val uw_ident = wrapP ident (fn s => if String.isPrefix "uw_" s andalso size s >= 4 then
ezyang@1697:                                         SOME (str (Char.toUpper (String.sub (s, 3)))
ezyang@1697:                                               ^ String.extract (s, 4, NONE))
ezyang@1697:                                     else
ezyang@1697:                                         NONE)
ezyang@1697: 
ziv@2209: val field = wrap (follow (opt (follow t_ident (const ".")))
ziv@2209:                          uw_ident)
ziv@2209:                  (fn (SOME (t, ()), f) => (t, f)
ziv@2209:                    | (NONE, f) => ("T", f)) (* Should probably deal with this MySQL/SQLite case better some day. *)
ezyang@1697: 
ezyang@1697: datatype Rel =
ziv@2216:          RCmp of cmp
ziv@2216:        | RLop of lop
ezyang@1697: 
ezyang@1697: datatype sqexp =
ezyang@1697:          SqConst of Prim.t
ezyang@1697:        | SqTrue
ezyang@1697:        | SqFalse
ezyang@1697:        | SqNot of sqexp
ezyang@1697:        | Field of string * string
ezyang@1697:        | Computed of string
ezyang@1697:        | Binop of Rel * sqexp * sqexp
ezyang@1697:        | SqKnown of sqexp
ezyang@1697:        | Inj of Mono.exp
ezyang@1697:        | SqFunc of string * sqexp
ezyang@1697:        | Unmodeled
ezyang@1697:        | Null
ezyang@1697: 
ziv@2216: fun cmp s r = wrap (const s) (fn () => RCmp r)
ezyang@1697: 
ezyang@1697: val sqbrel = altL [cmp "=" Eq,
ezyang@1697:                    cmp "<>" Ne,
ezyang@1697:                    cmp "<=" Le,
ezyang@1697:                    cmp "<" Lt,
ezyang@1697:                    cmp ">=" Ge,
ezyang@1697:                    cmp ">" Gt,
ziv@2216:                    wrap (const "AND") (fn () => RLop Or),
ziv@2216:                    wrap (const "OR") (fn () => RLop And)]
ezyang@1697: 
ezyang@1697: datatype ('a, 'b) sum = inl of 'a | inr of 'b
ezyang@1697: 
ezyang@1697: fun string chs =
ezyang@1697:     case chs of
ezyang@1697:         String s :: chs =>
ezyang@1697:         if size s >= 2 andalso String.sub (s, 0) = #"'" then
ezyang@1697:             let
ezyang@1697:                 fun loop (cs, acc) =
ezyang@1697:                     case cs of
ezyang@1697:                         [] => NONE
ezyang@1697:                       | c :: cs =>
ezyang@1697:                         if c = #"'" then
ezyang@1697:                             SOME (String.implode (rev acc), cs)
ezyang@1697:                         else if c = #"\\" then
ezyang@1697:                             case cs of
ezyang@1697:                                 c :: cs => loop (cs, c :: acc)
ezyang@1697:                               | _ => raise Fail "Iflow.string: Unmatched backslash escape"
ezyang@1697:                         else
ezyang@1697:                             loop (cs, c :: acc)
ezyang@1697:             in
ezyang@1697:                 case loop (String.explode (String.extract (s, 1, NONE)), []) of
ezyang@1697:                     NONE => NONE
ezyang@1697:                   | SOME (s, []) => SOME (s, chs)
ezyang@1697:                   | SOME (s, cs) => SOME (s, String (String.implode cs) :: chs)
ezyang@1697:             end
ezyang@1697:         else
ezyang@1697:             NONE
ziv@2202:       | _ => NONE
ezyang@1697: 
ezyang@1697: val prim =
ezyang@1697:     altL [wrap (follow (wrapP (follow (keep Char.isDigit) (follow (const ".") (keep Char.isDigit)))
ezyang@1697:                               (fn (x, ((), y)) => Option.map Prim.Float (Real64.fromString (x ^ "." ^ y))))
ezyang@1697:                        (opt (const "::float8"))) #1,
ezyang@1697:           wrap (follow (wrapP (keep Char.isDigit)
ezyang@1697:                               (Option.map Prim.Int o Int64.fromString))
ezyang@1697:                        (opt (const "::int8"))) #1,
ezyang@1697:           wrap (follow (opt (const "E")) (follow string (opt (const "::text"))))
adam@2048:                ((fn s => Prim.String (Prim.Normal, s)) o #1 o #2)]
ezyang@1697: 
ezyang@1697: fun known' chs =
ezyang@1697:     case chs of
ezyang@1697:         Exp (EFfi ("Basis", "sql_known"), _) :: chs => SOME ((), chs)
ezyang@1697:       | _ => NONE
ezyang@1697: 
ezyang@1697: fun sqlify chs =
ezyang@1697:     case chs of
ezyang@1697:         Exp (EFfiApp ("Basis", f, [(e, _)]), _) :: chs =>
ezyang@1697:         if String.isPrefix "sqlify" f then
ezyang@1697:             SOME (e, chs)
ezyang@1697:         else
ezyang@1697:             NONE
ezyang@1697:       | Exp (ECase (e, [((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, NONE), _),
adam@2048:                          (EPrim (Prim.String (Prim.Normal, "TRUE")), _)),
ezyang@1697:                         ((PCon (_, PConFfi {mod = "Basis", con = "False", ...}, NONE), _),
adam@2048:                          (EPrim (Prim.String (Prim.Normal, "FALSE")), _))], _), _) :: chs =>
ezyang@1697:         SOME (e, chs)
ziv@2202: 
ezyang@1697:       | _ => NONE
ezyang@1697: 
ziv@2213: fun sqlifySqlcache chs =
ziv@2213:     case chs of
ziv@2215:       (* Could have variables as well as FFIs. *)
ziv@2215:         Exp (e as (ERel _, _)) :: chs => SOME (e, chs)
ziv@2215:       (* If it is an FFI, match the entire expression. *)
ziv@2215:       | Exp (e as (EFfiApp ("Basis", f, [(_, _)]), _)) :: chs =>
ziv@2213:         if String.isPrefix "sqlify" f then
ziv@2215:             SOME (e, chs)
ziv@2213:         else
ziv@2213:             NONE
ziv@2213:       | Exp (ECase (e, [((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, NONE), _),
ziv@2213:                          (EPrim (Prim.String (Prim.Normal, "TRUE")), _)),
ziv@2213:                         ((PCon (_, PConFfi {mod = "Basis", con = "False", ...}, NONE), _),
ziv@2213:                          (EPrim (Prim.String (Prim.Normal, "FALSE")), _))], _), _) :: chs =>
ziv@2213:         SOME (e, chs)
ziv@2213: 
ziv@2213:       | _ => NONE
ziv@2213: 
ezyang@1697: fun constK s = wrap (const s) (fn () => s)
ezyang@1697: 
ezyang@1697: val funcName = altL [constK "COUNT",
ezyang@1697:                      constK "MIN",
ezyang@1697:                      constK "MAX",
ezyang@1697:                      constK "SUM",
ezyang@1697:                      constK "AVG"]
ezyang@1697: 
ezyang@1697: val unmodeled = altL [const "COUNT(*)",
ezyang@1697:                       const "CURRENT_TIMESTAMP"]
ezyang@1697: 
ziv@2213: val sqlcacheMode = ref false;
ziv@2213: 
ezyang@1697: fun sqexp chs =
ezyang@1697:     log "sqexp"
ezyang@1697:     (altL [wrap prim SqConst,
ezyang@1697:            wrap (const "TRUE") (fn () => SqTrue),
ezyang@1697:            wrap (const "FALSE") (fn () => SqFalse),
ezyang@1697:            wrap (const "NULL") (fn () => Null),
ezyang@1697:            wrap field Field,
ezyang@1697:            wrap uw_ident Computed,
ezyang@1697:            wrap known SqKnown,
ezyang@1697:            wrap func SqFunc,
ezyang@1697:            wrap unmodeled (fn () => Unmodeled),
ziv@2213:            wrap (if !sqlcacheMode then sqlifySqlcache else sqlify) Inj,
ezyang@1697:            wrap (follow (const "COALESCE(") (follow sqexp (follow (const ",")
ezyang@1697:                                                                   (follow (keep (fn ch => ch <> #")")) (const ")")))))
ezyang@1697:                 (fn ((), (e, _)) => e),
ezyang@1697:            wrap (follow (const "(NOT ") (follow sqexp (const ")")))
ezyang@1697:                 (fn ((), (e, _)) => SqNot e),
ezyang@1697:            wrap (follow (ws (const "("))
ezyang@1697:                         (follow (wrap
ezyang@1697:                                      (follow sqexp
ezyang@1697:                                              (alt
ezyang@1697:                                                   (wrap
ezyang@1697:                                                        (follow (ws sqbrel)
ezyang@1697:                                                                (ws sqexp))
ezyang@1697:                                                        inl)
ezyang@1697:                                                   (always (inr ()))))
ezyang@1697:                                      (fn (e1, sm) =>
ezyang@1697:                                          case sm of
ezyang@1697:                                              inl (bo, e2) => Binop (bo, e1, e2)
ezyang@1697:                                            | inr () => e1))
ezyang@1697:                                 (const ")")))
ezyang@1697:                 (fn ((), (e, ())) => e)])
ezyang@1697:     chs
ezyang@1697: 
ezyang@1697: and known chs = wrap (follow known' (follow (const "(") (follow sqexp (const ")"))))
ezyang@1697:                      (fn ((), ((), (e, ()))) => e) chs
ziv@2202: 
ezyang@1697: and func chs = wrap (follow funcName (follow (const "(") (follow sqexp (const ")"))))
ezyang@1697:                     (fn (f, ((), (e, ()))) => (f, e)) chs
ezyang@1697: 
ezyang@1697: datatype sitem =
ezyang@1697:          SqField of string * string
ezyang@1697:        | SqExp of sqexp * string
ezyang@1697: 
ezyang@1697: val sitem = alt (wrap (follow sqexp (follow (const " AS ") uw_ident))
ezyang@1697:                       (fn (e, ((), s)) => SqExp (e, s)))
ezyang@1697:                 (wrap field SqField)
ezyang@1697: 
ezyang@1697: val select = log "select"
ezyang@1697:              (wrap (follow (const "SELECT ") (list sitem))
ezyang@1697:                    (fn ((), ls) => ls))
ezyang@1697: 
ezyang@1697: val fitem = wrap (follow uw_ident
ezyang@1697:                          (follow (const " AS ")
ezyang@1697:                                  t_ident))
ezyang@1697:                  (fn (t, ((), f)) => (t, f))
ezyang@1697: 
ezyang@1697: val from = log "from"
ezyang@1697:            (wrap (follow (const "FROM ") (list fitem))
ezyang@1697:                  (fn ((), ls) => ls))
ezyang@1697: 
ezyang@1697: val wher = wrap (follow (ws (const "WHERE ")) sqexp)
ezyang@1697:            (fn ((), ls) => ls)
ezyang@1697: 
ezyang@1697: type query1 = {Select : sitem list,
ezyang@1697:               From : (string * string) list,
ezyang@1697:               Where : sqexp option}
ezyang@1697: 
ezyang@1697: val query1 = log "query1"
ezyang@1697:                 (wrap (follow (follow select from) (opt wher))
ezyang@1697:                       (fn ((fs, ts), wher) => {Select = fs, From = ts, Where = wher}))
ezyang@1697: 
ezyang@1697: datatype query =
ezyang@1697:          Query1 of query1
ezyang@1697:        | Union of query * query
ezyang@1697: 
ezyang@1697: val orderby = log "orderby"
ezyang@1697:               (wrap (follow (ws (const "ORDER BY "))
ezyang@1697:                             (follow (list sqexp)
ezyang@1697:                                     (opt (ws (const "DESC")))))
ezyang@1697:                     ignore)
ezyang@1697: 
ezyang@1697: fun query chs = log "query"
ezyang@1697:                 (wrap
ezyang@1697:                      (follow
ezyang@1697:                           (alt (wrap (follow (const "((")
ezyang@1697:                                              (follow query
ezyang@1697:                                                      (follow (const ") UNION (")
ezyang@1697:                                                              (follow query (const "))")))))
ezyang@1697:                                      (fn ((), (q1, ((), (q2, ())))) => Union (q1, q2)))
ezyang@1697:                                (wrap query1 Query1))
ezyang@1697:                           (opt orderby))
ezyang@1697:                      #1)
ezyang@1697:                 chs
ezyang@1697: 
ezyang@1697: datatype dml =
ezyang@1697:          Insert of string * (string * sqexp) list
ezyang@1697:        | Delete of string * sqexp
ezyang@1697:        | Update of string * (string * sqexp) list * sqexp
ezyang@1697: 
ezyang@1697: val insert = log "insert"
ezyang@1697:              (wrapP (follow (const "INSERT INTO ")
ezyang@1697:                             (follow uw_ident
ezyang@1697:                                     (follow (const " (")
ezyang@1697:                                             (follow (list uw_ident)
ezyang@1697:                                                     (follow (const ") VALUES (")
ezyang@1697:                                                             (follow (list sqexp)
ezyang@1697:                                                                     (const ")")))))))
ezyang@1697:               (fn ((), (tab, ((), (fs, ((), (es, ())))))) =>
ezyang@1697:                   (SOME (tab, ListPair.zipEq (fs, es)))
ezyang@1697:                   handle ListPair.UnequalLengths => NONE))
ezyang@1697: 
ezyang@1697: val delete = log "delete"
ezyang@1697:                  (wrap (follow (const "DELETE FROM ")
ezyang@1697:                                (follow uw_ident
ziv@2209:                                        (follow (follow (opt (const " AS T_T")) (const " WHERE "))
ezyang@1697:                                                sqexp)))
ziv@2209:                        (fn ((), (tab, (_, es))) => (tab, es)))
ezyang@1697: 
ezyang@1697: val setting = log "setting"
ziv@2209:                   (wrap (follow uw_ident (follow (const " = ") sqexp))
ziv@2209:                         (fn (f, ((), e)) => (f, e)))
ezyang@1697: 
ezyang@1697: val update = log "update"
ezyang@1697:                  (wrap (follow (const "UPDATE ")
ezyang@1697:                                (follow uw_ident
ziv@2209:                                        (follow (follow (opt (const " AS T_T")) (const " SET "))
ezyang@1697:                                                (follow (list setting)
ezyang@1697:                                                        (follow (ws (const "WHERE "))
ezyang@1697:                                                                sqexp)))))
ziv@2209:                        (fn ((), (tab, (_, (fs, ((), e))))) =>
ezyang@1697:                            (tab, fs, e)))
ezyang@1697: 
ezyang@1697: val dml = log "dml"
ezyang@1697:               (altL [wrap insert Insert,
ezyang@1697:                      wrap delete Delete,
ezyang@1697:                      wrap update Update])
ezyang@1697: 
ezyang@1697: datatype querydml =
ezyang@1697:          Query of query
ezyang@1697:        | Dml of dml
ezyang@1697: 
ezyang@1697: val querydml = log "querydml" (altL [wrap dml Dml, wrap query Query])
ezyang@1697: 
ezyang@1697: end