Monoize relops

3 files changed, 66 insertions, 5 deletions

diff --git a/lib/basis.urs b/lib/basis.urs
index c83ec044..bfb25651 100644
--- a/lib/basis.urs
+++ b/lib/basis.urs
@@ -57,11 +57,11 @@ 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}}
+val sql_relop : tables1 ::: {{Type}}
         -> tables2 ::: {{Type}}
         -> selectedFields ::: {{Type}}
         -> selectedExps ::: {Type}
+        -> sql_relop
         -> sql_query1 tables1 selectedFields selectedExps
         -> sql_query1 tables2 selectedFields selectedExps
         -> sql_query1 selectedFields selectedFields selectedExps
diff --git a/src/monoize.sml b/src/monoize.sml
index 35d474e6..c9bec0c5 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -586,7 +586,18 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                         if List.exists (fn x => x = NONE) tables then
                             NONE
                         else
-                            SOME (List.mapPartial (fn x => x) tables)
+                            let
+                                val tables = List.mapPartial (fn x => x) tables
+                                val tables = ListMergeSort.sort
+                                                 (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER)
+                                                 tables
+                                val tables = map (fn (x, xts) =>
+                                                     (x, ListMergeSort.sort
+                                                             (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER)
+                                                             xts)) tables
+                            in
+                                SOME tables
+                            end
                     end
             in
                 case (doTables tables, doTables grouped, doTables stables, monoType env (L.TRecord sexps, loc)) of
@@ -784,7 +795,37 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
               _), _),
              (L.CName tab, _)), _),
             (L.CName field, _)) => ((L'.EPrim (Prim.String (tab ^ "." ^ field)), loc), fm)
-                    
+
+          | L.ECApp (
+            (L.ECApp (
+             (L.ECApp (
+              (L.ECApp (
+               (L.EFfi ("Basis", "sql_relop"), _),
+               _), _),
+              _), _),
+             _), _),
+            _) =>
+            let
+                val s = (L'.TFfi ("Basis", "string"), loc)
+                fun sc s = (L'.EPrim (Prim.String s), loc)
+            in
+                ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
+                           (L'.EAbs ("e1", s, (L'.TFun (s, s), loc),
+                                     (L'.EAbs ("e2", s, s,
+                                               strcat loc [sc "((",
+                                                           (L'.ERel 1, loc),
+                                                           sc ") ",
+                                                           (L'.ERel 2, loc),
+                                                           sc " (",
+                                                           (L'.ERel 0, loc),
+                                                           sc "))"]), loc)), loc)), loc),
+                 fm)
+            end
+
+          | L.EFfi ("Basis", "sql_union") => ((L'.EPrim (Prim.String "UNION"), loc), fm)
+          | L.EFfi ("Basis", "sql_intersect") => ((L'.EPrim (Prim.String "INTERSECT"), loc), fm)
+          | L.EFfi ("Basis", "sql_except") => ((L'.EPrim (Prim.String "EXCEPT"), loc), fm)
+
           | L.EApp (
             (L.ECApp (
              (L.ECApp ((L.EFfi ("Basis", "cdata"), _), _), _),
diff --git a/tests/relops.ur b/tests/relops.ur
index c9fca0cc..b876c482 100644
--- a/tests/relops.ur
+++ b/tests/relops.ur
@@ -7,4 +7,24 @@ 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)
+        EXCEPT SELECT * FROM t1 WHERE t1.A < t1.A
+        UNION SELECT * FROM t1 WHERE t1.A > t1.A)
+
+datatype list a = Nil | Cons of a * list a
+
+val r1 : transaction (list {A : int, B : string, C : float}) =
+        query q3
+        (fn fs acc => return (Cons (fs.T1, acc)))
+        Nil
+
+val r2 : transaction string =
+        ls <- r1;
+        return (case ls of
+                    Nil => "Problem"
+                  | Cons ({B = b, ...}, _) => b)
+
+val main : unit -> transaction page = fn () =>
+        s <- r2;
+        return <html><body>
+                {cdata s}
+        </body></html>