Mercurial > urweb

changeset 220:2b665e822e9a

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
SQL boolean operators
author Adam Chlipala <adamc@hcoop.net>
date Sat, 16 Aug 2008 17:35:28 -0400
parents 5292c0113024
children 79819a6346e2
files lib/basis.lig src/elaborate.sml src/lacweb.grm src/lacweb.lex tests/where.lac
diffstat 5 files changed, 49 insertions(+), 7 deletions(-) [+]
line wrap: on
line diff
--- a/lib/basis.lig	Sat Aug 16 17:18:00 2008 -0400
+++ b/lib/basis.lig	Sat Aug 16 17:35:28 2008 -0400
@@ -34,6 +34,17 @@
 
 val sql_inject : tables ::: {{Type}} -> t ::: Type -> t -> sql_type t -> sql_exp tables t
 
+con sql_unary :: Type -> Type -> Type
+val sql_not : sql_unary bool bool
+val sql_unary : tables ::: {{Type}} -> arg ::: Type -> res ::: Type
+        -> sql_unary arg res -> sql_exp tables arg -> sql_exp tables res
+
+con sql_binary :: Type -> Type -> Type -> Type
+val sql_and : sql_binary bool bool bool
+val sql_or : sql_binary bool bool bool
+val sql_binary : tables ::: {{Type}} -> arg1 ::: Type -> arg2 ::: Type -> res ::: Type
+        -> sql_binary arg1 arg2 res -> sql_exp tables arg1 -> sql_exp tables arg2 -> sql_exp tables res
+
 type sql_comparison
 val sql_eq : sql_comparison
 val sql_ne : sql_comparison
--- a/src/elaborate.sml	Sat Aug 16 17:18:00 2008 -0400
+++ b/src/elaborate.sml	Sat Aug 16 17:35:28 2008 -0400
@@ -986,7 +986,7 @@
      | Inexhaustive of ErrorMsg.span
      | DuplicatePatField of ErrorMsg.span * string
      | Unresolvable of ErrorMsg.span * L'.con
-     | OutOfContext of ErrorMsg.span
+     | OutOfContext of ErrorMsg.span * (L'.exp * L'.con) option
 
 fun expError env err =
     case err of
@@ -1029,8 +1029,10 @@
         ErrorMsg.errorAt loc "Inexhaustive 'case'"
       | DuplicatePatField (loc, s) =>
         ErrorMsg.errorAt loc ("Duplicate record field " ^ s ^ " in pattern")
-      | OutOfContext loc =>
-        ErrorMsg.errorAt loc "Type class wildcard occurs out of context"
+      | OutOfContext (loc, co) =>
+        (ErrorMsg.errorAt loc "Type class wildcard occurs out of context";
+         Option.app (fn (e, c) => eprefaces' [("Function", p_exp env e),
+                                              ("Type", p_con env c)]) co)
       | Unresolvable (loc, c) =>
         (ErrorMsg.errorAt loc "Can't resolve type class instance";
          eprefaces' [("Class constraint", p_con env c)])
@@ -1466,10 +1468,10 @@
                                      (eerror, cerror, []))
                           | SOME pf => ((L'.EApp (e1', pf), loc), ran, gs1 @ gs2 @ gs3 @ gs4)
                     end
