# HG changeset patch
# User Adam Chlipala <adamc@hcoop.net>
# Date 1254865005 14400
# Node ID 166ea3944b9149a7d16b3d4e2f1b6160dd51a4d6
# Parent  7932d577cf78312961f265f896579b7594766884
Versioned1 demo working

diff -r 7932d577cf78 -r 166ea3944b91 demo/more/prose
--- a/demo/more/prose	Tue Oct 06 15:59:11 2009 -0400
+++ b/demo/more/prose	Tue Oct 06 17:36:45 2009 -0400
@@ -9,3 +9,7 @@
 orm1.urp
 
 <p>Many varieties of "object-relational mapping" (ORM) can be implemented as libraries in Ur/Web, as this demo shows.</p>
+
+versioned1.urp
+
+<p>We can also build a data store abstraction that makes it possible to view old versions of records.</p>
diff -r 7932d577cf78 -r 166ea3944b91 demo/more/versioned.ur
--- a/demo/more/versioned.ur	Tue Oct 06 15:59:11 2009 -0400
+++ b/demo/more/versioned.ur	Tue Oct 06 17:36:45 2009 -0400
@@ -2,7 +2,7 @@
                  con key :: {Type}
                  con data :: {Type}
                  constraint key ~ data
-                 constraint [When] ~ (key ++ data)
+                 constraint [When, Version] ~ (key ++ data)
 
                  val key : $(map sql_injectable key)
                  val data : $(map (fn t => {Inj : sql_injectable_prim t,
@@ -11,10 +11,14 @@
                  val keyFolder : folder key
                  val dataFolder : folder data
              end) = struct
-    con all = [When = time] ++ M.key ++ map option M.data
+    type version = int
+    con all = [When = time, Version = version] ++ M.key ++ map option M.data
+    sequence s
     table t : all
 
     val keys = List.mapQuery (SELECT DISTINCT t.{{M.key}} FROM t) (fn r => r.T)
+    fun keysAt vr = List.mapQuery (SELECT DISTINCT t.{{M.key}} FROM t
+                                   WHERE t.Version <= {[vr]}) (fn r => r.T)
 
     con dmeta = fn t => {Inj : sql_injectable_prim t,
                          Eq : eq t}
@@ -24,14 +28,16 @@
              (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 insert r =
+        vr <- nextval s;
+        dml (Basis.insert t
+                          ({Version = (SQL {[vr]}), 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]
@@ -46,9 +52,14 @@
                [_] M.keyFolder M.key r
                [_] !
 
-    fun current k =
+    datatype bound =
+             NoBound
+           | Lt of int
+           | Le of int
+
+    fun seek vro k =
         let
-            fun current' timeOpt r =
+            fun current' vro r =
                 let
                     val complete = foldR [option] [fn ts => option $ts]
                                    (fn [nm :: Name] [v :: Type] [r :: {Type}] [[nm] ~ r]
@@ -62,11 +73,12 @@
                         Some r => return (Some r)
                       | None =>
                         let
-                            val filter = case timeOpt of
-                                             None => (WHERE TRUE)
-                                           | Some time => (WHERE t.When < {[time]})
+                            val filter = case vro of
+                                             NoBound => (WHERE TRUE)
+                                           | Lt vr => (WHERE t.Version < {[vr]})
+                                           | Le vr => (WHERE t.Version <= {[vr]})
                         in
-                            ro <- oneOrNoRows (SELECT t.When, t.{{map option M.data}}
+                            ro <- oneOrNoRows (SELECT t.Version, t.{{map option M.data}}
                                                FROM t
                                                WHERE {filter}
                                                  AND {keyExp k}
@@ -81,21 +93,25 @@
                                                 case old of
                                                     None => new
                                                   | Some _ => old)
-                                            [_] M.dataFolder r (r'.T -- #When)
+                                            [_] M.dataFolder r (r'.T -- #Version)
                                 in
-                                    current' (Some r'.T.When) r
+                                    current' (Lt r'.T.Version) r
                                 end
                         end
                 end
         in
-            current' None (map0 [option] (fn [t :: Type] => None : option t) [_] M.dataFolder)
+            current' vro (map0 [option] (fn [t :: Type] => None : option t) [_] M.dataFolder)
         end
 
+    val current = seek NoBound
+    fun archive vr = seek (Le vr)
+
     fun update r =
         cur <- current (r --- M.data);
         case cur of
             None => error <xml>Tried to update nonexistent key</xml>
           | Some cur =>
+            vr <- nextval s;
             let
                 val r' = map3 [dmeta] [id] [id] [fn t => sql_exp [] [] [] (option t)]
                               (fn [t] (meta : dmeta t) old new =>
@@ -105,10 +121,14 @@
                                     else
                                         Some new))
                               [_] M.dataFolder M.data cur (r --- M.key)
-                val r' = {When = (SQL CURRENT_TIMESTAMP)}
+                val r' = {Version = (SQL {[vr]}), When = (SQL CURRENT_TIMESTAMP)}
                              ++ keyRecd r
                              ++ r'
             in
                 dml (Basis.insert t r')
             end
+
+    val updateTimes = List.mapQuery (SELECT t.Version, t.When
+                                     FROM t
+                                     ORDER BY t.When) (fn r => (r.T.Version, r.T.When))
 end
diff -r 7932d577cf78 -r 166ea3944b91 demo/more/versioned.urs
--- a/demo/more/versioned.urs	Tue Oct 06 15:59:11 2009 -0400
+++ b/demo/more/versioned.urs	Tue Oct 06 17:36:45 2009 -0400
@@ -2,7 +2,7 @@
                  con key :: {Type}
                  con data :: {Type}
                  constraint key ~ data
-                 constraint [When] ~ (key ++ data)
+                 constraint [When, Version] ~ (key ++ data)
 
                  val key : $(map sql_injectable key)
                  val data : $(map (fn t => {Inj : sql_injectable_prim t,
@@ -16,4 +16,9 @@
 
     val keys : transaction (list $M.key)
     val current : $M.key -> transaction (option $M.data)
+
+    type version
+    val keysAt : version -> transaction (list $M.key)
+    val archive : version -> $M.key -> transaction (option $M.data)
+    val updateTimes : transaction (list (version * time))
 end
diff -r 7932d577cf78 -r 166ea3944b91 demo/more/versioned1.ur
--- a/demo/more/versioned1.ur	Tue Oct 06 15:59:11 2009 -0400
+++ b/demo/more/versioned1.ur	Tue Oct 06 17:36:45 2009 -0400
@@ -9,6 +9,18 @@
                                                 Eq = _}}
                     end)
 
+fun retro vr =
+    ks <- keysAt vr;
+    ks <- List.mapM (fn r => fso <- archive vr r; return (r.Id, fso)) ks;
+
+    return <xml><body>
+      {List.mapX (fn (k, r) => <xml><li>
+        {[k]}: {case r of
+                    None => <xml>Whoa!</xml>
+                  | Some r => <xml>{[r.Nam]}, {[r.ShoeSize]}</xml>}
+      </li></xml>) ks}
+    </body></xml>
+
 fun expandKey k =
     name <- source "";
     shoeSize <- source "";
@@ -23,6 +35,8 @@
     name <- source "";
     shoeSize <- source "";
 
+    times <- updateTimes;
+
     return <xml><body>
       <dyn signal={ks <- signal ks;
                    return (List.mapX (fn kr => <xml><div>
@@ -59,4 +73,8 @@
                                              kr <- expandKey (readError id);
                                              set ks (kr :: cur)}/></th></tr>
       </table>
+
+      <h2>Archive</h2>
+
+      {List.mapX (fn (vr, tm) => <xml><li><a link={retro vr}>{[tm]}</a></li></xml>) times}
     </body></xml>
diff -r 7932d577cf78 -r 166ea3944b91 lib/ur/list.ur
--- a/lib/ur/list.ur	Tue Oct 06 15:59:11 2009 -0400
+++ b/lib/ur/list.ur	Tue Oct 06 17:36:45 2009 -0400
@@ -230,9 +230,10 @@
 fun mapQuery [tables ::: {{Type}}] [exps ::: {Type}] [t ::: Type]
              [tables ~ exps] (q : sql_query tables exps)
              (f : $(exps ++ map (fn fields :: {Type} => $fields) tables) -> t) =
-    query q
-          (fn fs acc => return (f fs :: acc))
-          []
+    ls <- query q
+                (fn fs acc => return (f fs :: acc))
+                [];
+    return (rev ls)
 
 fun assoc [a] [b] (_ : eq a) (x : a) =
     let
diff -r 7932d577cf78 -r 166ea3944b91 src/c/urweb.c
--- a/src/c/urweb.c	Tue Oct 06 15:59:11 2009 -0400
+++ b/src/c/urweb.c	Tue Oct 06 17:36:45 2009 -0400
@@ -2160,6 +2160,7 @@
 
   if (localtime_r(&t, &stm)) {
     s = uw_malloc(ctx, TIMES_MAX);
+    --stm.tm_hour;
     len = strftime(s, TIMES_MAX, TIME_FMT, &stm);
     r = uw_malloc(ctx, len + 14);
     sprintf(r, "'%s'::timestamp", s);
@@ -2176,7 +2177,6 @@
   if (localtime_r(&t, &stm)) {
     uw_check_heap(ctx, TIMES_MAX);
     r = ctx->heap.front;
-    --stm.tm_hour;
     len = strftime(r, TIMES_MAX, TIME_FMT, &stm);
     ctx->heap.front += len+1;
     return r;
@@ -2429,7 +2429,6 @@
     *dot = 0;
     if (strptime(s, TIME_FMT_PG, &stm)) {
       *dot = '.';
-      --stm.tm_hour;
       return mktime(&stm);
     }
     else {
@@ -2439,10 +2438,8 @@
   }
   else {
     if (strptime(s, TIME_FMT_PG, &stm) == end) {
-      --stm.tm_hour;
       return mktime(&stm);
     } else if (strptime(s, TIME_FMT, &stm) == end) {
-      --stm.tm_hour;
       return mktime(&stm);
     } else
       uw_error(ctx, FATAL, "Can't parse time: %s", s);
@@ -2602,9 +2599,13 @@
     ctx->transactionals[i].free(ctx->transactionals[i].data);
 
   // Splice script data into appropriate part of page
-  if (ctx->returning_blob || ctx->script_header[0] == 0)
-    ;
-  else if (buf_used(&ctx->script) == 0) {
+  if (ctx->returning_blob || ctx->script_header[0] == 0) {
+    char *start = strstr(ctx->page.start, "<sc>");
+    if (start) {
+      memmove(start, start + 4, buf_used(&ctx->page) - (start - ctx->page.start) - 4);
+      ctx->page.front -= 4;
+    }
+  } else if (buf_used(&ctx->script) == 0) {
     size_t len = strlen(ctx->script_header);
     char *start = strstr(ctx->page.start, "<sc>");
     if (start) {
diff -r 7932d577cf78 -r 166ea3944b91 src/cjr_print.sml
--- a/src/cjr_print.sml	Tue Oct 06 15:59:11 2009 -0400
+++ b/src/cjr_print.sml	Tue Oct 06 17:36:45 2009 -0400
@@ -536,23 +536,6 @@
 
       | _ => raise Fail "CjrPrint: getPargs"
 
-fun p_ensql t e =
-    case t of
-        Int => box [string "uw_Basis_attrifyInt(ctx, ", e, string ")"]
-      | Float => box [string "uw_Basis_attrifyFloat(ctx, ", e, string ")"]
-      | String => e
-      | Bool => box [string "(", e, string " ? \"TRUE\" : \"FALSE\")"]
-      | Time => box [string "uw_Basis_attrifyTime(ctx, ", e, string ")"]
-      | Blob => box [e, string ".data"]
-      | Channel => box [string "uw_Basis_attrifyChannel(ctx, ", e, string ")"]
-      | Client => box [string "uw_Basis_attrifyClient(ctx, ", e, string ")"]
-      | Nullable String => e
-      | Nullable t => box [string "(",
-                           e,
-                           string " == NULL ? NULL : ",
-                           p_ensql t (box [string "(*", e, string ")"]),
-                           string ")"]
-
 fun notLeaky env allowHeapAllocated =
     let
         fun nl ok (t, _) =
diff -r 7932d577cf78 -r 166ea3944b91 src/mono_reduce.sml
--- a/src/mono_reduce.sml	Tue Oct 06 15:59:11 2009 -0400
+++ b/src/mono_reduce.sml	Tue Oct 06 17:36:45 2009 -0400
@@ -380,7 +380,8 @@
                                                               else
                                                                   [Unsure])
                                   | EApp (f, x) =>
-                                    unravel (#1 f, passed + 1, summarize d x @ ls)
+                                    unravel (#1 f, passed + 1, List.revAppend (summarize d x,
+                                                                               ls))
                                   | _ => [Unsure]
                         in
                             unravel (e, 0, [])
@@ -584,6 +585,7 @@
                                     (*val () = Print.prefaces "Try"
                                                             [(*("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan)),*)
                                                              ("e'", MonoPrint.p_exp env e'),
+                                                             ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b),
                                                              ("e'_eff", p_events effs_e'),
                                                              ("b", p_events effs_b)]*)