# HG changeset patch
# User Adam Chlipala <adamc@hcoop.net>
# Date 1239901240 14400
# Node ID 2197f0e24a9fd1b2be47e09d2b7273473f078b91
# Parent  ba4c230b7231338a0839ec24fe0d9313619d2776
Avoid thread death via message receive

diff -r ba4c230b7231 -r 2197f0e24a9f lib/js/urweb.js
--- a/lib/js/urweb.js	Thu Apr 16 12:43:55 2009 -0400
+++ b/lib/js/urweb.js	Thu Apr 16 13:00:40 2009 -0400
@@ -75,6 +75,14 @@
     return tr;
 }
 
+function flattenLocal(s) {
+  var cls = {v : null};
+  var r = flatten(cls, s);
+  for (cl = cls.v; cl != null; cl = cl.next)
+    freeClosure(cl.data);
+  return r;
+}
+
 
 
 // Dynamic tree management
@@ -259,7 +267,21 @@
 function er(s) {
   for (var ls = errorHandlers; ls; ls = ls.next)
     ls.data(s)(null);
-  throw s;
+  throw {uw_error: s};
+}
+
+var failHandlers = null;
+
+function onFail(f) {
+  failHandlers = cons(f, failHandlers);
+}
+
+function doExn(v) {
+  if (v == null || v.uw_error == null) {
+    var s = (v == null ? "null" : v.toString());
+    for (var ls = failHandlers; ls; ls = ls.next)
+      ls.data(s)(null);
+  }
 }
 
 
@@ -299,11 +321,7 @@
 }
 
 function rc(uri, parse, k) {
-  var cls = {v : null};
-  uri = flatten(cls, uri);
-  for (cl = cls.v; cl != null; cl = cl.next)
-    freeClosure(cl.data);
-
+  uri = flattenLocal(uri);
   var xhr = getXHR();
 
   xhr.onreadystatechange = function() {
@@ -410,7 +428,11 @@
           if (listener == null) {
             enqueue(ch.msgs, msg);
           } else {
-            listener(msg);
+            try {
+              listener(msg);
+            } catch (v) {
+              doExn(v);
+            }
           }
         }
 
@@ -451,7 +473,11 @@
   if (msg == null) {
     enqueue(ch.listeners, function(msg) { k(parse(msg))(null); });
   } else {
-    k(parse(msg))(null);
+    try {
+      k(parse(msg))(null);
+    } catch (v) {
+      doExn(v);
+    }
   }
 }
 
diff -r ba4c230b7231 -r 2197f0e24a9f lib/ur/basis.urs
--- a/lib/ur/basis.urs	Thu Apr 16 12:43:55 2009 -0400
+++ b/lib/ur/basis.urs	Thu Apr 16 13:00:40 2009 -0400
@@ -553,6 +553,7 @@
 val error : t ::: Type -> xbody -> t
 
 val onError : (xbody -> transaction unit) -> transaction unit
+val onFail : (string -> transaction unit) -> transaction unit
 (* Client-side only *)
 
 val show_xml : ctx ::: {Unit} -> use ::: {Type} -> bind ::: {Type} -> show (xml ctx use bind)
diff -r ba4c230b7231 -r 2197f0e24a9f tests/buffer.ur
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/buffer.ur	Thu Apr 16 13:00:40 2009 -0400
@@ -0,0 +1,25 @@
+datatype lines = End | Line of string * source lines
+
+type t = { Head : source lines, Tail : source (source lines) }
+
+val create =
+    head <- source End;
+    tail <- source head;
+    return {Head = head, Tail = tail}
+
+fun renderL lines =
+    case lines of
+        End => <xml/>
+      | Line (line, linesS) => <xml>{[line]}<br/><dyn signal={renderS linesS}/></xml>
+
+and renderS linesS =
+    lines <- signal linesS;
+    return (renderL lines)
+
+fun render t = renderS t.Head
+
+fun write t s =
+    oldTail <- get t.Tail;
+    newTail <- source End;
+    set oldTail (Line (s, newTail));
+    set t.Tail newTail
diff -r ba4c230b7231 -r 2197f0e24a9f tests/buffer.urs
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/buffer.urs	Thu Apr 16 13:00:40 2009 -0400
@@ -0,0 +1,5 @@
+type t
+
+val create : transaction t
+val render : t -> signal xbody
+val write : t -> string -> transaction unit
diff -r ba4c230b7231 -r 2197f0e24a9f tests/roundTrip.ur
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/roundTrip.ur	Thu Apr 16 13:00:40 2009 -0400
@@ -0,0 +1,36 @@
+table channels : { Client : client, Channel : channel (string * int * float) }
+  PRIMARY KEY Client
+
+fun writeBack v =
+    me <- self;
+    r <- oneRow (SELECT channels.Channel FROM channels WHERE channels.Client = {[me]});
+    send r.Channels.Channel v
+
+fun main () =
+    me <- self;
+    ch <- channel;
+    dml (INSERT INTO channels (Client, Channel) VALUES ({[me]}, {[ch]}));
+    
+    buf <- Buffer.create;
+
+    let
+        fun receiverA () =
+            v <- recv ch;
+            Buffer.write buf ("A:(" ^ v.1 ^ ", " ^ show v.2 ^ ", " ^ show v.3 ^ ")");
+            receiverA ()
+
+        fun receiverB () =
+            v <- recv ch;
+            Buffer.write buf ("B:(" ^ v.1 ^ ", " ^ show v.2 ^ ", " ^ show v.3 ^ ")");
+            error <xml>Bail out!</xml>;
+            receiverB ()
+
+        fun sender s n f =
+            sleep 9;
+            writeBack (s, n, f);
+            sender (s ^ "!") (n + 1) (f + 1.23)
+    in
+        return <xml><body onload={spawn (receiverA ()); spawn (receiverB ()); sender "" 0 0.0}>
+          <dyn signal={Buffer.render buf}/>
+        </body></xml>
+    end
diff -r ba4c230b7231 -r 2197f0e24a9f tests/roundTrip.urp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/roundTrip.urp	Thu Apr 16 13:00:40 2009 -0400
@@ -0,0 +1,5 @@
+database dbname=roundtrip
+sql roundTrip.sql
+
+buffer
+roundTrip
diff -r ba4c230b7231 -r 2197f0e24a9f tests/roundTrip.urs
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/roundTrip.urs	Thu Apr 16 13:00:40 2009 -0400
@@ -0,0 +1,1 @@
+val main : unit -> transaction page
diff -r ba4c230b7231 -r 2197f0e24a9f tests/threads.ur
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/threads.ur	Thu Apr 16 13:00:40 2009 -0400
@@ -0,0 +1,18 @@
+fun main () =
+    buf <- Buffer.create;
+    let
+        fun loop1 () =
+            Buffer.write buf "A";
+            sleep 9;
+            loop1 ()
+
+        fun loop2 () =
+            Buffer.write buf "B";
+            sleep 9;
+            error <xml>Darn</xml>
+            loop2 ()
+    in
+        return <xml><body onload={spawn (loop1 ()); loop2 ()}>
+          <dyn signal={Buffer.render buf}/>
+        </body></xml>
+    end
diff -r ba4c230b7231 -r 2197f0e24a9f tests/threads.urp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/threads.urp	Thu Apr 16 13:00:40 2009 -0400
@@ -0,0 +1,3 @@
+
+buffer
+threads
diff -r ba4c230b7231 -r 2197f0e24a9f tests/threads.urs
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/threads.urs	Thu Apr 16 13:00:40 2009 -0400
@@ -0,0 +1,1 @@
+val main : unit -> transaction page