summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--include/urweb.h3
-rw-r--r--lib/basis.urs8
-rw-r--r--src/c/urweb.c25
-rw-r--r--src/mono_reduce.sml2
-rw-r--r--src/monoize.sml32
-rw-r--r--tests/reactive.ur4
-rw-r--r--tests/reactive.urp3
7 files changed, 62 insertions, 15 deletions
diff --git a/include/urweb.h b/include/urweb.h
index c021c3dd..3d7b967c 100644
--- a/include/urweb.h
+++ b/include/urweb.h
@@ -36,7 +36,8 @@ char *uw_get_optional_input(uw_context, int name);
void uw_write(uw_context, const char*);
-int uw_Basis_new_client_reactive(uw_context);
+int uw_Basis_new_client_source(uw_context, uw_unit);
+char *uw_Basis_get_script(uw_context, uw_unit);
char *uw_Basis_htmlifyInt(uw_context, uw_Basis_int);
char *uw_Basis_htmlifyFloat(uw_context, uw_Basis_float);
diff --git a/lib/basis.urs b/lib/basis.urs
index 25923870..ffba2b37 100644
--- a/lib/basis.urs
+++ b/lib/basis.urs
@@ -80,11 +80,15 @@ val bind : m ::: (Type -> Type) -> t1 ::: Type -> t2 ::: Type
-> m t1 -> (t1 -> m t2)
-> m t2
-(** ** Transactions *)
-
con transaction :: Type -> Type
val transaction_monad : monad transaction
+con source :: Type -> Type
+val source : t ::: Type -> t -> transaction (source t)
+
+con signal :: Type -> Type
+val signal_monad : monad signal
+val signal : t ::: Type -> source t -> signal t
(** HTTP operations *)
diff --git a/src/c/urweb.c b/src/c/urweb.c
index f9b623a4..7a9b3e79 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -32,7 +32,7 @@ struct uw_context {
char **inputs;
char *script, *script_front, *script_back;
- int reactive_count;
+ int source_count;
void *db;
@@ -75,7 +75,7 @@ uw_context uw_init(size_t outHeaders_len, size_t script_len, size_t page_len, si
ctx->script_front = ctx->script = malloc(script_len);
ctx->script_back = ctx->script_front + script_len;
- ctx->reactive_count = 0;
+ ctx->source_count = 0;
return ctx;
}
@@ -105,7 +105,7 @@ void uw_reset_keep_error_message(uw_context ctx) {
ctx->heap_front = ctx->heap;
ctx->regions = NULL;
ctx->cleanup_front = ctx->cleanup;
- ctx->reactive_count = 0;
+ ctx->source_count = 0;
}
void uw_reset_keep_request(uw_context ctx) {
@@ -374,14 +374,27 @@ void uw_write_script(uw_context ctx, uw_Basis_string s) {
ctx->script_front += len;
}
-int uw_Basis_new_client_reactive(uw_context ctx) {
+char *uw_Basis_get_script(uw_context ctx, uw_unit u) {
+ if (ctx->script_front == ctx->script) {
+ char *r = uw_malloc(ctx, 1);
+ r[0] = 0;
+ return r;
+ } else {
+ char *r = uw_malloc(ctx, 41 + (ctx->script_front - ctx->script));
+
+ sprintf(r, "<script type=\"text/javascript\">%s</script>", ctx->script);
+ return r;
+ }
+}
+
+int uw_Basis_new_client_source(uw_context ctx, uw_unit u) {
size_t len;
uw_check_script(ctx, 8 + INTS_MAX);
- sprintf(ctx->script_front, "var e%d=0\n%n", ctx->reactive_count, &len);
+ sprintf(ctx->script_front, "var e%d=0\n%n", ctx->source_count, &len);
ctx->script_front += len;
- return ctx->reactive_count++;
+ return ctx->source_count++;
}
static void uw_check(uw_context ctx, size_t extra) {
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index 24e686da..9cf6d8e8 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -54,6 +54,7 @@ fun impure (e, _) =
| ESome (_, e) => impure e
| EFfi _ => false
| EFfiApp ("Basis", "set_cookie", _) => true
+ | EFfiApp ("Basis", "new_client_source", _) => true
| EFfiApp _ => false
| EApp ((EFfi _, _), _) => false
| EApp _ => true
@@ -257,6 +258,7 @@ fun reduce file =
| ESome (_, e) => summarize d e
| EFfi _ => []
| EFfiApp ("Basis", "set_cookie", _) => [Unsure]
+ | EFfiApp ("Basis", "new_client_source", _) => [Unsure]
| EFfiApp (_, _, es) => List.concat (map (summarize d) es)
| EApp ((EFfi _, _), e) => summarize d e
| EApp _ =>
diff --git a/src/monoize.sml b/src/monoize.sml
index 1c4aa81b..e23d4f80 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -133,6 +133,8 @@ fun monoType env =
| L.CApp ((L.CFfi ("Basis", "transaction"), _), t) =>
(L'.TFun ((L'.TRecord [], loc), mt env dtmap t), loc)
+ | L.CApp ((L.CFfi ("Basis", "source"), _), t) =>
+ (L'.TFfi ("Basis", "int"), loc)
| L.CApp ((L.CFfi ("Basis", "http_cookie"), _), _) =>
(L'.TFfi ("Basis", "string"), loc)
| L.CApp ((L.CFfi ("Basis", "sql_table"), _), _) =>
@@ -965,6 +967,17 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
fm)
end
+ | L.ECApp ((L.EFfi ("Basis", "source"), _), t) =>
+ let
+ val t = monoType env t
+ in
+ ((L'.EAbs ("x", t, (L'.TFun ((L'.TRecord [], loc), (L'.TFfi ("Basis", "int"), loc)), loc),
+ (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "int"), loc),
+ (L'.EFfiApp ("Basis", "new_client_source", [(L'.ERecord [], loc)]), loc)), loc)),
+ loc),
+ fm)
+ end
+
| L.ECApp ((L.EFfi ("Basis", "getCookie"), _), t) =>
let
val s = (L'.TFfi ("Basis", "string"), loc)
@@ -1769,7 +1782,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
| _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
raise Fail "No name passed to input tag")
- fun normal (tag, extra) =
+ fun normal (tag, extra, extraInner) =
let
val (tagStart, fm) = tagStart tag
val tagStart = case extra of
@@ -1779,6 +1792,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
fun normal () =
let
val (xml, fm) = monoExp (env, st, fm) xml
+ val xml = case extraInner of
+ NONE => xml
+ | SOME ei => (L'.EStrcat (ei, xml), loc)
in
((L'.EStrcat ((L'.EStrcat (tagStart, (L'.EPrim (Prim.String ">"), loc)), loc),
(L'.EStrcat (xml,
@@ -1802,7 +1818,10 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
end
in
case tag of
- "submit" => normal ("input type=\"submit\"", NONE)
+ "body" => normal ("body", NONE,
+ SOME (L'.EFfiApp ("Basis", "get_script", [(L'.ERecord [], loc)]), loc))
+
+ | "submit" => normal ("input type=\"submit\"", NONE, NONE)
| "textbox" =>
(case targs of
@@ -1847,7 +1866,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
NONE => raise Fail "No name for radioGroup"
| SOME name =>
normal ("input",
- SOME (L'.EPrim (Prim.String (" type=\"radio\" name=\"" ^ name ^ "\"")), loc)))
+ SOME (L'.EPrim (Prim.String (" type=\"radio\" name=\"" ^ name ^ "\"")), loc),
+ NONE))
| "select" =>
(case targs of
@@ -1867,10 +1887,10 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
| _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
raise Fail "No name passed to lselect tag"))
- | "option" => normal ("option", NONE)
+ | "option" => normal ("option", NONE, NONE)
- | "tabl" => normal ("table", NONE)
- | _ => normal (tag, NONE)
+ | "tabl" => normal ("table", NONE, NONE)
+ | _ => normal (tag, NONE, NONE)
end
| L.EApp ((L.ECApp (
diff --git a/tests/reactive.ur b/tests/reactive.ur
new file mode 100644
index 00000000..cb49541f
--- /dev/null
+++ b/tests/reactive.ur
@@ -0,0 +1,4 @@
+fun main () : transaction page =
+ x <- source ();
+ y <- source ();
+ return <xml><body>Hi!</body></xml>
diff --git a/tests/reactive.urp b/tests/reactive.urp
new file mode 100644
index 00000000..88dd4cbc
--- /dev/null
+++ b/tests/reactive.urp
@@ -0,0 +1,3 @@
+debug
+
+reactive
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-19 09:22:32 +0000