Mercurial > urweb

comparison src/sql.sml @ 1697:cb0f05bdc183

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