Mercurial > urweb

annotate src/sql.sml @ 2226:e10881cd92da

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Merge.
author Ziv Scully <ziv@mit.edu>
date Fri, 27 Mar 2015 11:26:06 -0400
parents 70ec9bb337be
children 0aae15c2a05a
rev   line source
ziv@2204 1 structure Sql :> SQL = struct
ezyang@1697 2
ezyang@1697 3 open Mono
ezyang@1697 4
ezyang@1697 5 val debug = ref false
ezyang@1697 6
ezyang@1697 7 type lvar = int
ezyang@1697 8
ezyang@1697 9 datatype func =
ezyang@1697 10 DtCon0 of string
ezyang@1697 11 | DtCon1 of string
ezyang@1697 12 | UnCon of string
ezyang@1697 13 | Other of string
ezyang@1697 14
ezyang@1697 15 datatype exp =
ezyang@1697 16 Const of Prim.t
ezyang@1697 17 | Var of int
ezyang@1697 18 | Lvar of lvar
ezyang@1697 19 | Func of func * exp list
ezyang@1697 20 | Recd of (string * exp) list
ezyang@1697 21 | Proj of exp * string
ezyang@1697 22
ziv@2216 23 datatype cmp =
ziv@2216 24 Eq
ezyang@1697 25 | Ne
ezyang@1697 26 | Lt
ezyang@1697 27 | Le
ezyang@1697 28 | Gt
ezyang@1697 29 | Ge
ezyang@1697 30
ziv@2216 31 datatype reln =
ziv@2216 32 Known
ziv@2216 33 | Sql of string
ziv@2216 34 | PCon0 of string
ziv@2216 35 | PCon1 of string
ziv@2216 36 | Cmp of cmp
ziv@2216 37
ziv@2216 38 datatype lop =
ziv@2216 39 And
ziv@2216 40 | Or
ziv@2216 41
ezyang@1697 42 datatype prop =
ezyang@1697 43 True
ezyang@1697 44 | False
ezyang@1697 45 | Unknown
ziv@2216 46 | Lop of lop * prop * prop
ezyang@1697 47 | Reln of reln * exp list
ezyang@1697 48 | Cond of exp * prop
ezyang@1697 49
ezyang@1697 50 datatype chunk =
ezyang@1697 51 String of string
ezyang@1697 52 | Exp of Mono.exp
ezyang@1697 53
ezyang@1697 54 fun chunkify e =
ezyang@1697 55 case #1 e of
adam@2048 56 EPrim (Prim.String (_, s)) => [String s]
ezyang@1697 57 | EStrcat (e1, e2) =>
ezyang@1697 58 let
ezyang@1697 59 val chs1 = chunkify e1
ezyang@1697 60 val chs2 = chunkify e2
ezyang@1697 61 in
ezyang@1697 62 case chs2 of
ezyang@1697 63 String s2 :: chs2' =>
ezyang@1697 64 (case List.last chs1 of
ezyang@1697 65 String s1 => List.take (chs1, length chs1 - 1) @ String (s1 ^ s2) :: chs2'
ezyang@1697 66 | _ => chs1 @ chs2)
ezyang@1697 67 | _ => chs1 @ chs2
ezyang@1697 68 end
ezyang@1697 69 | _ => [Exp e]
ezyang@1697 70
ezyang@1697 71 type 'a parser = chunk list -> ('a * chunk list) option
ezyang@1697 72
ezyang@1697 73 fun always v chs = SOME (v, chs)
ezyang@1697 74
ezyang@1697 75 fun parse p s =
ezyang@1697 76 case p (chunkify s) of
ezyang@1697 77 SOME (v, []) => SOME v
ezyang@1697 78 | _ => NONE
ezyang@1697 79
ezyang@1697 80 fun const s chs =
ezyang@1697 81 case chs of
ezyang@1697 82 String s' :: chs => if String.isPrefix s s' then
ezyang@1697 83 SOME ((), if size s = size s' then
ezyang@1697 84 chs
ezyang@1697 85 else
ezyang@1697 86 String (String.extract (s', size s, NONE)) :: chs)
ezyang@1697 87 else
ezyang@1697 88 NONE
ezyang@1697 89 | _ => NONE
ezyang@1697 90
ezyang@1697 91 fun follow p1 p2 chs =
ezyang@1697 92 case p1 chs of
ezyang@1697 93 NONE => NONE
ezyang@1697 94 | SOME (v1, chs) =>
ezyang@1697 95 case p2 chs of
ezyang@1697 96 NONE => NONE
ezyang@1697 97 | SOME (v2, chs) => SOME ((v1, v2), chs)
ezyang@1697 98
ezyang@1697 99 fun wrap p f chs =
ezyang@1697 100 case p chs of
ezyang@1697 101 NONE => NONE
ezyang@1697 102 | SOME (v, chs) => SOME (f v, chs)
ezyang@1697 103
ezyang@1697 104 fun wrapP p f chs =
ezyang@1697 105 case p chs of
ezyang@1697 106 NONE => NONE
ezyang@1697 107 | SOME (v, chs) =>
ezyang@1697 108 case f v of
ezyang@1697 109 NONE => NONE
ezyang@1697 110 | SOME r => SOME (r, chs)
ezyang@1697 111
ezyang@1697 112 fun alt p1 p2 chs =
ezyang@1697 113 case p1 chs of
ezyang@1697 114 NONE => p2 chs
ezyang@1697 115 | v => v
ezyang@1697 116
ezyang@1697 117 fun altL ps =
ezyang@1697 118 case rev ps of
ezyang@1697 119 [] => (fn _ => NONE)
ezyang@1697 120 | p :: ps =>
ezyang@1697 121 foldl (fn (p1, p2) => alt p1 p2) p ps
ezyang@1697 122
ezyang@1697 123 fun opt p chs =
ezyang@1697 124 case p chs of
ezyang@1697 125 NONE => SOME (NONE, chs)
ezyang@1697 126 | SOME (v, chs) => SOME (SOME v, chs)
ezyang@1697 127
ezyang@1697 128 fun skip cp chs =
ezyang@1697 129 case chs of
ezyang@1697 130 String "" :: chs => skip cp chs
ezyang@1697 131 | String s :: chs' => if cp (String.sub (s, 0)) then
ezyang@1697 132 skip cp (String (String.extract (s, 1, NONE)) :: chs')
ezyang@1697 133 else
ezyang@1697 134 SOME ((), chs)
ezyang@1697 135 | _ => SOME ((), chs)
ezyang@1697 136
ezyang@1697 137 fun keep cp chs =
ezyang@1697 138 case chs of
ezyang@1697 139 String "" :: chs => keep cp chs
ezyang@1697 140 | String s :: chs' =>
ezyang@1697 141 let
ezyang@1697 142 val (befor, after) = Substring.splitl cp (Substring.full s)
ezyang@1697 143 in
ezyang@1697 144 if Substring.isEmpty befor then
ezyang@1697 145 NONE
ezyang@1697 146 else
ezyang@1697 147 SOME (Substring.string befor,
ezyang@1697 148 if Substring.isEmpty after then
ezyang@1697 149 chs'
ezyang@1697 150 else
ezyang@1697 151 String (Substring.string after) :: chs')
ezyang@1697 152 end
ezyang@1697 153 | _ => NONE
ezyang@1697 154
ezyang@1697 155 fun ws p = wrap (follow (skip (fn ch => ch = #" "))
ezyang@1697 156 (follow p (skip (fn ch => ch = #" ")))) (#1 o #2)
ezyang@1697 157
ezyang@1697 158 fun log name p chs =
ezyang@1697 159 (if !debug then
ezyang@1697 160 (print (name ^ ": ");
ezyang@1697 161 app (fn String s => print s
ezyang@1697 162 | _ => print "???") chs;
ezyang@1697 163 print "\n")
ezyang@1697 164 else
ezyang@1697 165 ();
ezyang@1697 166 p chs)
ezyang@1697 167
ezyang@1697 168 fun list p chs =
ezyang@1697 169 altL [wrap (follow p (follow (ws (const ",")) (list p)))
ezyang@1697 170 (fn (v, ((), ls)) => v :: ls),
ezyang@1697 171 wrap (ws p) (fn v => [v]),
ezyang@1697 172 always []] chs
ezyang@1697 173
ezyang@1697 174 val ident = keep (fn ch => Char.isAlphaNum ch orelse ch = #"_")
ezyang@1697 175
ezyang@1697 176 val t_ident = wrapP ident (fn s => if String.isPrefix "T_" s then
ezyang@1697 177 SOME (String.extract (s, 2, NONE))
ezyang@1697 178 else
ezyang@1697 179 NONE)
ezyang@1697 180 val uw_ident = wrapP ident (fn s => if String.isPrefix "uw_" s andalso size s >= 4 then
ezyang@1697 181 SOME (str (Char.toUpper (String.sub (s, 3)))
ezyang@1697 182 ^ String.extract (s, 4, NONE))
ezyang@1697 183 else
ezyang@1697 184 NONE)
ezyang@1697 185
ziv@2209 186 val field = wrap (follow (opt (follow t_ident (const ".")))
ziv@2209 187 uw_ident)
ziv@2209 188 (fn (SOME (t, ()), f) => (t, f)
ziv@2209 189 | (NONE, f) => ("T", f)) (* Should probably deal with this MySQL/SQLite case better some day. *)
ezyang@1697 190
ezyang@1697 191 datatype Rel =
ziv@2216 192 RCmp of cmp
ziv@2216 193 | RLop of lop
ezyang@1697 194
ezyang@1697 195 datatype sqexp =
ezyang@1697 196 SqConst of Prim.t
ezyang@1697 197 | SqTrue
ezyang@1697 198 | SqFalse
ezyang@1697 199 | SqNot of sqexp
ezyang@1697 200 | Field of string * string
ezyang@1697 201 | Computed of string
ezyang@1697 202 | Binop of Rel * sqexp * sqexp
ezyang@1697 203 | SqKnown of sqexp
ezyang@1697 204 | Inj of Mono.exp
ezyang@1697 205 | SqFunc of string * sqexp
ezyang@1697 206 | Unmodeled
ezyang@1697 207 | Null
ezyang@1697 208
ziv@2216 209 fun cmp s r = wrap (const s) (fn () => RCmp r)
ezyang@1697 210
ezyang@1697 211 val sqbrel = altL [cmp "=" Eq,
ezyang@1697 212 cmp "<>" Ne,
ezyang@1697 213 cmp "<=" Le,
ezyang@1697 214 cmp "<" Lt,
ezyang@1697 215 cmp ">=" Ge,
ezyang@1697 216 cmp ">" Gt,
ziv@2216 217 wrap (const "AND") (fn () => RLop Or),
ziv@2216 218 wrap (const "OR") (fn () => RLop And)]
ezyang@1697 219
ezyang@1697 220 datatype ('a, 'b) sum = inl of 'a | inr of 'b
ezyang@1697 221
ezyang@1697 222 fun string chs =
ezyang@1697 223 case chs of
ezyang@1697 224 String s :: chs =>
ezyang@1697 225 if size s >= 2 andalso String.sub (s, 0) = #"'" then
ezyang@1697 226 let
ezyang@1697 227 fun loop (cs, acc) =
ezyang@1697 228 case cs of
ezyang@1697 229 [] => NONE
ezyang@1697 230 | c :: cs =>
ezyang@1697 231 if c = #"'" then
ezyang@1697 232 SOME (String.implode (rev acc), cs)
ezyang@1697 233 else if c = #"\\" then
ezyang@1697 234 case cs of
ezyang@1697 235 c :: cs => loop (cs, c :: acc)
ezyang@1697 236 | _ => raise Fail "Iflow.string: Unmatched backslash escape"
ezyang@1697 237 else
ezyang@1697 238 loop (cs, c :: acc)
ezyang@1697 239 in
ezyang@1697 240 case loop (String.explode (String.extract (s, 1, NONE)), []) of
ezyang@1697 241 NONE => NONE
ezyang@1697 242 | SOME (s, []) => SOME (s, chs)
ezyang@1697 243 | SOME (s, cs) => SOME (s, String (String.implode cs) :: chs)
ezyang@1697 244 end
ezyang@1697 245 else
ezyang@1697 246 NONE
ziv@2202 247 | _ => NONE
ezyang@1697 248
ezyang@1697 249 val prim =
ezyang@1697 250 altL [wrap (follow (wrapP (follow (keep Char.isDigit) (follow (const ".") (keep Char.isDigit)))
ezyang@1697 251 (fn (x, ((), y)) => Option.map Prim.Float (Real64.fromString (x ^ "." ^ y))))
ezyang@1697 252 (opt (const "::float8"))) #1,
ezyang@1697 253 wrap (follow (wrapP (keep Char.isDigit)
ezyang@1697 254 (Option.map Prim.Int o Int64.fromString))
ezyang@1697 255 (opt (const "::int8"))) #1,
ezyang@1697 256 wrap (follow (opt (const "E")) (follow string (opt (const "::text"))))
adam@2048 257 ((fn s => Prim.String (Prim.Normal, s)) o #1 o #2)]
ezyang@1697 258
ezyang@1697 259 fun known' chs =
ezyang@1697 260 case chs of
ezyang@1697 261 Exp (EFfi ("Basis", "sql_known"), _) :: chs => SOME ((), chs)
ezyang@1697 262 | _ => NONE
ezyang@1697 263
ezyang@1697 264 fun sqlify chs =
ezyang@1697 265 case chs of
ezyang@1697 266 Exp (EFfiApp ("Basis", f, [(e, _)]), _) :: chs =>
ezyang@1697 267 if String.isPrefix "sqlify" f then
ezyang@1697 268 SOME (e, chs)
ezyang@1697 269 else
ezyang@1697 270 NONE
ezyang@1697 271 | Exp (ECase (e, [((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, NONE), _),
adam@2048 272 (EPrim (Prim.String (Prim.Normal, "TRUE")), _)),
ezyang@1697 273 ((PCon (_, PConFfi {mod = "Basis", con = "False", ...}, NONE), _),
adam@2048 274 (EPrim (Prim.String (Prim.Normal, "FALSE")), _))], _), _) :: chs =>
ezyang@1697 275 SOME (e, chs)
ziv@2202 276
ezyang@1697 277 | _ => NONE
ezyang@1697 278
ziv@2213 279 fun sqlifySqlcache chs =
ziv@2213 280 case chs of
ziv@2215 281 (* Could have variables as well as FFIs. *)
ziv@2215 282 Exp (e as (ERel _, _)) :: chs => SOME (e, chs)
ziv@2215 283 (* If it is an FFI, match the entire expression. *)
ziv@2215 284 | Exp (e as (EFfiApp ("Basis", f, [(_, _)]), _)) :: chs =>
ziv@2213 285 if String.isPrefix "sqlify" f then
ziv@2215 286 SOME (e, chs)
ziv@2213 287 else
ziv@2213 288 NONE
ziv@2213 289 | Exp (ECase (e, [((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, NONE), _),
ziv@2213 290 (EPrim (Prim.String (Prim.Normal, "TRUE")), _)),
ziv@2213 291 ((PCon (_, PConFfi {mod = "Basis", con = "False", ...}, NONE), _),
ziv@2213 292 (EPrim (Prim.String (Prim.Normal, "FALSE")), _))], _), _) :: chs =>
ziv@2213 293 SOME (e, chs)
ziv@2213 294
ziv@2213 295 | _ => NONE
ziv@2213 296
ezyang@1697 297 fun constK s = wrap (const s) (fn () => s)
ezyang@1697 298
ezyang@1697 299 val funcName = altL [constK "COUNT",
ezyang@1697 300 constK "MIN",
ezyang@1697 301 constK "MAX",
ezyang@1697 302 constK "SUM",
ezyang@1697 303 constK "AVG"]
ezyang@1697 304
ezyang@1697 305 val unmodeled = altL [const "COUNT(*)",
ezyang@1697 306 const "CURRENT_TIMESTAMP"]
ezyang@1697 307
ziv@2213 308 val sqlcacheMode = ref false;
ziv@2213 309
ezyang@1697 310 fun sqexp chs =
ezyang@1697 311 log "sqexp"
ezyang@1697 312 (altL [wrap prim SqConst,
ezyang@1697 313 wrap (const "TRUE") (fn () => SqTrue),
ezyang@1697 314 wrap (const "FALSE") (fn () => SqFalse),
ezyang@1697 315 wrap (const "NULL") (fn () => Null),
ezyang@1697 316 wrap field Field,
ezyang@1697 317 wrap uw_ident Computed,
ezyang@1697 318 wrap known SqKnown,
ezyang@1697 319 wrap func SqFunc,
ezyang@1697 320 wrap unmodeled (fn () => Unmodeled),
ziv@2213 321 wrap (if !sqlcacheMode then sqlifySqlcache else sqlify) Inj,
ezyang@1697 322 wrap (follow (const "COALESCE(") (follow sqexp (follow (const ",")
ezyang@1697 323 (follow (keep (fn ch => ch <> #")")) (const ")")))))
ezyang@1697 324 (fn ((), (e, _)) => e),
ezyang@1697 325 wrap (follow (const "(NOT ") (follow sqexp (const ")")))
ezyang@1697 326 (fn ((), (e, _)) => SqNot e),
ezyang@1697 327 wrap (follow (ws (const "("))
ezyang@1697 328 (follow (wrap
ezyang@1697 329 (follow sqexp
ezyang@1697 330 (alt
ezyang@1697 331 (wrap
ezyang@1697 332 (follow (ws sqbrel)
ezyang@1697 333 (ws sqexp))
ezyang@1697 334 inl)
ezyang@1697 335 (always (inr ()))))
ezyang@1697 336 (fn (e1, sm) =>
ezyang@1697 337 case sm of
ezyang@1697 338 inl (bo, e2) => Binop (bo, e1, e2)
ezyang@1697 339 | inr () => e1))
ezyang@1697 340 (const ")")))
ezyang@1697 341 (fn ((), (e, ())) => e)])
ezyang@1697 342 chs
ezyang@1697 343
ezyang@1697 344 and known chs = wrap (follow known' (follow (const "(") (follow sqexp (const ")"))))
ezyang@1697 345 (fn ((), ((), (e, ()))) => e) chs
ziv@2202 346
ezyang@1697 347 and func chs = wrap (follow funcName (follow (const "(") (follow sqexp (const ")"))))
ezyang@1697 348 (fn (f, ((), (e, ()))) => (f, e)) chs
ezyang@1697 349
ezyang@1697 350 datatype sitem =
ezyang@1697 351 SqField of string * string
ezyang@1697 352 | SqExp of sqexp * string
ezyang@1697 353
ezyang@1697 354 val sitem = alt (wrap (follow sqexp (follow (const " AS ") uw_ident))
ezyang@1697 355 (fn (e, ((), s)) => SqExp (e, s)))
ezyang@1697 356 (wrap field SqField)
ezyang@1697 357
ezyang@1697 358 val select = log "select"
ezyang@1697 359 (wrap (follow (const "SELECT ") (list sitem))
ezyang@1697 360 (fn ((), ls) => ls))
ezyang@1697 361
ezyang@1697 362 val fitem = wrap (follow uw_ident
ezyang@1697 363 (follow (const " AS ")
ezyang@1697 364 t_ident))
ezyang@1697 365 (fn (t, ((), f)) => (t, f))
ezyang@1697 366
ezyang@1697 367 val from = log "from"
ezyang@1697 368 (wrap (follow (const "FROM ") (list fitem))
ezyang@1697 369 (fn ((), ls) => ls))
ezyang@1697 370
ezyang@1697 371 val wher = wrap (follow (ws (const "WHERE ")) sqexp)
ezyang@1697 372 (fn ((), ls) => ls)
ezyang@1697 373
ezyang@1697 374 type query1 = {Select : sitem list,
ezyang@1697 375 From : (string * string) list,
ezyang@1697 376 Where : sqexp option}
ezyang@1697 377
ezyang@1697 378 val query1 = log "query1"
ezyang@1697 379 (wrap (follow (follow select from) (opt wher))
ezyang@1697 380 (fn ((fs, ts), wher) => {Select = fs, From = ts, Where = wher}))
ezyang@1697 381
ezyang@1697 382 datatype query =
ezyang@1697 383 Query1 of query1
ezyang@1697 384 | Union of query * query
ezyang@1697 385
ezyang@1697 386 val orderby = log "orderby"
ezyang@1697 387 (wrap (follow (ws (const "ORDER BY "))
ezyang@1697 388 (follow (list sqexp)
ezyang@1697 389 (opt (ws (const "DESC")))))
ezyang@1697 390 ignore)
ezyang@1697 391
ezyang@1697 392 fun query chs = log "query"
ezyang@1697 393 (wrap
ezyang@1697 394 (follow
ezyang@1697 395 (alt (wrap (follow (const "((")
ezyang@1697 396 (follow query
ezyang@1697 397 (follow (const ") UNION (")
ezyang@1697 398 (follow query (const "))")))))
ezyang@1697 399 (fn ((), (q1, ((), (q2, ())))) => Union (q1, q2)))
ezyang@1697 400 (wrap query1 Query1))
ezyang@1697 401 (opt orderby))
ezyang@1697 402 #1)
ezyang@1697 403 chs
ezyang@1697 404
ezyang@1697 405 datatype dml =
ezyang@1697 406 Insert of string * (string * sqexp) list
ezyang@1697 407 | Delete of string * sqexp
ezyang@1697 408 | Update of string * (string * sqexp) list * sqexp
ezyang@1697 409
ezyang@1697 410 val insert = log "insert"
ezyang@1697 411 (wrapP (follow (const "INSERT INTO ")
ezyang@1697 412 (follow uw_ident
ezyang@1697 413 (follow (const " (")
ezyang@1697 414 (follow (list uw_ident)
ezyang@1697 415 (follow (const ") VALUES (")
ezyang@1697 416 (follow (list sqexp)
ezyang@1697 417 (const ")")))))))
ezyang@1697 418 (fn ((), (tab, ((), (fs, ((), (es, ())))))) =>
ezyang@1697 419 (SOME (tab, ListPair.zipEq (fs, es)))
ezyang@1697 420 handle ListPair.UnequalLengths => NONE))
ezyang@1697 421
ezyang@1697 422 val delete = log "delete"
ezyang@1697 423 (wrap (follow (const "DELETE FROM ")
ezyang@1697 424 (follow uw_ident
ziv@2209 425 (follow (follow (opt (const " AS T_T")) (const " WHERE "))
ezyang@1697 426 sqexp)))
ziv@2209 427 (fn ((), (tab, (_, es))) => (tab, es)))
ezyang@1697 428
ezyang@1697 429 val setting = log "setting"
ziv@2209 430 (wrap (follow uw_ident (follow (const " = ") sqexp))
ziv@2209 431 (fn (f, ((), e)) => (f, e)))
ezyang@1697 432
ezyang@1697 433 val update = log "update"
ezyang@1697 434 (wrap (follow (const "UPDATE ")
ezyang@1697 435 (follow uw_ident
ziv@2209 436 (follow (follow (opt (const " AS T_T")) (const " SET "))
ezyang@1697 437 (follow (list setting)
ezyang@1697 438 (follow (ws (const "WHERE "))
ezyang@1697 439 sqexp)))))
ziv@2209 440 (fn ((), (tab, (_, (fs, ((), e))))) =>
ezyang@1697 441 (tab, fs, e)))
ezyang@1697 442
ezyang@1697 443 val dml = log "dml"
ezyang@1697 444 (altL [wrap insert Insert,
ezyang@1697 445 wrap delete Delete,
ezyang@1697 446 wrap update Update])
ezyang@1697 447
ezyang@1697 448 datatype querydml =
ezyang@1697 449 Query of query
ezyang@1697 450 | Dml of dml
ezyang@1697 451
ezyang@1697 452 val querydml = log "querydml" (altL [wrap dml Dml, wrap query Query])
ezyang@1697 453
ezyang@1697 454 end