Mercurial > urweb

changeset 1206:772760df4c4c

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Parsing more of WHERE
author Adam Chlipala <adamc@hcoop.net>
date Sun, 04 Apr 2010 17:44:12 -0400
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>