From 76c5b74abd4450a6a68084e08a7a7946e0e31fe9 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 30 Dec 2008 10:49:42 -0500 Subject: Setting a source server-side --- src/c/urweb.c | 31 +++++++++++++++++++++++++------ src/cjrize.sml | 1 + src/jscomp.sml | 14 +++++++++++++- src/mono.sml | 1 + src/mono_print.sml | 1 + src/mono_reduce.sml | 2 ++ src/mono_util.sml | 5 +++++ src/monoize.sml | 14 ++++++++------ 8 files changed, 56 insertions(+), 13 deletions(-) (limited to 'src') 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 -- cgit v1.2.3