summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2008-12-19 11:47:18 -0500
committerGravatar Adam Chlipala <adamc@hcoop.net>2008-12-19 11:47:18 -0500
commit2c8e4cddb5f5c7a85337b8c42135c346b14de1f4 (patch)
tree1244a9d96e9fb847422bb0bc447d01e77cbe1e9e /src
parent3aac0d79c1ad2da6358cf6619c62a56ddd2ed195 (diff)
Creation of sources in server code
Diffstat (limited to 'src')
-rw-r--r--src/c/urweb.c25
-rw-r--r--src/mono_reduce.sml2
-rw-r--r--src/monoize.sml32
3 files changed, 47 insertions, 12 deletions
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 (