Relational operators; string literals for SQL

4 files changed, 71 insertions, 10 deletions

diff --git a/lib/basis.lig b/lib/basis.lig
index 7b6f0917..6ef7408f 100644
--- a/lib/basis.lig
+++ b/lib/basis.lig
@@ -14,6 +14,7 @@ con sql_table :: {Type} -> Type
 (*** Queries *)
 
 con sql_query :: {{Type}} -> Type
+con sql_query1 :: {{Type}} -> {{Type}} -> Type
 con sql_exp :: {{Type}} -> {{Type}} -> Type -> Type
 
 con sql_subset :: {{Type}} -> {{Type}} -> Type
@@ -28,7 +29,7 @@ val sql_subset : keep_drop :: {({Type} * {Type})}
 val sql_subset_all : tables :: {{Type}}
         -> sql_subset tables tables
 
-val sql_query : tables ::: {{Type}}
+val sql_query1 : tables ::: {{Type}}
         -> grouped ::: {{Type}}
         -> selected ::: {{Type}}
         -> {From : $(fold (fn nm => fn fields :: {Type} => fn acc =>
@@ -37,6 +38,21 @@ val sql_query : tables ::: {{Type}}
             GroupBy : sql_subset tables grouped,
             Having : sql_exp grouped tables bool,
             SelectFields : sql_subset grouped selected}
+        -> sql_query1 tables selected
+
+type sql_relop 
+val sql_union : sql_relop
+val sql_intersect : sql_relop
+val sql_except : sql_relop
+val sql_relop : sql_relop
+        -> tables1 ::: {{Type}}
+        -> tables2 ::: {{Type}}
+        -> selected ::: {{Type}}
+        -> sql_query1 tables1 selected -> sql_query1 tables2 selected -> sql_query1 selected selected
+
+val sql_query : tables ::: {{Type}}
+        -> selected ::: {{Type}}
+        -> sql_query1 tables selected
         -> sql_query selected
 
 val sql_field : otherTabs ::: {{Type}} -> otherFields ::: {Type} -> fieldType ::: Type -> agg ::: {{Type}}
diff --git a/src/lacweb.grm b/src/lacweb.grm
index dd1cd201..8bbc935a 100644
--- a/src/lacweb.grm
+++ b/src/lacweb.grm
@@ -129,6 +129,15 @@ fun sql_unary (oper, sqlexp, loc) =
         (EApp (e, sqlexp), loc)
     end
 
+fun sql_relop (oper, sqlexp1, sqlexp2, loc) =
+    let
+        val e = (EVar (["Basis"], "sql_relop"), loc)
+        val e = (EApp (e, (EVar (["Basis"], "sql_" ^ oper), loc)), loc)
+        val e = (EApp (e, sqlexp1), loc)
+    in
+        (EApp (e, sqlexp2), loc)
+    end
+
 %%
 %header (functor LacwebLrValsFn(structure Token : TOKEN))
 
@@ -153,6 +162,7 @@ fun sql_unary (oper, sqlexp, loc) =
  | BEGIN_TAG of string | END_TAG of string
 
  | SELECT | FROM | AS | CWHERE | GROUP | BY | HAVING
+ | UNION | INTERSECT | EXCEPT
  | TRUE | FALSE | CAND | OR | NOT
  | NE | LT | LE | GT | GE
 
@@ -247,6 +257,7 @@ fun sql_unary (oper, sqlexp, loc) =
 %nonassoc DARROW
 %nonassoc COLON
 %nonassoc DCOLON TCOLON
+%left UNION INTERSECT EXCEPT
 %right COMMA
 %right OR
 %right CAND
@@ -644,7 +655,11 @@ attrv  : INT                            (EPrim (Prim.Int INT), s (INTleft, INTri
        | STRING                         (EPrim (Prim.String STRING), s (STRINGleft, STRINGright))
        | LBRACE eexp RBRACE             (eexp)
 
-query  : query1                         (query1)
+query  : query1                         (let
+                                             val loc = s (query1left, query1right)
+                                         in
+                                             (EApp ((EVar (["Basis"], "sql_query"), loc), query1), loc)
+                                         end)
                 
 query1 : SELECT select FROM tables wopt gopt hopt
                                         (let
@@ -691,7 +706,7 @@ query1 : SELECT select FROM tables wopt gopt hopt
                                                                        (CRecord tabs, loc)), loc)
                                                            end
 
-                                             val e = (EVar (["Basis"], "sql_query"), loc)
+                                             val e = (EVar (["Basis"], "sql_query1"), loc)
                                              val re = (ERecord [((CName "From", loc),
                                                                  (ERecord tables, loc)),
                                                                 ((CName "Where", loc),
@@ -708,6 +723,9 @@ query1 : SELECT select FROM tables wopt gopt hopt
                                          in
                                              e
                                          end)
+       | query1 UNION query1            (sql_relop ("union", query11, query12, s (query11left, query12right)))
+       | query1 INTERSECT query1        (sql_relop ("intersect", query11, query12, s (query11left, query12right)))
+       | query1 EXCEPT query1           (sql_relop ("except", query11, query12, s (query11left, query12right)))
 
 tables : table                          ([table])
        | table COMMA tables             (table :: tables)
@@ -748,6 +766,9 @@ sqlexp : TRUE                           (sql_inject (EVar (["Basis"], "True"),
        | FLOAT                          (sql_inject (EPrim (Prim.Float FLOAT),
                                                      EVar (["Basis"], "sql_float"),
                                                      s (FLOATleft, FLOATright)))
+       | STRING                         (sql_inject (EPrim (Prim.String STRING),
+                                                     EVar (["Basis"], "sql_string"),
+                                                     s (STRINGleft, STRINGright)))
 
        | tident DOT fident              (let
                                              val loc = s (tidentleft, fidentright)
diff --git a/src/lacweb.lex b/src/lacweb.lex
index 5c8b9d11..cd4e75f4 100644
--- a/src/lacweb.lex
+++ b/src/lacweb.lex
@@ -59,6 +59,7 @@ in
     end
 end
 
+val strEnder = ref #"\""
 val str = ref ([] : char list)
 val strStart = ref 0
 
@@ -141,16 +142,25 @@ notags = [^<{\n]+;
 <COMMENT> "*)"        => (if exitComment () then YYBEGIN INITIAL else ();
 			  continue ());
 
-<INITIAL> "\""        => (YYBEGIN STRING; strStart := pos yypos; str := []; continue());
+<INITIAL> "\""        => (YYBEGIN STRING; strEnder := #"\""; strStart := pos yypos; str := []; continue());
+<INITIAL> "'"         => (YYBEGIN STRING; strEnder := #"'"; strStart := pos yypos; str := []; continue());
 <STRING> "\\\""       => (str := #"\"" :: !str; continue());
-<STRING> "\""         => (if !xmlString then
-			  (xmlString := false; YYBEGIN XMLTAG)
-			  else
-			  YYBEGIN INITIAL;
-			  Tokens.STRING (String.implode (List.rev (!str)), !strStart, pos yypos + 1));
+<STRING> "\\'"        => (str := #"'" :: !str; continue());
 <STRING> "\n"         => (newline yypos;
 			  str := #"\n" :: !str; continue());
-<STRING> .            => (str := String.sub (yytext, 0) :: !str; continue());
+<STRING> .            => (let
+                              val ch = String.sub (yytext, 0)
+                          in
+                              if ch = !strEnder then
+                                  (if !xmlString then
+			               (xmlString := false; YYBEGIN XMLTAG)
+			           else
+			               YYBEGIN INITIAL;
+			           Tokens.STRING (String.implode (List.rev (!str)), !strStart, pos yypos + 1))
+                              else
+                                  (str := ch :: !str;
+                                   continue ())
+                          end);
 
 <INITIAL> "<" {id} ">"=> (let
 			      val tag = String.substring (yytext, 1, size yytext - 2)
@@ -299,6 +309,10 @@ notags = [^<{\n]+;
 <INITIAL> "BY"        => (Tokens.BY (pos yypos, pos yypos + size yytext));
 <INITIAL> "HAVING"    => (Tokens.HAVING (pos yypos, pos yypos + size yytext));
 
+<INITIAL> "UNION"     => (Tokens.UNION (pos yypos, pos yypos + size yytext));
+<INITIAL> "INTERSECT" => (Tokens.INTERSECT (pos yypos, pos yypos + size yytext));
+<INITIAL> "EXCEPT"    => (Tokens.EXCEPT (pos yypos, pos yypos + size yytext));
+
 <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));
diff --git a/tests/relops.lac b/tests/relops.lac
new file mode 100644
index 00000000..c9fca0cc
--- /dev/null
+++ b/tests/relops.lac
@@ -0,0 +1,10 @@
+table t1 : {A : int, B : string, C : float}
+table t2 : {A : float, D : int}
+
+val q1 = (SELECT * FROM t1
+        UNION SELECT * FROM t1)
+val q2 = (SELECT t1.A, t1.B FROM t1 WHERE t1.A = 0
+        INTERSECT SELECT t1.B, t1.A FROM t1 WHERE t1.B = t1.B)
+val q3 = (SELECT t1.A, t1.B, t1.C FROM t1 WHERE t1.A = 0
+        INTERSECT SELECT * FROM t1 WHERE t1.B = 'Hello world!'
+        EXCEPT SELECT * FROM t1 WHERE t1.A < t1.A)