summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--include/urweb.h4
-rw-r--r--src/c/urweb.c31
-rw-r--r--src/cjrize.sml1
-rw-r--r--src/jscomp.sml14
-rw-r--r--src/mono.sml1
-rw-r--r--src/mono_print.sml1
-rw-r--r--src/mono_reduce.sml2
-rw-r--r--src/mono_util.sml5
-rw-r--r--src/monoize.sml14
-rw-r--r--tests/reactive2.ur6
-rw-r--r--tests/reactive2.urp3
11 files changed, 68 insertions, 14 deletions
diff --git a/include/urweb.h b/include/urweb.h
index 647f153a..a5bb8dc0 100644
--- a/include/urweb.h
+++ b/include/urweb.h
@@ -36,7 +36,9 @@ char *uw_get_optional_input(uw_context, int name);
void uw_write(uw_context, const char*);
-int uw_Basis_new_client_source(uw_context, uw_unit);
+uw_Basis_int uw_Basis_new_client_source(uw_context, uw_Basis_string);
+uw_unit uw_Basis_set_client_source(uw_context, uw_Basis_int, uw_Basis_string);
+
char *uw_Basis_get_script(uw_context, uw_unit);
char *uw_Basis_htmlifyInt(uw_context, uw_Basis_int);
diff --git a/src/c/urweb.c b/src/c/urweb.c
index 11b99f4c..2c6d493a 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -363,6 +363,7 @@ static void uw_check_script(uw_context ctx, size_t extra) {
ctx->script_front = new_script + (ctx->script_front - ctx->script);
ctx->script_back = new_script + next;
ctx->script = new_script;
+ printf("new_script = %p\n", new_script);
}
}
@@ -434,7 +435,7 @@ uw_Basis_string uw_Basis_jsifyString_ws(uw_context ctx, uw_Basis_string s) {
char c = *s;
switch (c) {
- case '"':
+ case '\'':
strcpy(s2, "\\\"");
s2 += 2;
break;
@@ -457,18 +458,36 @@ uw_Basis_string uw_Basis_jsifyString_ws(uw_context ctx, uw_Basis_string s) {
return r;
}
-int uw_Basis_new_client_source(uw_context ctx, uw_Basis_string s) {
- size_t len;
+uw_Basis_int uw_Basis_new_client_source(uw_context ctx, uw_Basis_string s) {
+ int len;
+ size_t s_len = strlen(s);
- uw_check_script(ctx, 8 + INTS_MAX);
+ uw_check_script(ctx, 12 + INTS_MAX + s_len);
sprintf(ctx->script_front, "var s%d=sc(%n", ctx->source_count, &len);
ctx->script_front += len;
- uw_Basis_jsifyString_ws(ctx, s);
- uw_write_script(ctx, ");");
+ strcpy(ctx->script_front, s);
+ ctx->script_front += s_len;
+ strcpy(ctx->script_front, ");");
+ ctx->script_front += 2;
return ctx->source_count++;
}
+uw_unit uw_Basis_set_client_source(uw_context ctx, uw_Basis_int n, uw_Basis_string s) {
+ int len;
+ size_t s_len = strlen(s);
+
+ uw_check_script(ctx, 6 + INTS_MAX + s_len);
+ sprintf(ctx->script_front, "s%d.v=%n", (int)n, &len);
+ ctx->script_front += len;
+ strcpy(ctx->script_front, s);
+ ctx->script_front += s_len;
+ strcpy(ctx->script_front, ";");
+ ctx->script_front++;
+
+ return uw_unit_v;
+}
+
static void uw_check(uw_context ctx, size_t extra) {
size_t desired = ctx->page_front - ctx->page + extra, next;
char *new_page;
diff --git a/src/cjrize.sml b/src/cjrize.sml
index a9c51826..6d0ece61 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -120,6 +120,7 @@ fun cifyTyp x =
in
((L'.TOption t, loc), sm)
end
+ | L.TSource => ((L'.TFfi ("Basis", "int"), loc), sm)
| L.TSignal _ => raise Fail "Cjrize: TSignal remains"
in
cify IM.empty x
diff --git a/src/jscomp.sml b/src/jscomp.sml
index f7ef6927..8b874289 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -121,6 +121,13 @@ fun jsExp mode outer =
(str "ERROR", st))
val strcat = strcat loc
+
+ fun quoteExp (t : typ) e =
+ case #1 t of
+ TSource => strcat [str "s",
+ (EFfiApp ("Basis", "htmlifyInt", [e]), loc)]
+ | _ => (EM.errorAt loc "Don't know how to embed type in JavaScript";
+ str "ERROR")
in
case #1 e of
EPrim (Prim.String s) =>
@@ -130,6 +137,7 @@ fun jsExp mode outer =
"\\047"
else
"'"
+ | #"\"" => "\\\""
| #"<" =>
if mode = Script then
"<"
@@ -143,7 +151,11 @@ fun jsExp mode outer =
if n < inner then
(str ("uwr" ^ var n), st)
else
- (str ("uwo" ^ var n), st)
+ let
+ val n = n - inner
+ in
+ (quoteExp (List.nth (outer, n)) (ERel n, loc), st)
+ end
| ENamed _ => raise Fail "Named"
| ECon (_, pc, NONE) => (patCon pc, st)
| ECon (_, pc, SOME e) =>
diff --git a/src/mono.sml b/src/mono.sml
index ae9a06c7..41457071 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -37,6 +37,7 @@ datatype typ' =
| TDatatype of int * (datatype_kind * (string * int * typ option) list) ref
| TFfi of string * string
| TOption of typ
+ | TSource
| TSignal of typ
withtype typ = typ' located
diff --git a/src/mono_print.sml b/src/mono_print.sml
index b3c0a568..a876cfac 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -65,6 +65,7 @@ fun p_typ' par env (t, _) =
| TOption t => box [string "option(",
p_typ env t,
string ")"]
+ | TSource => string "source"
| TSignal t => box [string "signal(",
p_typ env t,
string ")"]
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index a6777db5..072c548e 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -55,6 +55,7 @@ fun impure (e, _) =
| EFfi _ => false
| EFfiApp ("Basis", "set_cookie", _) => true
| EFfiApp ("Basis", "new_client_source", _) => true
+ | EFfiApp ("Basis", "set_client_source", _) => true
| EFfiApp _ => false
| EApp ((EFfi _, _), _) => false
| EApp _ => true
@@ -263,6 +264,7 @@ fun reduce file =
| EFfi _ => []
| EFfiApp ("Basis", "set_cookie", _) => [Unsure]
| EFfiApp ("Basis", "new_client_source", _) => [Unsure]
+ | EFfiApp ("Basis", "set_client_source", _) => [Unsure]
| EFfiApp (_, _, es) => List.concat (map (summarize d) es)
| EApp ((EFfi _, _), e) => summarize d e
| EApp _ =>
diff --git a/src/mono_util.sml b/src/mono_util.sml
index b14e3ac9..3f9183d0 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -51,6 +51,7 @@ fun compare ((t1, _), (t2, _)) =
| (TDatatype (n1, _), TDatatype (n2, _)) => Int.compare (n1, n2)
| (TFfi (m1, x1), TFfi (m2, x2)) => join (String.compare (m1, m2), fn () => String.compare (x1, x2))
| (TOption t1, TOption t2) => compare (t1, t2)
+ | (TSource, TSource) => EQUAL
| (TSignal t1, TSignal t2) => compare (t1, t2)
| (TFun _, _) => LESS
@@ -68,6 +69,9 @@ fun compare ((t1, _), (t2, _)) =
| (TOption _, _) => LESS
| (_, TOption _) => GREATER
+ | (TSource, _) => LESS
+ | (_, TSource) => GREATER
+
and compareFields ((x1, t1), (x2, t2)) =
join (String.compare (x1, x2),
fn () => compare (t1, t2))
@@ -100,6 +104,7 @@ fun mapfold fc =
S.map2 (mft t,
fn t' =>
(TOption t, loc))
+ | TSource => S.return2 cAll
| TSignal t =>
S.map2 (mft t,
fn t' =>
diff --git a/src/monoize.sml b/src/monoize.sml
index e34ef162..f40d49d0 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -134,7 +134,7 @@ 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'.TSource, loc)
| L.CApp ((L.CFfi ("Basis", "signal"), _), t) =>
(L'.TSignal (mt env dtmap t), loc)
| L.CApp ((L.CFfi ("Basis", "http_cookie"), _), _) =>
@@ -973,9 +973,10 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
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'.ERel 1, loc)]), loc)), loc)),
+ ((L'.EAbs ("x", t, (L'.TFun ((L'.TRecord [], loc), (L'.TSource, loc)), loc),
+ (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TSource, loc),
+ (L'.EFfiApp ("Basis", "new_client_source",
+ [(L'.EJavaScript (L'.File, (L'.ERel 1, loc)), loc)]), loc)), loc)),
loc),
fm)
end
@@ -983,12 +984,13 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
let
val t = monoType env t
in
- ((L'.EAbs ("src", (L'.TFfi ("Basis", "int"), loc),
+ ((L'.EAbs ("src", (L'.TSource, loc),
(L'.TFun (t, (L'.TFun ((L'.TRecord [], loc), (L'.TRecord [], loc)), loc)), loc),
(L'.EAbs ("v", t, (L'.TFun ((L'.TRecord [], loc), (L'.TRecord [], loc)), loc),
(L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc),
(L'.EFfiApp ("Basis", "set_client_source",
- [(L'.ERel 2, loc), (L'.ERel 1, loc)]),
+ [(L'.ERel 2, loc),
+ (L'.EJavaScript (L'.File, (L'.ERel 1, loc)), loc)]),
loc)), loc)), loc)), loc),
fm)
end
diff --git a/tests/reactive2.ur b/tests/reactive2.ur
new file mode 100644
index 00000000..7164468e
--- /dev/null
+++ b/tests/reactive2.ur
@@ -0,0 +1,6 @@
+fun main () : transaction page =
+ x <- source <xml>TEST</xml>;
+ set x <xml>HI</xml>;
+ return <xml><body>
+ <dyn signal={signal x}/>
+ </body></xml>
diff --git a/tests/reactive2.urp b/tests/reactive2.urp
new file mode 100644
index 00000000..bdc0d1be
--- /dev/null
+++ b/tests/reactive2.urp
@@ -0,0 +1,3 @@
+debug
+
+reactive2
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-13 17:49:46 +0000