Monoize ASC/DESC

8 files changed, 47 insertions, 34 deletions

diff --git a/lib/basis.urs b/lib/basis.urs
index bfb25651..cd355316 100644
--- a/lib/basis.urs
+++ b/lib/basis.urs
@@ -73,7 +73,7 @@ val sql_desc : sql_direction
 con sql_order_by :: {{Type}} -> {Type} -> Type
 val sql_order_by_Nil : tables ::: {{Type}} -> exps :: {Type} -> sql_order_by tables exps
 val sql_order_by_Cons : tables ::: {{Type}} -> exps ::: {Type} -> t ::: Type
-        -> sql_exp tables [] exps t -> sql_order_by tables exps
+        -> sql_exp tables [] exps t -> sql_direction -> sql_order_by tables exps
         -> sql_order_by tables exps
 
 type sql_limit
diff --git a/src/compiler.sig b/src/compiler.sig
index 2549b4f1..51ec0537 100644
--- a/src/compiler.sig
+++ b/src/compiler.sig
@@ -74,12 +74,9 @@ signature COMPILER = sig
     val toMonoize : (job, Mono.file) transform
     val toMono_opt1 : (job, Mono.file) transform
     val toUntangle : (job, Mono.file) transform
-    val toMono_reduce1 : (job, Mono.file) transform
-    val toMono_shake1 : (job, Mono.file) transform
+    val toMono_reduce : (job, Mono.file) transform
+    val toMono_shake : (job, Mono.file) transform
     val toMono_opt2 : (job, Mono.file) transform
-    val toMono_reduce2 : (job, Mono.file) transform
-    val toMono_opt3 : (job, Mono.file) transform
-    val toMono_shake2 : (job, Mono.file) transform
     val toCjrize : (job, Cjr.file) transform
 
 end
diff --git a/src/compiler.sml b/src/compiler.sml
index cc8e459d..8c6c8f1f 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -313,29 +313,23 @@ val mono_reduce = {
     print = MonoPrint.p_file MonoEnv.empty
 }
 
-val toMono_reduce1 = toUntangle o transform mono_reduce "mono_reduce1"
+val toMono_reduce = toUntangle o transform mono_reduce "mono_reduce"
 
 val mono_shake = {
     func = MonoShake.shake,
     print = MonoPrint.p_file MonoEnv.empty
 }
 
-val toMono_shake1 = toMono_reduce1 o transform mono_shake "mono_shake1"
+val toMono_shake = toMono_reduce o transform mono_shake "mono_shake1"
 
-val toMono_opt2 = toMono_shake1 o transform mono_opt "mono_opt2"
-
-val toMono_reduce2 = toMono_opt2 o transform mono_reduce "mono_reduce2"
-
-val toMono_opt3 = toMono_reduce2 o transform mono_opt "mono_opt3"
-
-val toMono_shake2 = toMono_opt3 o transform mono_shake "mono_shake2"
+val toMono_opt2 = toMono_shake o transform mono_opt "mono_opt2"
 
 val cjrize = {
     func = Cjrize.cjrize,
     print = CjrPrint.p_file CjrEnv.empty
 }
 
-val toCjrize = toMono_shake2 o transform cjrize "cjrize"
+val toCjrize = toMono_opt2 o transform cjrize "cjrize"
 
 fun compileC {cname, oname, ename} =
     let
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index caa3c124..5367be60 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -203,6 +203,9 @@ fun exp env e =
         else
             #1 (reduceExp env (subExpInExp (0, e') b))
 
+      | EStrcat ((EPrim (Prim.String s1), _), (EPrim (Prim.String s2), _)) =>
+        EPrim (Prim.String (s1 ^ s2))
+
       | _ => e
 
 and bind (env, b) =
