diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/c/urweb.c | 25 | ||||
| -rw-r--r-- | src/mono_reduce.sml | 2 | ||||
| -rw-r--r-- | src/monoize.sml | 32 |
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 ( |