From f60bcb83cf4d8e0a6176a1dca6e557c49e9f9375 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 21 Dec 2008 12:56:39 -0500 Subject: Trivial use of a source --- src/c/urweb.c | 111 ++++++++++++++++++++++++++++++++++------------------ src/cjrize.sml | 1 + src/jscomp.sml | 17 ++++++-- src/mono.sml | 1 + src/mono_print.sml | 5 ++- src/mono_reduce.sml | 3 +- src/mono_util.sml | 4 ++ src/monoize.sml | 10 ++++- 8 files changed, 109 insertions(+), 43 deletions(-) (limited to 'src') diff --git a/src/c/urweb.c b/src/c/urweb.c index 64cdb81e..11b99f4c 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -387,12 +387,84 @@ char *uw_Basis_get_script(uw_context ctx, uw_unit u) { } } -int uw_Basis_new_client_source(uw_context ctx, uw_unit u) { +uw_Basis_string uw_Basis_jsifyString(uw_context ctx, uw_Basis_string s) { + char *r, *s2; + + uw_check_heap(ctx, strlen(s) * 4 + 2); + + r = s2 = ctx->heap_front; + *s2++ = '"'; + + for (; *s; s++) { + char c = *s; + + switch (c) { + case '"': + strcpy(s2, "\\\""); + s2 += 2; + break; + case '\\': + strcpy(s2, "\\\\"); + s2 += 2; + break; + default: + if (isprint(c)) + *s2++ = c; + else { + sprintf(s2, "\\%3o", c); + s2 += 4; + } + } + } + + strcpy(s2, "\""); + ctx->heap_front = s2 + 1; + return r; +} + +uw_Basis_string uw_Basis_jsifyString_ws(uw_context ctx, uw_Basis_string s) { + char *r, *s2; + + uw_check_script(ctx, strlen(s) * 4 + 2); + + r = s2 = ctx->script_front; + *s2++ = '"'; + + for (; *s; s++) { + char c = *s; + + switch (c) { + case '"': + strcpy(s2, "\\\""); + s2 += 2; + break; + case '\\': + strcpy(s2, "\\\\"); + s2 += 2; + break; + default: + if (isprint(c)) + *s2++ = c; + else { + sprintf(s2, "\\%3o", c); + s2 += 4; + } + } + } + + strcpy(s2, "\""); + ctx->script_front = s2 + 1; + return r; +} + +int uw_Basis_new_client_source(uw_context ctx, uw_Basis_string s) { size_t len; uw_check_script(ctx, 8 + INTS_MAX); - sprintf(ctx->script_front, "var e%d=0\n%n", ctx->source_count, &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, ");"); return ctx->source_count++; } @@ -1056,41 +1128,6 @@ char *uw_Basis_ensqlBool(uw_Basis_bool b) { return (char *)&true; } -uw_Basis_string uw_Basis_jsifyString(uw_context ctx, uw_Basis_string s) { - char *r, *s2; - - uw_check_heap(ctx, strlen(s) * 4 + 2); - - r = s2 = ctx->heap_front; - *s2++ = '"'; - - for (; *s; s++) { - char c = *s; - - switch (c) { - case '"': - strcpy(s2, "\\\""); - s2 += 2; - break; - case '\\': - strcpy(s2, "\\\\"); - s2 += 2; - break; - default: - if (isprint(c)) - *s2++ = c; - else { - sprintf(s2, "\\%3o", c); - s2 += 4; - } - } - } - - strcpy(s2, "\""); - ctx->heap_front = s2 + 1; - return r; -} - uw_Basis_string uw_Basis_intToString(uw_context ctx, uw_Basis_int n) { int len; char *r; diff --git a/src/cjrize.sml b/src/cjrize.sml index a46c725e..a9c51826 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -424,6 +424,7 @@ fun cifyExp (eAll as (e, loc), sm) = | L.EJavaScript _ => raise Fail "Cjrize: EJavaScript remains" | L.ESignalReturn _ => raise Fail "Cjrize: ESignalReturn remains" | L.ESignalBind _ => raise Fail "Cjrize: ESignalBind remains" + | L.ESignalSource _ => raise Fail "Cjrize: ESignalSource remains" fun cifyDecl ((d, loc), sm) = case d of diff --git a/src/jscomp.sml b/src/jscomp.sml index c38056e8..f7ef6927 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -34,7 +34,8 @@ structure E = MonoEnv structure U = MonoUtil val funcs = [(("Basis", "alert"), "alert"), - (("Basis", "htmlifyString"), "escape")] + (("Basis", "htmlifyString"), "escape"), + (("Basis", "new_client_source"), "sc")] structure FM = BinaryMapFn(struct type ord_key = string * string @@ -85,6 +86,7 @@ fun varDepth (e, _) = | EJavaScript _ => 0 | ESignalReturn e => varDepth e | ESignalBind (e1, e2) => Int.max (varDepth e1, varDepth e2) + | ESignalSource e => varDepth e fun strcat loc es = case es of @@ -168,7 +170,7 @@ fun jsExp mode outer = | EFfi k => let val name = case ffi k of - NONE => (EM.errorAt loc "Unsupported FFI identifier in JavaScript"; + NONE => (EM.errorAt loc ("Unsupported FFI identifier " ^ #2 k ^ " in JavaScript"); "ERROR") | SOME s => s in @@ -177,7 +179,7 @@ fun jsExp mode outer = | EFfiApp (m, x, args) => let val name = case ffi (m, x) of - NONE => (EM.errorAt loc "Unsupported FFI function in JavaScript"; + NONE => (EM.errorAt loc ("Unsupported FFI function " ^ x ^ " in JavaScript"); "ERROR") | SOME s => s in @@ -366,6 +368,15 @@ fun jsExp mode outer = str ")"], st) end + | ESignalSource e => + let + val (e, st) = jsE inner (e, st) + in + (strcat [str "ss(", + e, + str ")"], + st) + end end in jsE diff --git a/src/mono.sml b/src/mono.sml index 54b77550..ae9a06c7 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -106,6 +106,7 @@ datatype exp' = | ESignalReturn of exp | ESignalBind of exp * exp + | ESignalSource of exp withtype exp = exp' located diff --git a/src/mono_print.sml b/src/mono_print.sml index 608fe269..b3c0a568 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -285,12 +285,15 @@ fun p_exp' par env (e, _) = | ESignalReturn e => box [string "Return(", p_exp env e, string ")"] - | ESignalBind (e1, e2) => box [string "Return(", + | ESignalBind (e1, e2) => box [string "Bind(", p_exp env e1, string ",", space, p_exp env e2, string ")"] + | ESignalSource e => box [string "Source(", + p_exp env e, + string ")"] and p_exp env = p_exp' false env diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index 841e034e..a6777db5 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -78,6 +78,7 @@ fun impure (e, _) = | EJavaScript (_, e) => impure e | ESignalReturn e => impure e | ESignalBind (e1, e2) => impure e1 orelse impure e2 + | ESignalSource e => impure e val liftExpInExp = Monoize.liftExpInExp @@ -335,7 +336,7 @@ fun reduce file = | EJavaScript (_, e) => summarize d e | ESignalReturn e => summarize d e | ESignalBind (e1, e2) => summarize d e1 @ summarize d e2 - + | ESignalSource e => summarize d e fun exp env e = let diff --git a/src/mono_util.sml b/src/mono_util.sml index a85443d7..b14e3ac9 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -334,6 +334,10 @@ fun mapfoldB {typ = fc, exp = fe, bind} = S.map2 (mfe ctx e2, fn e2' => (ESignalBind (e1', e2'), loc))) + | ESignalSource e => + S.map2 (mfe ctx e, + fn e' => + (ESignalSource e', loc)) in mfe end diff --git a/src/monoize.sml b/src/monoize.sml index 30bd5daa..d3d20e7c 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -975,7 +975,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = 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)), + (L'.EFfiApp ("Basis", "new_client_source", [(L'.ERel 1, loc)]), loc)), loc)), loc), fm) end @@ -1003,6 +1003,14 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.ESignalBind ((L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc), fm) end + | L.ECApp ((L.EFfi ("Basis", "signal"), _), t) => + let + val t = monoType env t + in + ((L'.EAbs ("x", (L'.TFfi ("Basis", "int"), loc), (L'.TSignal t, loc), + (L'.ESignalSource (L'.ERel 0, loc), loc)), loc), + fm) + end | L.ECApp ((L.EFfi ("Basis", "getCookie"), _), t) => let -- cgit v1.2.3