-                  | _ => (expError env (OutOfContext loc);
+                  | _ => (expError env (OutOfContext (loc, SOME (e1', t1)));
                           (eerror, cerror, []))
             end
-          | L.EWild => (expError env (OutOfContext loc);
+          | L.EWild => (expError env (OutOfContext (loc, NONE));
                         (eerror, cerror, []))
 
           | L.EApp (e1, e2) =>
--- a/src/lacweb.grm	Sat Aug 16 17:18:00 2008 -0400
+++ b/src/lacweb.grm	Sat Aug 16 17:35:28 2008 -0400
@@ -86,7 +86,24 @@
         val e = (EApp (e, sqlexp1), loc)
         val e = (EApp (e, sqlexp2), loc)
     in
-                (EApp (e, (EWild, loc)), loc)
+        (EApp (e, (EWild, loc)), loc)
+    end
+
+fun sql_binary (oper, sqlexp1, sqlexp2, loc) =
+    let
+        val e = (EVar (["Basis"], "sql_binary"), loc)
+        val e = (EApp (e, (EVar (["Basis"], "sql_" ^ oper), loc)), loc)
+        val e = (EApp (e, sqlexp1), loc)
+    in
+        (EApp (e, sqlexp2), loc)
+    end
+
+fun sql_unary (oper, sqlexp, loc) =
+    let
+        val e = (EVar (["Basis"], "sql_unary"), loc)
+        val e = (EApp (e, (EVar (["Basis"], "sql_" ^ oper), loc)), loc)
+    in
+        (EApp (e, sqlexp), loc)
     end
 
 %%
@@ -113,7 +130,7 @@
  | BEGIN_TAG of string | END_TAG of string
 
  | SELECT | FROM | AS | CWHERE
- | TRUE | FALSE
+ | TRUE | FALSE | CAND | OR | NOT
  | NE | LT | LE | GT | GE
 
 %nonterm
@@ -203,10 +220,13 @@
 %nonassoc COLON
 %nonassoc DCOLON TCOLON
 %right COMMA
+%right OR
+%right CAND
 %nonassoc EQ NE LT LE GT GE
 %right ARROW LARROW
 %right PLUSPLUS MINUSMINUS
 %right STAR
+%left NOT
 %nonassoc TWIDDLE
 %nonassoc DOLLAR
 %left DOT
@@ -670,9 +690,14 @@
        | sqlexp GT sqlexp               (sql_compare ("gt", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
        | sqlexp GE sqlexp               (sql_compare ("ge", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
 
+       | sqlexp CAND sqlexp             (sql_binary ("and", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
+       | sqlexp OR sqlexp               (sql_binary ("or", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
+       | NOT sqlexp                     (sql_unary ("not", sqlexp, s (NOTleft, sqlexpright)))
+
        | LBRACE eexp RBRACE             (sql_inject (#1 eexp,
                                                      EWild,
                                                      s (LBRACEleft, RBRACEright)))
+       | LPAREN sqlexp RPAREN           (sqlexp)
 
 wopt   :                                (sql_inject (EVar (["Basis"], "True"),
                                                      EVar (["Basis"], "sql_bool"),
--- a/src/lacweb.lex	Sat Aug 16 17:18:00 2008 -0400
+++ b/src/lacweb.lex	Sat Aug 16 17:35:28 2008 -0400
@@ -298,6 +298,9 @@
 
 <INITIAL> "TRUE"      => (Tokens.TRUE (pos yypos, pos yypos + size yytext));
 <INITIAL> "FALSE"     => (Tokens.FALSE (pos yypos, pos yypos + size yytext));
+<INITIAL> "AND"       => (Tokens.CAND (pos yypos, pos yypos + size yytext));
+<INITIAL> "OR"        => (Tokens.OR (pos yypos, pos yypos + size yytext));
+<INITIAL> "NOT"       => (Tokens.NOT (pos yypos, pos yypos + size yytext));
 
 <INITIAL> {id}        => (Tokens.SYMBOL (yytext, pos yypos, pos yypos + size yytext));
 <INITIAL> {cid}       => (Tokens.CSYMBOL (yytext, pos yypos, pos yypos + size yytext));
--- a/tests/where.lac	Sat Aug 16 17:18:00 2008 -0400
+++ b/tests/where.lac	Sat Aug 16 17:35:28 2008 -0400
@@ -7,3 +7,4 @@
 val q4 = (SELECT * FROM t1 WHERE {True})
 val q5 = (SELECT * FROM t1 WHERE {1} = {1})
 val q6 = (SELECT * FROM t1 WHERE {"Hi"} < {"Bye"})
+val q7 = (SELECT * FROM t1 WHERE {1} <> {1} AND NOT ({"Hi"} >= {"Bye"}))