Mercurial > urweb

comparison src/iflow.sml @ 1201:8793fd48968c

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Generating a good Iflow condition for a test query
author Adam Chlipala <adamc@hcoop.net>
date Sun, 04 Apr 2010 15:17:57 -0400
parents 5eac14322548
children 509a6d7b60fb
comparison
equal deleted inserted replaced
1200:5eac14322548 1201:8793fd48968c
220 case #1 e of 220 case #1 e of
221 EPrim (Prim.String s) => [String s] 221 EPrim (Prim.String s) => [String s]
222 | EStrcat (e1, e2) => chunkify e1 @ chunkify e2 222 | EStrcat (e1, e2) => chunkify e1 @ chunkify e2
223 | _ => [Exp e] 223 | _ => [Exp e]
224 224
225 type 'a parser = chunk list -> ('a * chunk list) option
226
227 fun always v chs = SOME (v, chs)
228
229 fun parse p chs =
230 case p chs of
231 SOME (v, []) => SOME v
232 | _ => NONE
233
234 fun const s chs =
235 case chs of
236 String s' :: chs => if String.isPrefix s s' then
237 SOME ((), if size s = size s' then
238 chs
239 else
240 String (String.extract (s', size s, NONE)) :: chs)
241 else
242 NONE
243 | _ => NONE
244
245 fun follow p1 p2 chs =
246 case p1 chs of
247 NONE => NONE
248 | SOME (v1, chs) =>
249 case p2 chs of
250 NONE => NONE
251 | SOME (v2, chs) => SOME ((v1, v2), chs)
252
253 fun wrap p f chs =
254 case p chs of
255 NONE => NONE
256 | SOME (v, chs) => SOME (f v, chs)
257
258 fun alt p1 p2 chs =
259 case p1 chs of
260 NONE => p2 chs
261 | v => v
262
263 fun skip cp chs =
264 case chs of
265 String "" :: chs => skip cp chs
266 | String s :: chs' => if cp (String.sub (s, 0)) then
267 skip cp (String (String.extract (s, 1, NONE)) :: chs')
268 else
269 SOME ((), chs)
270 | _ => SOME ((), chs)
271
272 fun keep cp chs =
273 case chs of
274 String "" :: chs => keep cp chs
275 | String s :: chs' =>
276 let
277 val (befor, after) = Substring.splitl cp (Substring.full s)
278 in
279 if Substring.isEmpty befor then
280 NONE
281 else
282 SOME (Substring.string befor,
283 if Substring.isEmpty after then
284 chs'
285 else
286 String (Substring.string after) :: chs')
287 end
288 | _ => NONE
289
290 fun ws p = wrap (follow p (skip (fn ch => ch = #" "))) #1
291
292 fun list p chs =
293 (alt (wrap (follow p (follow (ws (const ",")) (list p)))
294 (fn (v, ((), ls)) => v :: ls))
295 (alt (wrap (ws p) (fn v => [v]))
296 (always []))) chs
297
298 val ident = keep (fn ch => Char.isAlphaNum ch orelse ch = #"_")
299
300 val t_ident = wrap ident (fn s => if String.isPrefix "T_" s then
301 String.extract (s, 2, NONE)
302 else
303 raise Fail "Iflow: Bad table variable")
304 val uw_ident = wrap ident (fn s => if String.isPrefix "uw_" s then
305 String.extract (s, 3, NONE)
306 else
307 raise Fail "Iflow: Bad uw_* variable")
308
309 val sitem = wrap (follow t_ident
310 (follow (const ".")
311 uw_ident))
312 (fn (t, ((), f)) => (t, f))
313
314 val select = wrap (follow (const "SELECT ") (list sitem))
315 (fn ((), ls) => ls)
316
317 val fitem = wrap (follow uw_ident
318 (follow (const " AS ")
319 t_ident))
320 (fn (t, ((), f)) => (t, f))
321
322 val from = wrap (follow (const "FROM ") (list fitem))
323 (fn ((), ls) => ls)
324
325 val query = wrap (follow select from)
326 (fn (fs, ts) => {Select = fs, From = ts})
327
225 fun queryProp rv e = 328 fun queryProp rv e =
226 let 329 case parse query (chunkify e) of
227 fun query chs = 330 NONE => Unknown
228 case chs of 331 | SOME r =>
229 [] => raise Fail "Iflow: Empty query" 332 foldl (fn ((t, v), p) =>
230 | Exp _ :: _ => Unknown 333 And (p,
231 | String "" :: chs => query chs 334 Reln (Sql t,
232 | String s :: chs => True 335 [Recd (foldl (fn ((v', f), fs) =>
233 in 336 if v' = v then
234 query (chunkify e) 337 (f, Proj (Proj (Lvar rv, v), f)) :: fs
235 end 338 else
339 fs) [] (#Select r))])))
340 True (#From r)
236 341
237 fun evalExp env (e : Mono.exp, st as (nv, p, sent)) = 342 fun evalExp env (e : Mono.exp, st as (nv, p, sent)) =
238 let 343 let
239 fun default () = 344 fun default () =
240 (Var nv, (nv+1, p, sent)) 345 (Var nv, (nv+1, p, sent))