SELECT DISTINCT; eta expansion during Cjrization

15 files changed, 260 insertions, 11 deletions

diff --git a/demo/more/versioned.ur b/demo/more/versioned.ur
new file mode 100644
index 00000000..cb93ef6c
--- /dev/null
+++ b/demo/more/versioned.ur
@@ -0,0 +1,114 @@
+functor Make(M : sig
+                 con key :: {Type}
+                 con data :: {Type}
+                 constraint key ~ data
+                 constraint [When] ~ (key ++ data)
+
+                 val key : $(map sql_injectable key)
+                 val data : $(map (fn t => {Inj : sql_injectable_prim t,
+                                            Eq : eq t}) data)
+
+                 val keyFolder : folder key
+                 val dataFolder : folder data
+             end) = struct
+    con all = [When = time] ++ M.key ++ map option M.data
+    table t : all
+
+    val keys = List.mapQuery (SELECT DISTINCT t.{{M.key}} FROM t) (fn r => r.T)
+
+    con dmeta = fn t => {Inj : sql_injectable_prim t,
+                         Eq : eq t}
+
+    fun keyRecd (r : $(M.key ++ M.data)) =
+        map2 [sql_injectable] [id] [sql_exp [] [] []]
+             (fn [t] => @sql_inject)
+             [_] M.keyFolder M.key (r --- M.data)
+
+    fun insert r = dml (Basis.insert t
+                                     ({When = (SQL CURRENT_TIMESTAMP)}
+                                          ++ keyRecd r
+                                          ++ map2 [dmeta] [id]
+                                          [fn t => sql_exp [] [] [] (option t)]
+                                          (fn [t] x v => @sql_inject (@sql_option_prim x.Inj)
+                                                          (Some v))
+                                          [_] M.dataFolder M.data (r --- M.key)))
+
+    fun keyExp (r : $M.key) : sql_exp [T = all] [] [] bool =
+        foldR2 [sql_injectable] [id] [fn before => after :: {Type} -> [before ~ after]
+                                         => sql_exp [T = before ++ after] [] [] bool]
+               (fn [nm :: Name] [t :: Type] [before :: {Type}] [[nm] ~ before]
+                                (inj : sql_injectable t) (v : t)
+                   (e : after :: {Type} -> [before ~ after]
+                    => sql_exp [T = before ++ after] [] [] bool)
+                   [after :: {Type}] [[nm = t] ++ before ~ after] =>
+                   (SQL t.{nm} = {[v]} AND {e [[nm = t] ++ after] !}))
+               (fn [after :: {Type}] [[] ~ after] => (SQL TRUE))
+               [_] M.keyFolder M.key r
+               [_] !
+
+    fun current k =
+        let
+            fun current' timeOpt r =
+                let
+                    val complete = foldR [option] [fn ts => option $ts]
+                                   (fn [nm :: Name] [v :: Type] [r :: {Type}] [[nm] ~ r]
+                                                    v r =>
+                                       case (v, r) of
+                                           (Some v, Some r) => Some ({nm = v} ++ r)
+                                         | _ => None)
+                                   (Some {}) [_] M.dataFolder r
+                in
+                    case complete of
+                        Some r => return (Some r)
+                      | None =>
+                        let
+                            val filter = case timeOpt of
+                                             None => (WHERE TRUE)
+                                           | Some time => (WHERE t.When < {[time]})
+                        in
+                            ro <- oneOrNoRows (SELECT t.When, t.{{map option M.data}}
+                                               FROM t
+                                               WHERE {filter}
+                                                 AND {keyExp k}
+                                               ORDER BY t.When DESC
+                                               LIMIT 1);
+                            case ro of
+                                None => return None
+                              | Some r' =>
+                                let
+                                    val r = map2 [option] [option] [option]
+                                            (fn [t ::: Type] old new =>
+                                                case old of
+                                                    None => new
+                                                  | Some _ => old)
+                                            [_] M.dataFolder r (r'.T -- #When)
+                                in
+                                    current' (Some r'.T.When) r
+                                end
+                        end
+                end
+        in
+            current' None (map0 [option] (fn [t :: Type] => None : option t) [_] M.dataFolder)
+        end
+
+    fun update r =
+        cur <- current (r --- M.data);
+        case cur of
+            None => error <xml>Tried to update nonexistent key</xml>
+          | Some cur =>
+            let
+                val r' = map3 [dmeta] [id] [id] [fn t => sql_exp [] [] [] (option t)]
+                              (fn [t] (meta : dmeta t) old new =>
+                                  @sql_inject (@sql_option_prim meta.Inj)
+                                   (if @@eq [_] meta.Eq old new then
+                                        None
+                                    else
+                                        Some new))
+                              [_] M.dataFolder M.data cur (r --- M.key)
+                val r' = {When = (SQL CURRENT_TIMESTAMP)}
+                             ++ keyRecd r
+                             ++ r'
+            in
+                dml (Basis.insert t r')
+            end
+end
diff --git a/demo/more/versioned.urp b/demo/more/versioned.urp
new file mode 100644
index 00000000..a75d6c6a
--- /dev/null
+++ b/demo/more/versioned.urp
@@ -0,0 +1,4 @@
+
+$/option
+$/list
+versioned
diff --git a/demo/more/versioned.urs b/demo/more/versioned.urs
new file mode 100644
index 00000000..eb0a485e
--- /dev/null
+++ b/demo/more/versioned.urs
@@ -0,0 +1,19 @@
+functor Make(M : sig
+                 con key :: {Type}
+                 con data :: {Type}
+                 constraint key ~ data
+                 constraint [When] ~ (key ++ data)
+
+                 val key : $(map sql_injectable key)
+                 val data : $(map (fn t => {Inj : sql_injectable_prim t,
+                                            Eq : eq t}) data)
+
+                 val keyFolder : folder key
+                 val dataFolder : folder data
+             end) : sig
+    val insert : $(M.key ++ M.data) -> transaction unit
+    val update : $(M.key ++ M.data) -> transaction unit
+
+    val keys : transaction (list $M.key)
+    val current : $M.key -> transaction (option $M.data)
+end
diff --git a/demo/more/versioned1.ur b/demo/more/versioned1.ur
new file mode 100644
index 00000000..506d2778
--- /dev/null
+++ b/demo/more/versioned1.ur
@@ -0,0 +1,62 @@
+open Versioned.Make(struct
+                        con key = [Id = int]
+                        con data = [Nam = string, ShoeSize = int]
+
+                        val key = {Id = _}
+                        val data = {Nam = {Inj = _,
+                                           Eq = _},
+                                    ShoeSize = {Inj = _,
+                                                Eq = _}}
+                    end)
+
+fun expandKey k =
+    name <- source "";
+    shoeSize <- source "";
+    return {Key = k, Nam = name, ShoeSize = shoeSize}
+
+fun main () =
+    ks0 <- keys;
+    ks0 <- List.mapM (fn r => expandKey r.Id) ks0;
+    ks <- source ks0;
+
+    id <- source "";
+    name <- source "";
+    shoeSize <- source "";
+
+    return <xml><body>
+      <dyn signal={ks <- signal ks;
+                   return (List.mapX (fn kr => <xml><div>
+                     {[kr.Key]}:
+                     <ctextbox source={kr.Nam}/>
+                     <ctextbox size={5} source={kr.ShoeSize}/>
+                     <button value="Latest" onclick={ro <- rpc (current {Id = kr.Key});
+                                                     case ro of
+                                                         None => alert "Can't get it!"
+                                                       | Some r =>
+                                                         set kr.Nam r.Nam;
+                                                         set kr.ShoeSize (show r.ShoeSize)}/>
+                     <button value="Update" onclick={name <- get kr.Nam;
+                                                     shoeSize <- get kr.ShoeSize;
+                                                     rpc (update {Id = kr.Key,
+                                                                  Nam = name,
+                                                                  ShoeSize = readError shoeSize})
+                                                    }/>
+                   </div></xml>) ks)}/>
+
+      <h2>Add one:</h2>
+
+      <table>
+        <tr><th>Id:</th> <td><ctextbox size={5} source={id}/></td></tr>
+        <tr><th>Name:</th> <td><ctextbox source={name}/></td></tr>
+        <tr><th>Shoe size:</th> <td><ctextbox size={5} source={shoeSize}/></td></tr>
+        <tr><th><button value="Add" onclick={id <- get id;
+                                             name <- get name;
+                                             shoeSize <- get shoeSize;
+                                             rpc (insert {Id = readError id, Nam = name,
+                                                          ShoeSize = readError shoeSize});
+
+                                             cur <- get ks;
+                                             kr <- expandKey (readError id);
+                                             set ks (kr :: cur)}/></th></tr>
+      </table>
+    </body></xml>
diff --git a/demo/more/versioned1.urp b/demo/more/versioned1.urp
new file mode 100644
index 00000000..c24b3531
--- /dev/null
+++ b/demo/more/versioned1.urp
@@ -0,0 +1,6 @@
+debug
+library versioned
+database dbname=test
+sql versioned1.sql
+
+versioned1
diff --git a/demo/more/versioned1.urs b/demo/more/versioned1.urs
new file mode 100644
index 00000000..6ac44e0b
--- /dev/null
+++ b/demo/more/versioned1.urs
@@ -0,0 +1 @@
+val main : unit -> transaction page
diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index b7468d2f..9ddae8fe 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -291,7 +291,8 @@ val sql_query1 : tables ::: {{Type}}
                  -> grouped ::: {{Type}}
                  -> selectedFields ::: {{Type}}
                  -> selectedExps ::: {Type}
-                 -> {From : sql_from_items tables,
+                 -> {Distinct : bool,
+                     From : sql_from_items tables,
                      Where : sql_exp tables [] [] bool,
                      GroupBy : sql_subset tables grouped,
                      Having : sql_exp grouped tables [] bool,
diff --git a/lib/ur/top.ur b/lib/ur/top.ur
index 67e75573..a2395d4f 100644
--- a/lib/ur/top.ur
+++ b/lib/ur/top.ur
@@ -92,6 +92,12 @@ fun read_option [t ::: Type] (_ : read t) =
 fun txt [t] [ctx ::: {Unit}] [use ::: {Type}] (_ : show t) (v : t) =
     cdata (show v)
 
+fun map0 [K] [tf :: K -> Type] (f : t :: K -> tf t) [r :: {K}] (fl : folder r) =
+    fl [fn r :: {K} => $(map tf r)]
+    (fn [nm :: Name] [t :: K] [rest :: {K}] [[nm] ~ rest] acc =>
+        acc ++ {nm = f [t]})
+    {}
+
 fun mp [K] [tf1 :: K -> Type] [tf2 :: K -> Type] (f : t ::: K -> tf1 t -> tf2 t) [r :: {K}] (fl : folder r) =
     fl [fn r :: {K} => $(map tf1 r) -> $(map tf2 r)]
     (fn [nm :: Name] [t :: K] [rest :: {K}] [[nm] ~ rest] acc r =>
diff --git a/lib/ur/top.urs b/lib/ur/top.urs
index 637c4e5d..ef907760 100644
--- a/lib/ur/top.urs
+++ b/lib/ur/top.urs
@@ -45,6 +45,9 @@ val read_option : t ::: Type -> read t -> read (option t)
 val txt : t ::: Type -> ctx ::: {Unit} -> use ::: {Type} -> show t -> t
           -> xml ctx use []
 
+val map0 : K --> tf :: (K -> Type)
+           -> (t :: K -> tf t)
+           -> r :: {K} -> folder r -> $(map tf r)
 val mp : K --> tf1 :: (K -> Type) -> tf2 :: (K -> Type)
          -> (t ::: K -> tf1 t -> tf2 t)
          -> r :: {K} -> folder r -> $(map tf1 r) -> $(map tf2 r)
diff --git a/src/cjrize.sml b/src/cjrize.sml
index 6a79b4e6..bf814266 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -520,9 +520,14 @@ fun cifyDecl ((d, loc), sm) =
                                           in
                                               ((ax, dom) :: args, t, e)
                                           end
-                                        | (L'.TFun _, _) =>
-                                          (ErrorMsg.errorAt loc "Function isn't explicit at code generation";
-                                           ([], tAll, eAll))
+                                        | (L'.TFun (dom, ran), _) =>
+                                          let
+                                              val e = MonoEnv.liftExpInExp 0 eAll
+                                              val e = (L.EApp (e, (L.ERel 0, loc)), loc)
+                                              val (args, t, e) = unravel (ran, e)
+                                          in
+                                              (("x", dom) :: args, t, e)
+                                          end
                                         | _ => ([], tAll, eAll)
 
                                   val (args, ran, e) = unravel (t, e)
diff --git a/src/elisp/urweb-mode.el b/src/elisp/urweb-mode.el
index 7f4b0dee..42846e6c 100644
--- a/src/elisp/urweb-mode.el
+++ b/src/elisp/urweb-mode.el
@@ -144,7 +144,7 @@ See doc for the variable `urweb-mode-info'."
   "A regexp that matches any non-SQL keywords of Ur/Web.")
 
 (defconst urweb-sql-keywords-regexp
-  (urweb-syms-re "SELECT" "FROM" "AS" "WHERE" "SQL" "GROUP" "ORDER" "BY"
+  (urweb-syms-re "SELECT" "DISTINCT" "FROM" "AS" "WHERE" "SQL" "GROUP" "ORDER" "BY"
                  "HAVING" "LIMIT" "OFFSET" "ALL" "UNION" "INTERSECT" "EXCEPT"
                  "TRUE" "FALSE" "AND" "OR" "NOT" "COUNT" "AVG" "SUM" "MIN" "MAX"
                  "ASC" "DESC" "INSERT" "INTO" "VALUES" "UPDATE" "SET" "DELETE"
diff --git a/src/mono_env.sig b/src/mono_env.sig
index c59596ae..c5ca7c0b 100644
--- a/src/mono_env.sig
+++ b/src/mono_env.sig
@@ -48,5 +48,7 @@ signature MONO_ENV = sig
     val declBinds : env -> Mono.decl -> env
     val patBinds : env -> Mono.pat -> env
     val patBindsN : Mono.pat -> int
+
+    val liftExpInExp : int -> Mono.exp -> Mono.exp
                                                  
 end
diff --git a/src/monoize.sml b/src/monoize.sml
index b80b4a65..a01f953f 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -1771,6 +1771,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
             let
                 fun sc s = (L'.EPrim (Prim.String s), loc)
                 val s = (L'.TFfi ("Basis", "string"), loc)
+                val b = (L'.TFfi ("Basis", "bool"), loc)
                 val un = (L'.TRecord [], loc)
                 fun gf s = (L'.EField ((L'.ERel 0, loc), s), loc)
 
@@ -1806,7 +1807,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                                         (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) sexps
                     in
                         ((L'.EAbs ("r",
-                                   (L'.TRecord [("From", s),
+                                   (L'.TRecord [("Distinct", b),
+                                                ("From", s),
                                                 ("Where", s),
                                                 ("GroupBy", un),
                                                 ("Having", s),
@@ -1815,6 +1817,22 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                                     loc),
                                    s,
                                    strcat [sc "SELECT ",
+                                           (L'.ECase (gf "Distinct",
+                                                      [((L'.PCon (L'.Enum,
+                                                                  L'.PConFfi {mod = "Basis",
+                                                                              datatyp = "bool",
+                                                                              con = "True",
+                                                                              arg = NONE},
+                                                                  NONE), loc),
+                                                        (L'.EPrim (Prim.String "DISTINCT "), loc)),
+                                                       ((L'.PCon (L'.Enum,
+                                                                  L'.PConFfi {mod = "Basis",
+                                                                              datatyp = "bool",
+                                                                              con = "False",
+                                                                              arg = NONE},
+                                                                  NONE), loc),
+                                                        (L'.EPrim (Prim.String ""), loc))],
+                                                      {disc = b, result = s}), loc),
                                            strcatComma (map (fn (x, t) =>
                                                                 strcat [
                                                                 (L'.EField (gf "SelectExps", x), loc),
diff --git a/src/urweb.grm b/src/urweb.grm
index 111b1854..edd93d96 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -208,7 +208,7 @@ fun patType loc (p : pat) =
  | NOTAGS of string 
  | BEGIN_TAG of string | END_TAG of string
 
- | SELECT | FROM | AS | CWHERE | GROUP | ORDER | BY | HAVING
+ | SELECT | DISTINCT | FROM | AS | CWHERE | GROUP | ORDER | BY | HAVING
  | UNION | INTERSECT | EXCEPT
  | LIMIT | OFFSET | ALL
  | TRUE | FALSE | CAND | OR | NOT
@@ -314,6 +314,7 @@ fun patType loc (p : pat) =
 
  | query of exp
  | query1 of exp
+ | dopt of exp
  | tables of con list * exp
  | fitem of con list * exp
  | tname of con
@@ -625,7 +626,7 @@ pmodes :                                ([])
 commaOpt:                               ()
         | COMMA                         ()
 
-pkopt  :                                (EVar (["Basis"], "no_primary_key", Infer), ErrorMsg.dummySpan)
+pkopt  :                                (EVar (["Basis"], "no_primary_key", Infer), dummy)
        | PRIMARY KEY tnames             (let
                                              val loc = s (PRIMARYleft, tnamesright)
 
@@ -1410,8 +1411,12 @@ query  : query1 obopt lopt ofopt        (let
                                          in
                                              (EApp ((EVar (["Basis"], "sql_query", Infer), loc), re), loc)
                                          end)
-                
-query1 : SELECT select FROM tables wopt gopt hopt
+
+dopt   :                                (EVar (["Basis"], "False", Infer), dummy)
+       | DISTINCT                       (EVar (["Basis"], "True", Infer),
+                                         s (DISTINCTleft, DISTINCTright))
+
+query1 : SELECT dopt select FROM tables wopt gopt hopt
                                         (let
                                              val loc = s (SELECTleft, tablesright)
 
@@ -1460,7 +1465,9 @@ query1 : SELECT select FROM tables wopt gopt hopt
                                                            end
 
                                              val e = (EVar (["Basis"], "sql_query1", Infer), loc)
-                                             val re = (ERecord [((CName "From", loc),
+                                             val re = (ERecord [((CName "Distinct", loc),
+                                                                 dopt),
+                                                                ((CName "From", loc),
                                                                  #2 tables),
                                                                 ((CName "Where", loc),
                                                                  wopt),
diff --git a/src/urweb.lex b/src/urweb.lex
index 38816a3c..4e572009 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -408,6 +408,7 @@ notags = [^<{\n]+;
 <INITIAL> "Unit"      => (Tokens.KUNIT (pos yypos, pos yypos + size yytext));
 
 <INITIAL> "SELECT"    => (Tokens.SELECT (pos yypos, pos yypos + size yytext));
+<INITIAL> "DISTINCT"  => (Tokens.DISTINCT (pos yypos, pos yypos + size yytext));
 <INITIAL> "FROM"      => (Tokens.FROM (pos yypos, pos yypos + size yytext));
 <INITIAL> "AS"        => (Tokens.AS (pos yypos, pos yypos + size yytext));
 <INITIAL> "WHERE"     => (Tokens.CWHERE (pos yypos, pos yypos + size yytext));