Mercurial > urweb
changeset 1206:772760df4c4c
Parsing more of WHERE
author | Adam Chlipala <adamc@hcoop.net> |
---|---|
date | Sun, 04 Apr 2010 17:44:12 -0400 (2010-04-04) |
parents | 7cd11380cdf1 |
children | ae3036773768 |
files | src/iflow.sig src/iflow.sml tests/policy.ur |
diffstat | 3 files changed, 72 insertions(+), 41 deletions(-) [+] |
line wrap: on
line diff
--- a/src/iflow.sig Sun Apr 04 17:18:41 2010 -0400 +++ b/src/iflow.sig Sun Apr 04 17:44:12 2010 -0400 @@ -55,4 +55,6 @@ val check : Mono.file -> unit + val debug : bool ref + end
--- a/src/iflow.sml Sun Apr 04 17:18:41 2010 -0400 +++ b/src/iflow.sml Sun Apr 04 17:44:12 2010 -0400 @@ -420,10 +420,15 @@ fun ws p = wrap (follow (skip (fn ch => ch = #" ")) (follow p (skip (fn ch => ch = #" ")))) (#1 o #2) +val debug = ref false + fun log name p chs = - (case chs of - String s :: [] => print (name ^ ": " ^ s ^ "\n") - | _ => print (name ^ ": blocked!\n"); + (if !debug then + case chs of + String s :: [] => print (name ^ ": " ^ s ^ "\n") + | _ => print (name ^ ": blocked!\n") + else + (); p chs) fun list p chs = @@ -448,34 +453,64 @@ uw_ident)) (fn (t, ((), f)) => (t, f)) +datatype Rel = + Exps of exp * exp -> prop + | Props of prop * prop -> prop + datatype sqexp = - Field of string * string - | Binop of string * sqexp * sqexp + SqConst of Prim.t + | Field of string * string + | Binop of Rel * sqexp * sqexp -val sqbrel = wrap (const "=") (fn () => "=") +val sqbrel = alt (wrap (const "=") (fn () => Exps (fn (e1, e2) => Reln (Eq, [e1, e2])))) + (alt (wrap (const "AND") (fn () => Props And)) + (wrap (const "OR") (fn () => Props Or))) datatype ('a, 'b) sum = inl of 'a | inr of 'b +fun int chs = + case chs of + String s :: chs' => + let + val (befor, after) = Substring.splitl Char.isDigit (Substring.full s) + in + if Substring.isEmpty befor then + NONE + else case Int64.fromString (Substring.string befor) of + NONE => NONE + | SOME n => SOME (n, if Substring.isEmpty after then + chs' + else + String (Substring.string after) :: chs') + end + | _ => NONE + +val prim = wrap (follow (wrap int Prim.Int) (opt (const "::int8"))) #1 + fun sqexp chs = - alt - (wrap (follow (ws (const "(")) - (follow (ws sqexp) - (ws (const ")")))) - (fn ((), (e, ())) => e)) - (wrap - (follow (wrap sitem Field) - (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)) - chs - + log "sqexp" + (alt + (wrap prim SqConst) + (alt + (wrap sitem Field) + (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 + val select = wrap (follow (const "SELECT ") (list sitem)) (fn ((), ls) => ls) @@ -511,21 +546,13 @@ fun expIn e = case e of - Field (v, f) => inl (Proj (Proj (Lvar rv, v), f)) + SqConst p => inl (Const p) + | Field (v, f) => inl (Proj (Proj (Lvar rv, v), f)) | Binop (bo, e1, e2) => - (case (expIn e1, expIn e2) of - (inr _, _) => inr Unknown - | (_, inr _) => inr Unknown - | (inl e1, inl e2) => - let - val bo = case bo of - "=" => SOME Eq - | _ => NONE - in - case bo of - NONE => inr Unknown - | SOME bo => inr (Reln (bo, [e1, e2])) - end) + inr (case (bo, expIn e1, expIn e2) of + (Exps f, inl e1, inl e2) => f (e1, e2) + | (Props f, inr p1, inr p2) => f (p1, p2) + | _ => Unknown) val p = case #Where r of NONE => p
--- a/tests/policy.ur Sun Apr 04 17:18:41 2010 -0400 +++ b/tests/policy.ur Sun Apr 04 17:44:12 2010 -0400 @@ -12,7 +12,8 @@ FROM fruit) policy query_policy (SELECT order.Id, order.Fruit, order.Qty FROM order, fruit - WHERE order.Fruit = fruit.Id) + WHERE order.Fruit = fruit.Id + AND order.Qty = 13) fun main () = x1 <- queryX (SELECT fruit.Id, fruit.Nam @@ -21,7 +22,8 @@ x2 <- queryX (SELECT fruit.Nam, order.Qty FROM fruit, order - WHERE fruit.Id = order.Fruit) + WHERE fruit.Id = order.Fruit + AND order.Qty = 13) (fn x => <xml><li>{[x.Fruit.Nam]}: {[x.Order.Qty]}</li></xml>); return <xml><body>