Partitioning and ordering for window functions

7 files changed, 90 insertions, 19 deletions

diff --git a/src/monoize.sml b/src/monoize.sml
index 1a70894f..8224b26f 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -299,6 +299,8 @@ fun monoType env =
                     (L'.TRecord [], loc)
                   | L.CApp ((L.CFfi ("Basis", "sql_maxable"), _), _) =>
                     (L'.TRecord [], loc)
+                  | L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_partition"), _), _), _), _), _), _) =>
+                    (L'.TFfi ("Basis", "string"), loc)
                   | L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_window"), _), _), _), _), _), _), _), _) =>
                     (L'.TFfi ("Basis", "string"), loc)
                   | L.CApp ((L.CFfi ("Basis", "sql_arith"), _), _) =>
@@ -2744,10 +2746,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
             ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc),
                        (L'.ERecord [], loc)), loc),
              fm)
-          | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_avg"), _), _), _), _) =>
-            ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun ((L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc)), loc),
-                       (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
-                                 (L'.EPrim (Prim.String "AVG"), loc)), loc)), loc),
+          | L.ECApp ((L.EFfi ("Basis", "sql_avg"), _), _) =>
+            ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
+                       (L'.EPrim (Prim.String "AVG"), loc)), loc),
              fm)
           | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_sum"), _), _), _), _) =>
             ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun ((L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc)), loc),
@@ -2783,6 +2784,29 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
           | L.ECApp (
             (L.ECApp (
              (L.ECApp (
+               (L.EFfi ("Basis", "sql_no_partition"), _),
+               _), _),
+             _), _),
+            _) => ((L'.EPrim (Prim.String ""), loc), fm)
+          | L.ECApp (
+            (L.ECApp (
+             (L.ECApp (
+              (L.ECApp (
+               (L.EFfi ("Basis", "sql_partition"), _),
+               _), _),
+              _), _),
+             _), _),
+            _) =>
+            let
+                val s = (L'.TFfi ("Basis", "string"), loc)
+            in
+                ((L'.EAbs ("e", s, s, strcat [(L'.EPrim (Prim.String "PARTITION BY "), loc), (L'.ERel 0, loc)]), loc),
+                 fm)
+            end
+
+          | L.ECApp (
+            (L.ECApp (
+             (L.ECApp (
               (L.ECApp (
                (L.EFfi ("Basis", "sql_window"), _),
                _), _),
@@ -2790,13 +2814,31 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
              _), _),
             _) =>
             let
+                val () = if #windowFunctions (Settings.currentDbms ()) then
+                             ()
+                         else
+                             ErrorMsg.errorAt loc "The DBMS you've selected doesn't support window functions."
+
                 val s = (L'.TFfi ("Basis", "string"), loc)
                 fun sc s = (L'.EPrim (Prim.String s), loc)
 
-                val main = strcat [(L'.ERel 0, loc),
-                                   sc " OVER ()"]
+                val main = strcat [(L'.ERel 2, loc),
+                                   sc " OVER (",
+                                   (L'.ERel 1, loc),
+                                   (L'.ECase ((L'.ERel 0, loc),
+                                              [((L'.PPrim (Prim.String ""), loc),
+                                                sc ""),
+                                               ((L'.PWild, loc),
+                                                strcat [sc " ORDER BY ",
+                                                        (L'.ERel 0, loc)])],
+                                              {disc = s,
+                                               result = s}), loc),
+                                   sc ")"]
             in
-                ((L'.EAbs ("w", s, s, main), loc),
+                ((L'.EAbs ("w", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
+                           (L'.EAbs ("p", s, (L'.TFun (s, s), loc),
+                                     (L'.EAbs ("o", s, s,
+                                               main), loc)), loc)), loc),
                  fm)
             end
 
diff --git a/src/mysql.sml b/src/mysql.sml
index 780f5148..1a641d57 100644
--- a/src/mysql.sml
+++ b/src/mysql.sml
@@ -1554,6 +1554,7 @@ val () = addDbms {name = "mysql",
                   trueString = "TRUE",
                   falseString = "FALSE",
                   onlyUnion = true,
-                  nestedRelops = false}
+                  nestedRelops = false,
+                  windowFunctions = false}
 
 end
diff --git a/src/postgres.sml b/src/postgres.sml
index db9c9d3a..e555c565 100644
--- a/src/postgres.sml
+++ b/src/postgres.sml
@@ -1063,7 +1063,8 @@ val () = addDbms {name = "postgres",
                   trueString = "TRUE",
                   falseString = "FALSE",
                   onlyUnion = false,
-                  nestedRelops = true}
+                  nestedRelops = true,
+                  windowFunctions = true}
 
 val () = setDbms "postgres"
 
diff --git a/src/settings.sig b/src/settings.sig
index 7140c645..a9ad36a5 100644
--- a/src/settings.sig
+++ b/src/settings.sig
@@ -199,7 +199,8 @@ signature SETTINGS = sig
          trueString : string,
          falseString : string,
          onlyUnion : bool,
-         nestedRelops : bool
+         nestedRelops : bool,
+         windowFunctions : bool
     }
 
     val addDbms : dbms -> unit
diff --git a/src/settings.sml b/src/settings.sml
index 246be88b..3b89ce46 100644
--- a/src/settings.sml
+++ b/src/settings.sml
@@ -537,7 +537,8 @@ type dbms = {
      trueString : string,
      falseString : string,
      onlyUnion : bool,
-     nestedRelops : bool
+     nestedRelops : bool,
+     windowFunctions : bool
 }
 
 val dbmses = ref ([] : dbms list)
@@ -568,7 +569,8 @@ val curDb = ref ({name = "",
                   trueString = "",
                   falseString = "",
                   onlyUnion = false,
-                  nestedRelops = false} : dbms)
+                  nestedRelops = false,
+                  windowFunctions = false} : dbms)
 
 fun addDbms v = dbmses := v :: !dbmses
 fun setDbms s =
diff --git a/src/sqlite.sml b/src/sqlite.sml
index f7d8f824..0f83c967 100644
--- a/src/sqlite.sml
+++ b/src/sqlite.sml
@@ -846,6 +846,7 @@ val () = addDbms {name = "sqlite",
                   trueString = "1",
                   falseString = "0",
                   onlyUnion = false,
-                  nestedRelops = false}
+                  nestedRelops = false,
+                  windowFunctions = false}
 
 end
diff --git a/src/urweb.grm b/src/urweb.grm
index 831ec4a8..eec8f8c1 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -303,6 +303,19 @@ fun parseStyle s pos =
         foldl (fn (s, e) => (EApp ((EApp ((EVar (["Basis"], "oneProperty", Infer), pos), e), pos), parseProperty s pos), pos))
                 (EVar (["Basis"], "noStyle", Infer), pos) props
 
+fun applyWindow loc e window =
+    let
+        val (pb, ob) = getOpt (window, ((EVar (["Basis"], "sql_no_partition", Infer), dummy),
+                                        (ECApp ((EVar (["Basis"], "sql_order_by_Nil", Infer), dummy),
+                                                (CWild (KRecord (KType, dummy), dummy), dummy)),
+                                         dummy)))
+        val e' = (EVar (["Basis"], "sql_window", Infer), loc)
+        val e' = (EApp (e', e), loc)
+        val e' = (EApp (e', pb), loc)
+    in
+        (EApp (e', ob), loc)
+    end
+
 %%
 %header (functor UrwebLrValsFn(structure Token : TOKEN))
 
@@ -456,7 +469,8 @@ fun parseStyle s pos =
  | selis of select_item list
  | select of select
  | sqlexp of exp
- | window of unit option
+ | window of (exp * exp) option
+ | pbopt of exp
  | wopt of exp
  | groupi of group_item
  | groupis of group_item list
@@ -2036,14 +2050,14 @@ sqlexp : TRUE                           (sql_inject (EVar (["Basis"], "True", In
                                                   let
                                                       val e = (EVar (["Basis"], "sql_window_count", Infer), loc)
                                                   in
-                                                      (EApp ((EVar (["Basis"], "sql_window", Infer), loc), e), loc)
+                                                      applyWindow loc e window
                                                   end
                                           end)
        | RANK UNIT window                (let
                                               val loc = s (RANKleft, windowright)
                                               val e = (EVar (["Basis"], "sql_window_rank", Infer), loc)
                                           in
-                                              (EApp ((EVar (["Basis"], "sql_window", Infer), loc), e), loc)
+                                              applyWindow loc e window
                                           end)
        | COUNT LPAREN sqlexp RPAREN window (let
                                                 val loc = s (COUNTleft, windowright)
@@ -2064,7 +2078,7 @@ sqlexp : TRUE                           (sql_inject (EVar (["Basis"], "True", In
                                                                        e), loc)
                                                         val e = (EApp (e, sqlexp), loc)
                                                     in
-                                                        (EApp ((EVar (["Basis"], "sql_window", Infer), loc), e), loc)
+                                                        applyWindow loc e window
                                                     end
                                             end)
        | sqlagg LPAREN sqlexp RPAREN window (let
@@ -2086,7 +2100,7 @@ sqlexp : TRUE                           (sql_inject (EVar (["Basis"], "True", In
                                                                         e), loc)
                                                          val e = (EApp (e, sqlexp), loc)
                                                      in
-                                                         (EApp ((EVar (["Basis"], "sql_window", Infer), loc), e), loc)
+                                                         applyWindow loc e window
                                                      end
                                              end)
        | COALESCE LPAREN sqlexp COMMA sqlexp RPAREN
@@ -2114,7 +2128,16 @@ sqlexp : TRUE                           (sql_inject (EVar (["Basis"], "True", In
                                          end)
 
 window :                                (NONE)
-       | OVER LPAREN RPAREN             (SOME ())
+       | OVER LPAREN pbopt obopt RPAREN (SOME (pbopt, obopt))
+
+pbopt  :                                ((EVar (["Basis"], "sql_no_partition", Infer), dummy))
+       | PARTITION BY sqlexp            (let
+                                             val loc = s (PARTITIONleft, sqlexpright)
+
+                                             val e = (EVar (["Basis"], "sql_partition", Infer), loc)
+                                         in
+                                             (EApp (e, sqlexp), loc)
+                                         end)
 
 fname  : SYMBOL                         (EVar (["Basis"], "sql_" ^ SYMBOL, Infer), s (SYMBOLleft, SYMBOLright))
        | LBRACE eexp RBRACE             (eexp)