diff --git a/src/monoize.sml b/src/monoize.sml
index 55245074..6624c971 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -718,17 +718,19 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                 val s = (L'.TFfi ("Basis", "string"), loc)
                 fun sc s = (L'.EPrim (Prim.String s), loc)
             in
-                ((L'.EAbs ("e1", s, (L'.TFun (s, s), loc),
-                           (L'.EAbs ("e2", s, s,
-                                     (L'.ECase ((L'.ERel 0, loc),
-                                                [((L'.PPrim (Prim.String ""), loc),
-                                                  (L'.ERel 1, loc)),
-                                                 ((L'.PWild, loc),
-                                                  strcat loc [(L'.ERel 1, loc),
-                                                              sc ", ",
-                                                              (L'.ERel 0, loc),
-                                                              sc ")"])],
-                                                {disc = s, result = s}), loc)), loc)), loc),
+                ((L'.EAbs ("e1", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
+                           (L'.EAbs ("d", s, (L'.TFun (s, s), loc),
+                                     (L'.EAbs ("e2", s, s,
+                                               (L'.ECase ((L'.ERel 0, loc),
+                                                          [((L'.PPrim (Prim.String ""), loc),
+                                                            strcat loc [(L'.ERel 2, loc),
+                                                                        (L'.ERel 1, loc)]),
+                                                           ((L'.PWild, loc),
+                                                            strcat loc [(L'.ERel 2, loc),
+                                                                        (L'.ERel 1, loc),
+                                                                        sc ", ",
+                                                                        (L'.ERel 0, loc)])],
+                                                          {disc = s, result = s}), loc)), loc)), loc)), loc),
                  fm)
             end
 
@@ -968,6 +970,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                        (L'.EPrim (Prim.String "MIN"), loc)), loc),
              fm)
 
+          | L.EFfi ("Basis", "sql_asc") => ((L'.EPrim (Prim.String ""), loc), fm)
+          | L.EFfi ("Basis", "sql_desc") => ((L'.EPrim (Prim.String " DESC"), loc), fm)
+
           | L.EApp (
             (L.ECApp (
              (L.ECApp ((L.EFfi ("Basis", "cdata"), _), _), _),
diff --git a/src/urweb.grm b/src/urweb.grm
index 51c104d7..6cb41890 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -178,6 +178,7 @@ fun native_op (oper, e1, e2, loc) =
  | LIMIT | OFFSET | ALL
  | TRUE | FALSE | CAND | OR | NOT
  | COUNT | AVG | SUM | MIN | MAX
+ | ASC | DESC
  | NE | LT | LE | GT | GE
 
 %nonterm
@@ -270,7 +271,9 @@ fun native_op (oper, e1, e2, loc) =
  | gopt of group_item list option
  | hopt of exp
  | obopt of exp
+ | obitem of exp * exp
  | obexps of exp
+ | diropt of exp
  | lopt of exp
  | ofopt of exp
  | sqlint of exp
@@ -1022,26 +1025,34 @@ obopt  :                                (ECApp ((EVar (["Basis"], "sql_order_by_
                                          dummy)
        | ORDER BY obexps                (obexps)
 
-obexps : sqlexp                         (let
-                                             val loc = s (sqlexpleft, sqlexpright)
+obitem : sqlexp diropt                  (sqlexp, diropt)
+
+obexps : obitem                         (let
+                                             val loc = s (obitemleft, obitemright)
 
                                              val e' = (ECApp ((EVar (["Basis"], "sql_order_by_Nil"), loc),
                                                               (CWild (KRecord (KType, loc), loc), loc)),
                                                        loc)
                                              val e = (EApp ((EVar (["Basis"], "sql_order_by_Cons"), loc),
-                                                            sqlexp), loc)
+                                                            #1 obitem), loc)
+                                             val e = (EApp (e, #2 obitem), loc)
                                          in
                                              (EApp (e, e'), loc)
                                          end)
-       | sqlexp COMMA obexps            (let
-                                             val loc = s (sqlexpleft, obexpsright)
+       | obitem COMMA obexps            (let
+                                             val loc = s (obitemleft, obexpsright)
 
                                              val e = (EApp ((EVar (["Basis"], "sql_order_by_Cons"), loc),
-                                                            sqlexp), loc)
+                                                            #1 obitem), loc)
+                                             val e = (EApp (e, #2 obitem), loc)
                                          in
                                              (EApp (e, obexps), loc)
                                          end)
 
+diropt :                                (EVar (["Basis"], "sql_asc"), dummy)
+       | ASC                            (EVar (["Basis"], "sql_asc"), s (ASCleft, ASCright))
+       | DESC                           (EVar (["Basis"], "sql_desc"), s (DESCleft, DESCright))
+
 lopt   :                                 (EVar (["Basis"], "sql_no_limit"), dummy)
        | LIMIT ALL                       (EVar (["Basis"], "sql_no_limit"), dummy)
        | LIMIT sqlint                    (let
diff --git a/src/urweb.lex b/src/urweb.lex
index 1d64a85c..e47546b3 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -332,6 +332,9 @@ notags = [^<{\n]+;
 <INITIAL> "MIN"       => (Tokens.MIN (pos yypos, pos yypos + size yytext));
 <INITIAL> "MAX"       => (Tokens.MAX (pos yypos, pos yypos + size yytext));
 
+<INITIAL> "ASC"       => (Tokens.ASC (pos yypos, pos yypos + size yytext));
+<INITIAL> "DESC"      => (Tokens.DESC (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));
 
diff --git a/tests/order_by.ur b/tests/order_by.ur
index dbe041c2..de584fda 100644
--- a/tests/order_by.ur
+++ b/tests/order_by.ur
@@ -12,7 +12,7 @@ val q4 = (SELECT t1.A, t2.D, t1.A < t2.D AS Lt
         ORDER BY Lt)
 val q5 = (SELECT t1.A, t1.B, t2.D, t1.A < t2.D AS Lt
         FROM t1, t2
-        ORDER BY t1.A, Lt, t2.D)
+        ORDER BY t1.A DESC, Lt ASC, t2.D DESC)
 
 
 datatype list a = Nil | Cons of a * list a