Mercurial > urweb
changeset 565:74800be65591
Creation of sources in server code
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Fri, 19 Dec 2008 11:47:18 -0500 |
| parents | 803b2f3bb86b |
| children | a152905c3c3b |
| files | include/urweb.h lib/basis.urs src/c/urweb.c src/mono_reduce.sml src/monoize.sml tests/reactive.ur tests/reactive.urp |
| diffstat | 7 files changed, 62 insertions(+), 15 deletions(-) [+] |
line wrap: on
line diff
--- a/include/urweb.h Fri Dec 19 10:27:58 2008 -0500 +++ b/include/urweb.h Fri Dec 19 11:47:18 2008 -0500 @@ -36,7 +36,8 @@ 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);
--- a/lib/basis.urs Fri Dec 19 10:27:58 2008 -0500 +++ b/lib/basis.urs Fri Dec 19 11:47:18 2008 -0500 @@ -80,11 +80,15 @@ -> 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 *)
--- a/src/c/urweb.c Fri Dec 19 10:27:58 2008 -0500 +++ b/src/c/urweb.c Fri Dec 19 11:47:18 2008 -0500 @@ -32,7 +32,7 @@ char **inputs; char *script, *script_front, *script_back; - int reactive_count; + int source_count; void *db; @@ -75,7 +75,7 @@ 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 @@ 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 @@ 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) {
--- a/src/mono_reduce.sml Fri Dec 19 10:27:58 2008 -0500 +++ b/src/mono_reduce.sml Fri Dec 19 11:47:18 2008 -0500 @@ -54,6 +54,7 @@ | 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 @@ | 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 _ =>
--- a/src/monoize.sml Fri Dec 19 10:27:58 2008 -0500 +++ b/src/monoize.sml Fri Dec 19 11:47:18 2008 -0500 @@ -133,6 +133,8 @@ | 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 @@ 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 @@ | _ => (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 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 @@ 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 @@ 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 @@ | _ => (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 (