From 9f6397d0f801f6e020aa6123f14ddc44e11deee7 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 6 Nov 2008 12:08:41 -0500 Subject: Reading cookies works --- src/mono.sml | 2 ++ 1 file changed, 2 insertions(+) (limited to 'src/mono.sml') diff --git a/src/mono.sml b/src/mono.sml index b7ac6346..f465d2bd 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -94,6 +94,8 @@ datatype exp' = | EDml of exp | ENextval of exp + | EUnurlify of exp * typ + withtype exp = exp' located -- cgit v1.2.3 From e478b4d432d65b33613a601f71204fc0c656c3db Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Fri, 19 Dec 2008 12:38:11 -0500 Subject: Displayed an alert dialog --- include/urweb.h | 2 ++ lib/basis.urs | 7 ++++++- src/c/urweb.c | 35 +++++++++++++++++++++++++++++++++++ src/cjrize.sml | 2 ++ src/mono.sml | 2 ++ src/mono_opt.sml | 5 +++++ src/mono_print.sml | 3 +++ src/mono_reduce.sml | 2 ++ src/mono_util.sml | 4 ++++ src/monoize.sml | 13 +++++++++++++ tests/alert.ur | 3 +++ tests/alert.urp | 3 +++ 12 files changed, 80 insertions(+), 1 deletion(-) create mode 100644 tests/alert.ur create mode 100644 tests/alert.urp (limited to 'src/mono.sml') diff --git a/include/urweb.h b/include/urweb.h index 3d7b967c..647f153a 100644 --- a/include/urweb.h +++ b/include/urweb.h @@ -94,6 +94,8 @@ uw_Basis_string uw_Basis_sqlifyTimeN(uw_context, uw_Basis_time*); char *uw_Basis_ensqlBool(uw_Basis_bool); +char *uw_Basis_jsifyString(uw_context, uw_Basis_string); + uw_Basis_string uw_Basis_intToString(uw_context, uw_Basis_int); uw_Basis_string uw_Basis_floatToString(uw_context, uw_Basis_float); uw_Basis_string uw_Basis_boolToString(uw_context, uw_Basis_bool); diff --git a/lib/basis.urs b/lib/basis.urs index ffba2b37..ac4c4832 100644 --- a/lib/basis.urs +++ b/lib/basis.urs @@ -100,6 +100,11 @@ val getCookie : t ::: Type -> http_cookie t -> transaction (option t) val setCookie : t ::: Type -> http_cookie t -> t -> transaction unit +(** JavaScript-y gadgets *) + +val alert : string -> transaction unit + + (** SQL *) con sql_table :: {Type} -> Type @@ -403,7 +408,7 @@ val ul : bodyTag [] val hr : bodyTag [] -val a : bodyTag [Link = transaction page] +val a : bodyTag [Link = transaction page, Onclick = transaction unit] val form : ctx ::: {Unit} -> bind ::: {Type} -> fn [[Body] ~ ctx] => diff --git a/src/c/urweb.c b/src/c/urweb.c index 7a9b3e79..64cdb81e 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -1056,6 +1056,41 @@ 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 6c34923b..1152b0ef 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -420,6 +420,8 @@ fun cifyExp (eAll as (e, loc), sm) = ((L'.EUnurlify (e, t), loc), sm) end + | L.EJavaScript _ => raise Fail "EJavaScript remains" + fun cifyDecl ((d, loc), sm) = case d of L.DDatatype (x, n, xncs) => diff --git a/src/mono.sml b/src/mono.sml index f465d2bd..187b1853 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -96,6 +96,8 @@ datatype exp' = | EUnurlify of exp * typ + | EJavaScript of exp + withtype exp = exp' located diff --git a/src/mono_opt.sml b/src/mono_opt.sml index 6c0e6e21..7f83c003 100644 --- a/src/mono_opt.sml +++ b/src/mono_opt.sml @@ -360,6 +360,11 @@ fun exp e = | EWrite (EPrim (Prim.String ""), loc) => ERecord [] + | EJavaScript (EAbs (_, (TRecord [], _), _, (EFfiApp ("Basis", "alert", [s]), _)), loc) => + EStrcat ((EPrim (Prim.String "alert("), loc), + (EStrcat ((EFfiApp ("Basis", "jsifyString", [s]), loc), + (EPrim (Prim.String ")"), loc)), loc)) + | _ => e and optExp e = #1 (U.Exp.map {typ = typ, exp = exp} e) diff --git a/src/mono_print.sml b/src/mono_print.sml index 8d91d048..7b675438 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -275,6 +275,9 @@ fun p_exp' par env (e, _) = | EUnurlify (e, _) => box [string "unurlify(", p_exp env e, string ")"] + | EJavaScript e => box [string "JavaScript(", + 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 9cf6d8e8..040414f3 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -75,6 +75,7 @@ fun impure (e, _) = | ELet (_, _, e1, e2) => impure e1 orelse impure e2 | EClosure (_, es) => List.exists impure es + | EJavaScript e => impure e val liftExpInExp = Monoize.liftExpInExp @@ -329,6 +330,7 @@ fun reduce file = | EDml e => summarize d e @ [WriteDb] | ENextval e => summarize d e @ [WriteDb] | EUnurlify (e, _) => summarize d e + | EJavaScript e => summarize d e fun exp env e = diff --git a/src/mono_util.sml b/src/mono_util.sml index 2b2476e7..18b5c948 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -311,6 +311,10 @@ fun mapfoldB {typ = fc, exp = fe, bind} = S.map2 (mft t, fn t' => (EUnurlify (e', t'), loc))) + | EJavaScript e => + S.map2 (mfe ctx e, + fn e' => + (EJavaScript e', loc)) in mfe end diff --git a/src/monoize.sml b/src/monoize.sml index e23d4f80..e92a1c8a 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -1744,6 +1744,19 @@ fun monoExp (env, st, fm) (all as (e, loc)) = result = (L'.TFfi ("Basis", "string"), loc)}), loc), fm) end + | (L'.TFun _, _) => + let + val s' = " " ^ lowercaseFirst x ^ "='" + in + ((L'.EStrcat (s, + (L'.EStrcat ( + (L'.EPrim (Prim.String s'), loc), + (L'.EStrcat ( + (L'.EJavaScript e, loc), + (L'.EPrim (Prim.String "'"), loc)), loc)), + loc)), loc), + fm) + end | _ => let val fooify = diff --git a/tests/alert.ur b/tests/alert.ur new file mode 100644 index 00000000..7b2eaacf --- /dev/null +++ b/tests/alert.ur @@ -0,0 +1,3 @@ +fun main () : transaction page = return + Click Me! + diff --git a/tests/alert.urp b/tests/alert.urp new file mode 100644 index 00000000..3976e9b0 --- /dev/null +++ b/tests/alert.urp @@ -0,0 +1,3 @@ +debug + +alert -- cgit v1.2.3 From 80be553bea33f3d9cb19f399f64eed36017048a3 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 20 Dec 2008 15:46:48 -0500 Subject: Initial support --- lib/basis.urs | 5 +++- src/cjrize.sml | 4 +++- src/jscomp.sml | 66 +++++++++++++++++++++++++++++++++++++++-------------- src/mono.sml | 9 +++++++- src/mono_print.sml | 13 ++++++++--- src/mono_reduce.sml | 7 ++++-- src/mono_util.sml | 16 +++++++++++-- src/monoize.sml | 33 ++++++++++++++++++++++++++- tests/sreturn.ur | 5 ++++ tests/sreturn.urp | 3 +++ 10 files changed, 133 insertions(+), 28 deletions(-) create mode 100644 tests/sreturn.ur create mode 100644 tests/sreturn.urp (limited to 'src/mono.sml') diff --git a/lib/basis.urs b/lib/basis.urs index ac4c4832..a61bf3ce 100644 --- a/lib/basis.urs +++ b/lib/basis.urs @@ -376,6 +376,9 @@ con form = [Body, Form] con tabl = [Body, Table] con tr = [Body, Tr] +val dyn : ctx ::: {Unit} -> use ::: {Type} -> bind ::: {Type} -> unit + -> tag [Signal = signal (xml ctx use bind)] ctx [] use bind + val head : unit -> tag [] html head [] [] val title : unit -> tag [] head [] [] [] @@ -433,7 +436,7 @@ con select = [Select] val select : formTag string select [] val option : unit -> tag [Value = string, Selected = bool] select [] [] [] -val submit : ctx ::: {Unit} -> use ::: {Type} +val submit : ctx ::: {Unit} -> use ::: {Type} -> fn [[Form] ~ ctx] => unit -> tag [Value = string, Action = $use -> transaction page] diff --git a/src/cjrize.sml b/src/cjrize.sml index 1152b0ef..f3c5e5a7 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -120,6 +120,7 @@ fun cifyTyp x = in ((L'.TOption t, loc), sm) end + | L.TSignal _ => raise Fail "Cjrize: TSignal remains" in cify IM.empty x end @@ -420,7 +421,8 @@ fun cifyExp (eAll as (e, loc), sm) = ((L'.EUnurlify (e, t), loc), sm) end - | L.EJavaScript _ => raise Fail "EJavaScript remains" + | L.EJavaScript _ => raise Fail "Cjrize: EJavaScript remains" + | L.ESignalReturn _ => raise Fail "Cjrize: ESignalReturn remains" fun cifyDecl ((d, loc), sm) = case d of diff --git a/src/jscomp.sml b/src/jscomp.sml index 0dd7882a..b0842c6b 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -69,8 +69,15 @@ fun varDepth (e, _) = | ENextval _ => 0 | EUnurlify _ => 0 | EJavaScript _ => 0 + | ESignalReturn e => varDepth e -fun jsExp inAttr outer = +fun strcat loc es = + case es of + [] => (EPrim (Prim.String ""), loc) + | [x] => x + | x :: es' => (EStrcat (x, strcat loc es'), loc) + +fun jsExp mode outer = let val len = length outer @@ -85,11 +92,7 @@ fun jsExp inAttr outer = PConVar n => str (Int.toString n) | PConFfi {con, ...} => str ("\"_" ^ con ^ "\"") - fun strcat es = - case es of - [] => (EPrim (Prim.String ""), loc) - | [x] => x - | x :: es' => (EStrcat (x, strcat es'), loc) + fun isNullable (t, _) = case t of @@ -99,17 +102,19 @@ fun jsExp inAttr outer = fun unsupported s = (EM.errorAt loc (s ^ " in code to be compiled to JavaScript"); (str "ERROR", st)) + + val strcat = strcat loc in case #1 e of EPrim (Prim.String s) => (str ("\"" ^ String.translate (fn #"'" => - if inAttr then + if mode = Attribute then "\\047" else "'" | #"<" => - if inAttr then + if mode = Script then "<" else "\\074" @@ -274,7 +279,14 @@ fun jsExp inAttr outer = st) end - | EWrite _ => unsupported "EWrite" + | EWrite e => + let + val (e, st) = jsE inner (e, st) + in + (strcat [str "document.write(", + e, + str ")"], st) + end | ESeq (e1, e2) => let @@ -301,6 +313,15 @@ fun jsExp inAttr outer = | ENextval _ => unsupported "Nextval" | EUnurlify _ => unsupported "EUnurlify" | EJavaScript _ => unsupported "Nested JavaScript" + | ESignalReturn e => + let + val (e, st) = jsE inner (e, st) + in + (strcat [(*str "sreturn(",*) + e(*, + str ")"*)], + st) + end end in jsE @@ -309,14 +330,25 @@ fun jsExp inAttr outer = val decl : state -> decl -> decl * state = U.Decl.foldMapB {typ = fn x => x, exp = fn (env, e, st) => - case e of - EJavaScript (EAbs (_, t, _, e), _) => - let - val (e, st) = jsExp true (t :: env) 0 (e, st) - in - (#1 e, st) - end - | _ => (e, st), + let + fun doCode m env e = + let + val len = length env + fun str s = (EPrim (Prim.String s), #2 e) + + val locals = List.tabulate + (varDepth e, + fn i => str ("var uwr" ^ Int.toString (len + i) ^ ";")) + val (e, st) = jsExp m env 0 (e, st) + in + (#1 (strcat (#2 e) (locals @ [e])), st) + end + in + case e of + EJavaScript (m, (EAbs (_, t, _, e), _)) => doCode m (t :: env) e + | EJavaScript (m, e) => doCode m env e + | _ => (e, st) + end, decl = fn (_, e, st) => (e, st), bind = fn (env, U.Decl.RelE (_, t)) => t :: env | (env, _) => env} diff --git a/src/mono.sml b/src/mono.sml index 187b1853..c6e0ae8a 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 + | TSignal of typ withtype typ = typ' located @@ -55,6 +56,11 @@ datatype pat' = withtype pat = pat' located +datatype javascript_mode = + Attribute + | Script + | File + datatype exp' = EPrim of Prim.t | ERel of int @@ -96,8 +102,9 @@ datatype exp' = | EUnurlify of exp * typ - | EJavaScript of exp + | EJavaScript of javascript_mode * exp + | ESignalReturn of exp withtype exp = exp' located diff --git a/src/mono_print.sml b/src/mono_print.sml index 7b675438..89b6c35b 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -65,6 +65,9 @@ fun p_typ' par env (t, _) = | TOption t => box [string "option(", p_typ env t, string ")"] + | TSignal t => box [string "signal(", + p_typ env t, + string ")"] and p_typ env = p_typ' false env @@ -275,9 +278,13 @@ fun p_exp' par env (e, _) = | EUnurlify (e, _) => box [string "unurlify(", p_exp env e, string ")"] - | EJavaScript e => box [string "JavaScript(", - p_exp env e, - string ")"] + | EJavaScript (_, e) => box [string "JavaScript(", + p_exp env e, + string ")"] + + | ESignalReturn e => box [string "Return(", + 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 040414f3..e1da02c9 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -75,7 +75,8 @@ fun impure (e, _) = | ELet (_, _, e1, e2) => impure e1 orelse impure e2 | EClosure (_, es) => List.exists impure es - | EJavaScript e => impure e + | EJavaScript (_, e) => impure e + | ESignalReturn e => impure e val liftExpInExp = Monoize.liftExpInExp @@ -330,7 +331,8 @@ fun reduce file = | EDml e => summarize d e @ [WriteDb] | ENextval e => summarize d e @ [WriteDb] | EUnurlify (e, _) => summarize d e - | EJavaScript e => summarize d e + | EJavaScript (_, e) => summarize d e + | ESignalReturn e => summarize d e fun exp env e = @@ -421,6 +423,7 @@ fun reduce file = fun trySub () = case t of (TFfi ("Basis", "string"), _) => doSub () + | (TSignal _, _) => e | _ => case e' of (ECase _, _) => e diff --git a/src/mono_util.sml b/src/mono_util.sml index ebc30984..553f802e 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) + | (TSignal t1, TSignal t2) => compare (t1, t2) | (TFun _, _) => LESS | (_, TFun _) => GREATER @@ -64,6 +65,9 @@ fun compare ((t1, _), (t2, _)) = | (TFfi _, _) => LESS | (_, TFfi _) => GREATER + | (TOption _, _) => LESS + | (_, TOption _) => GREATER + and compareFields ((x1, t1), (x2, t2)) = join (String.compare (x1, x2), fn () => compare (t1, t2)) @@ -96,6 +100,10 @@ fun mapfold fc = S.map2 (mft t, fn t' => (TOption t, loc)) + | TSignal t => + S.map2 (mft t, + fn t' => + (TSignal t, loc)) in mft end @@ -311,10 +319,14 @@ fun mapfoldB {typ = fc, exp = fe, bind} = S.map2 (mft t, fn t' => (EUnurlify (e', t'), loc))) - | EJavaScript e => + | EJavaScript (m, e) => + S.map2 (mfe ctx e, + fn e' => + (EJavaScript (m, e'), loc)) + | ESignalReturn e => S.map2 (mfe ctx e, fn e' => - (EJavaScript e', loc)) + (ESignalReturn e', loc)) in mfe end diff --git a/src/monoize.sml b/src/monoize.sml index e92a1c8a..1b7b467d 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -135,6 +135,8 @@ fun monoType env = (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", "signal"), _), t) => + (L'.TSignal (mt env dtmap t), loc) | L.CApp ((L.CFfi ("Basis", "http_cookie"), _), _) => (L'.TFfi ("Basis", "string"), loc) | L.CApp ((L.CFfi ("Basis", "sql_table"), _), _) => @@ -978,6 +980,16 @@ fun monoExp (env, st, fm) (all as (e, loc)) = fm) end + | L.EApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "return"), _), _), _), t), _), + (L.EFfi ("Basis", "signal_monad"), _)) => + let + val t = monoType env t + in + ((L'.EAbs ("x", t, (L'.TSignal t, loc), + (L'.ESignalReturn (L'.ERel 0, loc), loc)), loc), + fm) + end + | L.ECApp ((L.EFfi ("Basis", "getCookie"), _), t) => let val s = (L'.TFfi ("Basis", "string"), loc) @@ -1752,7 +1764,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.EStrcat ( (L'.EPrim (Prim.String s'), loc), (L'.EStrcat ( - (L'.EJavaScript e, loc), + (L'.EJavaScript (L'.Attribute, e), loc), (L'.EPrim (Prim.String "'"), loc)), loc)), loc)), loc), fm) @@ -1833,6 +1845,25 @@ fun monoExp (env, st, fm) (all as (e, loc)) = case tag of "body" => normal ("body", NONE, SOME (L'.EFfiApp ("Basis", "get_script", [(L'.ERecord [], loc)]), loc)) + + | "dyn" => + (case #1 attrs of + (*L'.ERecord [("Signal", (L'.ESignalReturn e, _), _)] => (e, fm) + | L'.ERecord [("Signal", (L'.EApp ((L'.EAbs (_, _, _, (L'.ESignalReturn (L'.ERel 0, _), _)), _), + e), _), _)] => (e, fm) *) + + L'.ERecord [("Signal", e, _)] => + ((L'.EStrcat + ((L'.EPrim (Prim.String ""), loc)), loc)), loc), + fm) + | _ => raise Fail "Monoize: Bad dyn attributes") | "submit" => normal ("input type=\"submit\"", NONE, NONE) diff --git a/tests/sreturn.ur b/tests/sreturn.ur new file mode 100644 index 00000000..62db377d --- /dev/null +++ b/tests/sreturn.ur @@ -0,0 +1,5 @@ +fun main () : transaction page = return +

Before

+

Hi!}/>

+

After

+ diff --git a/tests/sreturn.urp b/tests/sreturn.urp new file mode 100644 index 00000000..5591aa5e --- /dev/null +++ b/tests/sreturn.urp @@ -0,0 +1,3 @@ +debug + +sreturn -- cgit v1.2.3 From ec745f90fc97e10948dc32ec4f44aabf5c6908db Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 20 Dec 2008 16:19:26 -0500 Subject: Successfully generated a page element from a signal --- Makefile.in | 3 +++ jslib/urweb.js | 1 + src/c/driver.c | 5 ----- src/cjr.sml | 2 ++ src/cjr_env.sml | 1 + src/cjr_print.sml | 20 ++++++++++++++++++++ src/cjrize.sml | 1 + src/config.sig | 1 + src/config.sml.in | 2 ++ src/jscomp.sml | 18 +++++++++++++----- src/mono.sml | 3 +++ src/mono_env.sml | 1 + src/mono_print.sml | 4 ++++ src/mono_shake.sml | 6 ++++-- src/mono_util.sml | 6 +++++- src/monoize.sml | 4 +++- src/prepare.sml | 1 + 17 files changed, 65 insertions(+), 14 deletions(-) create mode 100644 jslib/urweb.js (limited to 'src/mono.sml') diff --git a/Makefile.in b/Makefile.in index 57a083bd..ed65ceea 100644 --- a/Makefile.in +++ b/Makefile.in @@ -5,6 +5,7 @@ SITELISP := @SITELISP@ LIB_UR := $(LIB)/ur LIB_C := $(LIB)/c +LIB_JS := $(LIB)/js all: smlnj mlton c @@ -70,6 +71,8 @@ install: cp lib/*.ur $(LIB_UR)/ mkdir -p $(LIB_C) cp clib/*.o $(LIB_C)/ + mkdir -p $(LIB_JS) + cp jslib/*.js $(LIB_JS)/ mkdir -p $(INCLUDE) cp include/*.h $(INCLUDE)/ mkdir -p $(SITELISP) diff --git a/jslib/urweb.js b/jslib/urweb.js new file mode 100644 index 00000000..32912e4c --- /dev/null +++ b/jslib/urweb.js @@ -0,0 +1 @@ +function sreturn(v) { return {v : v} } diff --git a/src/c/driver.c b/src/c/driver.c index a25cd743..34e57a6d 100644 --- a/src/c/driver.c +++ b/src/c/driver.c @@ -193,8 +193,6 @@ static void *worker(void *data) { uw_set_headers(ctx, headers); while (1) { - uw_write(ctx, ""); - if (uw_db_begin(ctx)) { printf("Error running SQL BEGIN\n"); if (retries_left) @@ -211,13 +209,10 @@ static void *worker(void *data) { } uw_write_header(ctx, "HTTP/1.1 200 OK\r\n"); - uw_write_header(ctx, "Content-type: text/html\r\n"); strcpy(path_copy, path); fk = uw_begin(ctx, path_copy); if (fk == SUCCESS) { - uw_write(ctx, ""); - if (uw_db_commit(ctx)) { fk = FATAL; diff --git a/src/cjr.sml b/src/cjr.sml index 84aea54e..43a29a6c 100644 --- a/src/cjr.sml +++ b/src/cjr.sml @@ -109,6 +109,8 @@ datatype decl' = | DDatabase of string | DPreparedStatements of (string * int) list + | DJavaScript of string + withtype decl = decl' located type file = decl list * (Core.export_kind * string * int * typ list) list diff --git a/src/cjr_env.sml b/src/cjr_env.sml index 49e86140..9921ee48 100644 --- a/src/cjr_env.sml +++ b/src/cjr_env.sml @@ -166,6 +166,7 @@ fun declBinds env (d, loc) = | DSequence _ => env | DDatabase _ => env | DPreparedStatements _ => env + | DJavaScript _ => env end diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 8c3c3d86..06f9f5ca 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -1800,6 +1800,10 @@ fun p_decl env (dAll as (d, _) : decl) = string "}"] + | DJavaScript s => box [string "static char jslib[] = \"", + string (String.toString s), + string "\";"] + datatype 'a search = Found of 'a | NotFound @@ -2048,6 +2052,10 @@ fun p_file env (ds, ps) = newline, string "if (*request == '/') ++request;", newline, + string "uw_write_header(ctx, \"Content-type: text/html\\r\\n\");", + newline, + string "uw_write(ctx, \"\");", + newline, box [string "{", newline, box (ListUtil.mapi (fn (i, t) => box [p_typ env t, @@ -2070,6 +2078,8 @@ fun p_file env (ds, ps) = inputsVar, string ", uw_unit_v);", newline, + string "uw_write(ctx, \"\");", + newline, string "return;", newline, string "}", @@ -2374,6 +2384,16 @@ fun p_file env (ds, ps) = newline, string "void uw_handle(uw_context ctx, char *request) {", newline, + string "if (!strcmp(request, \"/app.js\")) {", + newline, + box [string "uw_write_header(ctx, \"Content-type: text/javascript\\r\\n\");", + newline, + string "uw_write(ctx, jslib);", + newline, + string "return;", + newline], + string "}", + newline, p_list_sep newline (fn x => x) pds', newline, string "uw_error(ctx, FATAL, \"Unknown page\");", diff --git a/src/cjrize.sml b/src/cjrize.sml index f3c5e5a7..78513ef7 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -528,6 +528,7 @@ fun cifyDecl ((d, loc), sm) = | L.DSequence s => (SOME (L'.DSequence s, loc), NONE, sm) | L.DDatabase s => (SOME (L'.DDatabase s, loc), NONE, sm) + | L.DJavaScript s => (SOME (L'.DJavaScript s, loc), NONE, sm) fun cjrize ds = let diff --git a/src/config.sig b/src/config.sig index 6075482e..90fb72e7 100644 --- a/src/config.sig +++ b/src/config.sig @@ -6,6 +6,7 @@ signature CONFIG = sig val libUr : string val libC : string + val libJs : string val gccArgs : string end diff --git a/src/config.sml.in b/src/config.sml.in index 9e53986b..c7d231d5 100644 --- a/src/config.sml.in +++ b/src/config.sml.in @@ -9,6 +9,8 @@ val libUr = OS.Path.joinDirFile {dir = lib, file = "ur"} val libC = OS.Path.joinDirFile {dir = lib, file = "c"} +val libJs = OS.Path.joinDirFile {dir = lib, + file = "js"} val gccArgs = "@GCCARGS@" diff --git a/src/jscomp.sml b/src/jscomp.sml index b0842c6b..95c18016 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -285,7 +285,7 @@ fun jsExp mode outer = in (strcat [str "document.write(", e, - str ")"], st) + str ".v)"], st) end | ESeq (e1, e2) => @@ -317,9 +317,9 @@ fun jsExp mode outer = let val (e, st) = jsE inner (e, st) in - (strcat [(*str "sreturn(",*) - e(*, - str ")"*)], + (strcat [str "sreturn(", + e, + str ")"], st) end end @@ -369,8 +369,16 @@ fun process file = {decls = [], script = ""} file + + val inf = TextIO.openIn (OS.Path.joinDirFile {dir = Config.libJs, file = "urweb.js"}) + fun lines acc = + case TextIO.inputLine inf of + NONE => String.concat (rev acc) + | SOME line => lines (line :: acc) + val lines = lines [] in - ds + TextIO.closeIn inf; + (DJavaScript lines, ErrorMsg.dummySpan) :: ds end end diff --git a/src/mono.sml b/src/mono.sml index c6e0ae8a..1a7fde00 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -118,6 +118,9 @@ datatype decl' = | DSequence of string | DDatabase of string + | DJavaScript of string + + withtype decl = decl' located type file = decl list diff --git a/src/mono_env.sml b/src/mono_env.sml index cce4a4c4..248567de 100644 --- a/src/mono_env.sml +++ b/src/mono_env.sml @@ -110,6 +110,7 @@ fun declBinds env (d, loc) = | DTable _ => env | DSequence _ => env | DDatabase _ => env + | DJavaScript _ => env fun patBinds env (p, loc) = case p of diff --git a/src/mono_print.sml b/src/mono_print.sml index 89b6c35b..e44bb74c 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -379,6 +379,10 @@ fun p_decl env (dAll as (d, _) : decl) = | DDatabase s => box [string "database", space, string s] + | DJavaScript s => box [string "JavaScript(", + string s, + string ")"] + fun p_file env file = let diff --git a/src/mono_shake.sml b/src/mono_shake.sml index 6714718a..34bd98be 100644 --- a/src/mono_shake.sml +++ b/src/mono_shake.sml @@ -56,7 +56,8 @@ fun shake file = | ((DExport _, _), acc) => acc | ((DTable _, _), acc) => acc | ((DSequence _, _), acc) => acc - | ((DDatabase _, _), acc) => acc) + | ((DDatabase _, _), acc) => acc + | ((DJavaScript _, _), acc) => acc) (IM.empty, IM.empty) file fun typ (c, s) = @@ -112,7 +113,8 @@ fun shake file = | (DExport _, _) => true | (DTable _, _) => true | (DSequence _, _) => true - | (DDatabase _, _) => true) file + | (DDatabase _, _) => true + | (DJavaScript _, _) => true) file end end diff --git a/src/mono_util.sml b/src/mono_util.sml index 553f802e..9788a551 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -323,6 +323,7 @@ fun mapfoldB {typ = fc, exp = fe, bind} = S.map2 (mfe ctx e, fn e' => (EJavaScript (m, e'), loc)) + | ESignalReturn e => S.map2 (mfe ctx e, fn e' => @@ -421,6 +422,7 @@ fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} = | DTable _ => S.return2 dAll | DSequence _ => S.return2 dAll | DDatabase _ => S.return2 dAll + | DJavaScript _ => S.return2 dAll and mfvi ctx (x, n, t, e, s) = S.bind2 (mft t, @@ -501,6 +503,7 @@ fun mapfoldB (all as {bind, ...}) = | DTable _ => ctx | DSequence _ => ctx | DDatabase _ => ctx + | DJavaScript _ => ctx in S.map2 (mff ctx' ds', fn ds' => @@ -548,7 +551,8 @@ val maxName = foldl (fn ((d, _) : decl, count) => | DExport _ => count | DTable _ => count | DSequence _ => count - | DDatabase _ => count) 0 + | DDatabase _ => count + | DJavaScript _ => count) 0 end diff --git a/src/monoize.sml b/src/monoize.sml index 1b7b467d..a0a0df30 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -1844,7 +1844,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) = in case tag of "body" => normal ("body", NONE, - SOME (L'.EFfiApp ("Basis", "get_script", [(L'.ERecord [], loc)]), loc)) + SOME (L'.EStrcat ((L'.EPrim (Prim.String ""), loc), + (L'.EFfiApp ("Basis", "get_script", [(L'.ERecord [], loc)]), + loc)), loc)) | "dyn" => (case #1 attrs of diff --git a/src/prepare.sml b/src/prepare.sml index 708bcade..110f6f9a 100644 --- a/src/prepare.sml +++ b/src/prepare.sml @@ -258,6 +258,7 @@ fun prepDecl (d as (_, loc), sns) = | DSequence _ => (d, sns) | DDatabase _ => (d, sns) | DPreparedStatements _ => (d, sns) + | DJavaScript _ => (d, sns) fun prepare (ds, ps) = let -- cgit v1.2.3 From d5c3faacb1c3114fe6802973a62528cda8be8ac7 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 21 Dec 2008 12:30:57 -0500 Subject: Handling singnal bind --- jslib/urweb.js | 3 +- src/cjrize.sml | 1 + src/compiler.sig | 3 +- src/compiler.sml | 8 +++-- src/jscomp.sml | 90 +++++++++++++++++++++++++++++++++++++++-------------- src/mono.sml | 1 + src/mono_opt.sml | 3 ++ src/mono_print.sml | 6 ++++ src/mono_reduce.sml | 5 +++ src/mono_util.sml | 6 ++++ src/monoize.sml | 18 +++++++++-- tests/sbind.ur | 5 +++ tests/sbind.urp | 3 ++ 13 files changed, 122 insertions(+), 30 deletions(-) create mode 100644 tests/sbind.ur create mode 100644 tests/sbind.urp (limited to 'src/mono.sml') diff --git a/jslib/urweb.js b/jslib/urweb.js index b7a1af91..f552b26b 100644 --- a/jslib/urweb.js +++ b/jslib/urweb.js @@ -1,4 +1,5 @@ -function sreturn(v) { return {v : v} } +function sr(v) { return {v : v} } +function sb(x,y) { return {v : y(x.v).v} } function dyn(s) { var x = document.createElement("span"); diff --git a/src/cjrize.sml b/src/cjrize.sml index 78513ef7..a46c725e 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -423,6 +423,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" fun cifyDecl ((d, loc), sm) = case d of diff --git a/src/compiler.sig b/src/compiler.sig index 1f1f4973..c156b268 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -102,8 +102,9 @@ signature COMPILER = sig val toUntangle : (string, Mono.file) transform val toMono_reduce : (string, Mono.file) transform val toMono_shake : (string, Mono.file) transform - val toJscomp : (string, Mono.file) transform val toMono_opt2 : (string, Mono.file) transform + val toJscomp : (string, Mono.file) transform + val toMono_opt3 : (string, Mono.file) transform val toFuse : (string, Mono.file) transform val toUntangle2 : (string, Mono.file) transform val toMono_shake2 : (string, Mono.file) transform diff --git a/src/compiler.sml b/src/compiler.sml index ecee1065..6d499283 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -511,21 +511,23 @@ val mono_shake = { val toMono_shake = transform mono_shake "mono_shake1" o toMono_reduce +val toMono_opt2 = transform mono_opt "mono_opt2" o toMono_shake + val jscomp = { func = JsComp.process, print = MonoPrint.p_file MonoEnv.empty } -val toJscomp = transform jscomp "jscomp" o toMono_reduce +val toJscomp = transform jscomp "jscomp" o toMono_opt2 -val toMono_opt2 = transform mono_opt "mono_opt2" o toJscomp +val toMono_opt3 = transform mono_opt "mono_opt3" o toJscomp val fuse = { func = Fuse.fuse, print = MonoPrint.p_file MonoEnv.empty } -val toFuse = transform fuse "fuse" o toMono_opt2 +val toFuse = transform fuse "fuse" o toMono_opt3 val toUntangle2 = transform untangle "untangle2" o toFuse diff --git a/src/jscomp.sml b/src/jscomp.sml index 95c18016..c38056e8 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -33,6 +33,20 @@ structure EM = ErrorMsg structure E = MonoEnv structure U = MonoUtil +val funcs = [(("Basis", "alert"), "alert"), + (("Basis", "htmlifyString"), "escape")] + +structure FM = BinaryMapFn(struct + type ord_key = string * string + fun compare ((m1, x1), (m2, x2)) = + Order.join (String.compare (m1, m2), + fn () => String.compare (x1, x2)) + end) + +val funcs = foldl (fn ((k, v), m) => FM.insert (m, k, v)) FM.empty funcs + +fun ffi k = FM.find (funcs, k) + type state = { decls : decl list, script : string @@ -70,6 +84,7 @@ fun varDepth (e, _) = | EUnurlify _ => 0 | EJavaScript _ => 0 | ESignalReturn e => varDepth e + | ESignalBind (e1, e2) => Int.max (varDepth e1, varDepth e2) fun strcat loc es = case es of @@ -150,33 +165,50 @@ fun jsExp mode outer = e, st) end - | EFfi (_, s) => (str s, st) - | EFfiApp (_, s, []) => (str (s ^ "()"), st) - | EFfiApp (_, s, [e]) => + | EFfi k => let - val (e, st) = jsE inner (e, st) - + val name = case ffi k of + NONE => (EM.errorAt loc "Unsupported FFI identifier in JavaScript"; + "ERROR") + | SOME s => s in - (strcat [str (s ^ "("), - e, - str ")"], st) + (str name, st) end - | EFfiApp (_, s, e :: es) => + | EFfiApp (m, x, args) => let - val (e, st) = jsE inner (e, st) - val (es, st) = ListUtil.foldlMapConcat - (fn (e, st) => - let - val (e, st) = jsE inner (e, st) - in - ([str ",", e], st) - end) - st es + val name = case ffi (m, x) of + NONE => (EM.errorAt loc "Unsupported FFI function in JavaScript"; + "ERROR") + | SOME s => s in - (strcat (str (s ^ "(") - :: e - :: es - @ [str ")"]), st) + case args of + [] => (str (name ^ "()"), st) + | [e] => + let + val (e, st) = jsE inner (e, st) + + in + (strcat [str (name ^ "("), + e, + str ")"], st) + end + | e :: es => + let + val (e, st) = jsE inner (e, st) + val (es, st) = ListUtil.foldlMapConcat + (fn (e, st) => + let + val (e, st) = jsE inner (e, st) + in + ([str ",", e], st) + end) + st es + in + (strcat (str (name ^ "(") + :: e + :: es + @ [str ")"]), st) + end end | EApp (e1, e2) => @@ -317,11 +349,23 @@ fun jsExp mode outer = let val (e, st) = jsE inner (e, st) in - (strcat [str "sreturn(", + (strcat [str "sr(", e, str ")"], st) end + | ESignalBind (e1, e2) => + let + val (e1, st) = jsE inner (e1, st) + val (e2, st) = jsE inner (e2, st) + in + (strcat [str "sb(", + e1, + str ",", + e2, + str ")"], + st) + end end in jsE diff --git a/src/mono.sml b/src/mono.sml index 1a7fde00..54b77550 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -105,6 +105,7 @@ datatype exp' = | EJavaScript of javascript_mode * exp | ESignalReturn of exp + | ESignalBind of exp * exp withtype exp = exp' located diff --git a/src/mono_opt.sml b/src/mono_opt.sml index 6c0e6e21..550a055c 100644 --- a/src/mono_opt.sml +++ b/src/mono_opt.sml @@ -360,6 +360,9 @@ fun exp e = | EWrite (EPrim (Prim.String ""), loc) => ERecord [] + | ESignalBind ((ESignalReturn e1, loc), e2) => + optExp (EApp (e2, e1), loc) + | _ => e and optExp e = #1 (U.Exp.map {typ = typ, exp = exp} e) diff --git a/src/mono_print.sml b/src/mono_print.sml index e44bb74c..608fe269 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -285,6 +285,12 @@ fun p_exp' par env (e, _) = | ESignalReturn e => box [string "Return(", p_exp env e, string ")"] + | ESignalBind (e1, e2) => box [string "Return(", + p_exp env e1, + string ",", + space, + p_exp env e2, + string ")"] and p_exp env = p_exp' false env diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index e1da02c9..841e034e 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -77,6 +77,7 @@ fun impure (e, _) = | EClosure (_, es) => List.exists impure es | EJavaScript (_, e) => impure e | ESignalReturn e => impure e + | ESignalBind (e1, e2) => impure e1 orelse impure e2 val liftExpInExp = Monoize.liftExpInExp @@ -333,6 +334,7 @@ fun reduce file = | EUnurlify (e, _) => summarize d e | EJavaScript (_, e) => summarize d e | ESignalReturn e => summarize d e + | ESignalBind (e1, e2) => summarize d e1 @ summarize d e2 fun exp env e = @@ -478,6 +480,9 @@ fun reduce file = | EStrcat ((EPrim (Prim.String s1), _), (EPrim (Prim.String s2), _)) => EPrim (Prim.String (s1 ^ s2)) + | ESignalBind ((ESignalReturn e1, loc), e2) => + #1 (reduceExp env (EApp (e2, e1), loc)) + | _ => e in (*Print.prefaces "exp'" [("r", MonoPrint.p_exp env (r, ErrorMsg.dummySpan))];*) diff --git a/src/mono_util.sml b/src/mono_util.sml index 9788a551..a85443d7 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -328,6 +328,12 @@ fun mapfoldB {typ = fc, exp = fe, bind} = S.map2 (mfe ctx e, fn e' => (ESignalReturn e', loc)) + | ESignalBind (e1, e2) => + S.bind2 (mfe ctx e1, + fn e1' => + S.map2 (mfe ctx e2, + fn e2' => + (ESignalBind (e1', e2'), loc))) in mfe end diff --git a/src/monoize.sml b/src/monoize.sml index 63d84d8c..30bd5daa 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -957,8 +957,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) = val mt1 = (L'.TFun (un, t1), loc) val mt2 = (L'.TFun (un, t2), loc) in - ((L'.EAbs ("m1", mt1, (L'.TFun (mt1, (L'.TFun (mt2, (L'.TFun (un, un), loc)), loc)), loc), - (L'.EAbs ("m2", mt2, (L'.TFun (un, un), loc), + ((L'.EAbs ("m1", mt1, (L'.TFun ((L'.TFun (t1, mt2), loc), (L'.TFun (un, un), loc)), loc), + (L'.EAbs ("m2", (L'.TFun (t1, mt2), loc), (L'.TFun (un, un), loc), (L'.EAbs ("_", un, un, (L'.ELet ("r", t1, (L'.EApp ((L'.ERel 2, loc), (L'.ERecord [], loc)), loc), @@ -989,6 +989,20 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.ESignalReturn (L'.ERel 0, loc), loc)), loc), fm) end + | L.EApp ((L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "bind"), _), _), _), t1), _), t2), _), + (L.EFfi ("Basis", "signal_monad"), _)) => + let + val t1 = monoType env t1 + val t2 = monoType env t2 + val un = (L'.TRecord [], loc) + val mt1 = (L'.TSignal t1, loc) + val mt2 = (L'.TSignal t2, loc) + in + ((L'.EAbs ("m1", mt1, (L'.TFun ((L'.TFun (t1, mt2), loc), mt2), loc), + (L'.EAbs ("m2", (L'.TFun (t1, mt2), loc), mt2, + (L'.ESignalBind ((L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc), + fm) + end | L.ECApp ((L.EFfi ("Basis", "getCookie"), _), t) => let diff --git a/tests/sbind.ur b/tests/sbind.ur new file mode 100644 index 00000000..6e3ca782 --- /dev/null +++ b/tests/sbind.ur @@ -0,0 +1,5 @@ +fun main () : transaction page = return +

Before

+

{[s]}}/>

+

After

+ diff --git a/tests/sbind.urp b/tests/sbind.urp new file mode 100644 index 00000000..d8735c70 --- /dev/null +++ b/tests/sbind.urp @@ -0,0 +1,3 @@ +debug + +sbind -- cgit v1.2.3 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 --- jslib/urweb.js | 3 ++ 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 ++++- tests/reactive.ur | 7 ++-- 10 files changed, 116 insertions(+), 46 deletions(-) (limited to 'src/mono.sml') diff --git a/jslib/urweb.js b/jslib/urweb.js index f552b26b..eab67626 100644 --- a/jslib/urweb.js +++ b/jslib/urweb.js @@ -1,3 +1,6 @@ +function sc(v) { return {v : v} } + +function ss(s) { return {v : s.v} } function sr(v) { return {v : v} } function sb(x,y) { return {v : y(x.v).v} } 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 diff --git a/tests/reactive.ur b/tests/reactive.ur index cb49541f..95839c7d 100644 --- a/tests/reactive.ur +++ b/tests/reactive.ur @@ -1,4 +1,5 @@ fun main () : transaction page = - x <- source (); - y <- source (); - return Hi! + x <- source TEST; + return + + -- cgit v1.2.3 From 493ec594ea29706c85196d1b616ab28ed3da6797 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 --- include/urweb.h | 4 +++- 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 ++++++++------ tests/reactive2.ur | 6 ++++++ tests/reactive2.urp | 3 +++ 11 files changed, 68 insertions(+), 14 deletions(-) create mode 100644 tests/reactive2.ur create mode 100644 tests/reactive2.urp (limited to 'src/mono.sml') diff --git a/include/urweb.h b/include/urweb.h index 647f153a..a5bb8dc0 100644 --- a/include/urweb.h +++ b/include/urweb.h @@ -36,7 +36,9 @@ char *uw_get_optional_input(uw_context, int name); void uw_write(uw_context, const char*); -int uw_Basis_new_client_source(uw_context, uw_unit); +uw_Basis_int uw_Basis_new_client_source(uw_context, uw_Basis_string); +uw_unit uw_Basis_set_client_source(uw_context, uw_Basis_int, uw_Basis_string); + char *uw_Basis_get_script(uw_context, uw_unit); char *uw_Basis_htmlifyInt(uw_context, uw_Basis_int); 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 diff --git a/tests/reactive2.ur b/tests/reactive2.ur new file mode 100644 index 00000000..7164468e --- /dev/null +++ b/tests/reactive2.ur @@ -0,0 +1,6 @@ +fun main () : transaction page = + x <- source TEST; + set x HI; + return + + diff --git a/tests/reactive2.urp b/tests/reactive2.urp new file mode 100644 index 00000000..bdc0d1be --- /dev/null +++ b/tests/reactive2.urp @@ -0,0 +1,3 @@ +debug + +reactive2 -- cgit v1.2.3 From 8d3edc5aaa4617dd06623447cf9357067eadc072 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 30 Dec 2008 11:33:31 -0500 Subject: Harmonized source-setting between server and client --- src/cjrize.sml | 2 ++ src/jscomp.sml | 15 ++++++++++----- src/mono.sml | 2 +- src/mono_opt.sml | 2 ++ src/mono_print.sml | 13 ++++++++----- src/mono_reduce.sml | 4 ++-- src/mono_util.sml | 10 ++++++++-- src/monoize.sml | 16 ++++++++-------- 8 files changed, 41 insertions(+), 23 deletions(-) (limited to 'src/mono.sml') diff --git a/src/cjrize.sml b/src/cjrize.sml index 6d0ece61..1a5d10c0 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -422,7 +422,9 @@ fun cifyExp (eAll as (e, loc), sm) = ((L'.EUnurlify (e, t), loc), sm) end + | L.EJavaScript (_, _, SOME e) => cifyExp (e, 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" diff --git a/src/jscomp.sml b/src/jscomp.sml index 8b874289..a4e3dd35 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -190,6 +190,12 @@ fun jsExp mode outer = end | EFfiApp (m, x, args) => let + val args = + case (m, x, args) of + ("Basis", "new_client_source", [(EJavaScript (_, e, _), _)]) => [e] + | ("Basis", "set_client_source", [e1, (EJavaScript (_, e2, _), _)]) => [e1, e2] + | _ => args + val name = case ffi (m, x) of NONE => (EM.errorAt loc ("Unsupported FFI function " ^ x ^ " in JavaScript"); "ERROR") @@ -200,7 +206,6 @@ fun jsExp mode outer = | [e] => let val (e, st) = jsE inner (e, st) - in (strcat [str (name ^ "("), e, @@ -398,7 +403,7 @@ val decl : state -> decl -> decl * state = U.Decl.foldMapB {typ = fn x => x, exp = fn (env, e, st) => let - fun doCode m env e = + fun doCode m env orig e = let val len = length env fun str s = (EPrim (Prim.String s), #2 e) @@ -408,12 +413,12 @@ val decl : state -> decl -> decl * state = fn i => str ("var uwr" ^ Int.toString (len + i) ^ ";")) val (e, st) = jsExp m env 0 (e, st) in - (#1 (strcat (#2 e) (locals @ [e])), st) + (EJavaScript (m, orig, SOME (strcat (#2 e) (locals @ [e]))), st) end in case e of - EJavaScript (m, (EAbs (_, t, _, e), _)) => doCode m (t :: env) e - | EJavaScript (m, e) => doCode m env e + EJavaScript (m, orig as (EAbs (_, t, _, e), _), _) => doCode m (t :: env) orig e + | EJavaScript (m, e, _) => doCode m env e e | _ => (e, st) end, decl = fn (_, e, st) => (e, st), diff --git a/src/mono.sml b/src/mono.sml index 41457071..b58396fa 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -103,7 +103,7 @@ datatype exp' = | EUnurlify of exp * typ - | EJavaScript of javascript_mode * exp + | EJavaScript of javascript_mode * exp * exp option | ESignalReturn of exp | ESignalBind of exp * exp diff --git a/src/mono_opt.sml b/src/mono_opt.sml index 550a055c..7f23d8b1 100644 --- a/src/mono_opt.sml +++ b/src/mono_opt.sml @@ -363,6 +363,8 @@ fun exp e = | ESignalBind ((ESignalReturn e1, loc), e2) => optExp (EApp (e2, e1), loc) + | EJavaScript (_, _, SOME (e, _)) => e + | _ => e and optExp e = #1 (U.Exp.map {typ = typ, exp = exp} e) diff --git a/src/mono_print.sml b/src/mono_print.sml index a876cfac..f8a23d1d 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -216,10 +216,12 @@ fun p_exp' par env (e, _) = p_exp env e, string ")"] - | ESeq (e1, e2) => box [p_exp env e1, + | ESeq (e1, e2) => box [string "(", + p_exp env e1, string ";", space, - p_exp env e2] + p_exp env e2, + string ")"] | ELet (x, t, e1, e2) => box [string "(let", space, string x, @@ -279,9 +281,10 @@ fun p_exp' par env (e, _) = | EUnurlify (e, _) => box [string "unurlify(", p_exp env e, string ")"] - | EJavaScript (_, e) => box [string "JavaScript(", - p_exp env e, - string ")"] + | EJavaScript (_, e, NONE) => box [string "JavaScript(", + p_exp env e, + string ")"] + | EJavaScript (_, _, SOME e) => p_exp env e | ESignalReturn e => box [string "Return(", p_exp env e, diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index 072c548e..c96f97cf 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -76,7 +76,7 @@ fun impure (e, _) = | ELet (_, _, e1, e2) => impure e1 orelse impure e2 | EClosure (_, es) => List.exists impure es - | EJavaScript (_, e) => impure e + | EJavaScript (_, e, _) => impure e | ESignalReturn e => impure e | ESignalBind (e1, e2) => impure e1 orelse impure e2 | ESignalSource e => impure e @@ -335,7 +335,7 @@ fun reduce file = | EDml e => summarize d e @ [WriteDb] | ENextval e => summarize d e @ [WriteDb] | EUnurlify (e, _) => summarize d e - | EJavaScript (_, e) => summarize d e + | EJavaScript (_, e, _) => summarize d e | ESignalReturn e => summarize d e | ESignalBind (e1, e2) => summarize d e1 @ summarize d e2 | ESignalSource e => summarize d e diff --git a/src/mono_util.sml b/src/mono_util.sml index 3f9183d0..9ce3293b 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -324,10 +324,16 @@ fun mapfoldB {typ = fc, exp = fe, bind} = S.map2 (mft t, fn t' => (EUnurlify (e', t'), loc))) - | EJavaScript (m, e) => + | EJavaScript (m, e, NONE) => S.map2 (mfe ctx e, fn e' => - (EJavaScript (m, e'), loc)) + (EJavaScript (m, e', NONE), loc)) + | EJavaScript (m, e, SOME e2) => + S.bind2 (mfe ctx e, + fn e' => + S.map2 (mfe ctx e2, + fn e2' => + (EJavaScript (m, e', SOME e2'), loc))) | ESignalReturn e => S.map2 (mfe ctx e, diff --git a/src/monoize.sml b/src/monoize.sml index f40d49d0..f62848c5 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -976,7 +976,8 @@ fun monoExp (env, st, fm) (all as (e, 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)), + [(L'.EJavaScript (L'.File, (L'.ERel 1, loc), NONE), loc)]), + loc)), loc)), loc), fm) end @@ -990,7 +991,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc), (L'.EFfiApp ("Basis", "set_client_source", [(L'.ERel 2, loc), - (L'.EJavaScript (L'.File, (L'.ERel 1, loc)), loc)]), + (L'.EJavaScript (L'.File, (L'.ERel 1, loc), NONE), loc)]), loc)), loc)), loc)), loc), fm) end @@ -1801,7 +1802,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.EStrcat ( (L'.EPrim (Prim.String s'), loc), (L'.EStrcat ( - (L'.EJavaScript (L'.Attribute, e), loc), + (L'.EJavaScript (L'.Attribute, e, NONE), loc), (L'.EPrim (Prim.String "'"), loc)), loc)), loc)), loc), fm) @@ -1887,13 +1888,12 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | "dyn" => (case #1 attrs of - (*L'.ERecord [("Signal", (L'.EApp ((L'.EAbs (_, _, _, (L'.ESignalReturn (L'.ERel 0, _), _)), _), - e), _), _)] => (e, fm) *) - - L'.ERecord [("Signal", e, _)] => + L'.ERecord [("Signal", (L'.EApp ((L'.EAbs (_, _, _, (L'.ESignalReturn (L'.ERel 0, _), _)), _), + e), _), _)] => (e, fm) + | L'.ERecord [("Signal", e, _)] => ((L'.EStrcat ((L'.EPrim (Prim.String ""), loc)), loc)), loc), fm) | _ => raise Fail "Monoize: Bad dyn attributes") -- cgit v1.2.3 From 8bb915433716ecfdcf2c2209d1a62796ebde4714 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 1 Jan 2009 15:11:17 -0500 Subject: Injecting an int --- src/jscomp.sml | 67 +++++++++++++++++++++++++++++++++++++++++---------------- src/mono.sml | 2 +- src/monoize.sml | 5 +++-- tests/jsinj.ur | 14 ++++++++++++ tests/jsinj.urp | 3 +++ 5 files changed, 70 insertions(+), 21 deletions(-) create mode 100644 tests/jsinj.ur create mode 100644 tests/jsinj.urp (limited to 'src/mono.sml') diff --git a/src/jscomp.sml b/src/jscomp.sml index 67d8d9c1..b27a860b 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -102,6 +102,8 @@ fun strcat loc es = | [x] => x | x :: es' => (EStrcat (x, strcat loc es'), loc) +exception Unsupported of string * EM.span + fun process file = let val nameds = foldl (fn ((DVal (_, n, t, e, _), _), nameds) => IM.insert (nameds, n, e) @@ -111,13 +113,28 @@ fun process file = | (_, nameds) => nameds) IM.empty file + fun str loc s = (EPrim (Prim.String s), loc) + + fun quoteExp loc (t : typ) e = + case #1 t of + TSource => strcat loc [str loc "s", + (EFfiApp ("Basis", "htmlifyInt", [e]), loc)] + | TRecord [] => str loc "null" + + | TFfi ("Basis", "string") => e + | TFfi ("Basis", "int") => (EFfiApp ("Basis", "htmlifyInt", [e]), loc) + + | _ => (EM.errorAt loc "Don't know how to embed type in JavaScript"; + Print.prefaces "Can't embed" [("t", MonoPrint.p_typ MonoEnv.empty t)]; + str loc "ERROR") + fun jsExp mode skip outer = let val len = length outer fun jsE inner (e as (_, loc), st) = let - fun str s = (EPrim (Prim.String s), loc) + val str = str loc fun var n = Int.toString (len + inner - n - 1) @@ -134,22 +151,10 @@ fun process file = | TRecord [] => true | _ => false - fun unsupported s = - (EM.errorAt loc (s ^ " in code to be compiled to JavaScript"); - (str "ERROR", st)) + fun unsupported s = raise Unsupported (s, loc) val strcat = strcat loc - fun quoteExp (t : typ) e = - case #1 t of - TSource => strcat [str "s", - (EFfiApp ("Basis", "htmlifyInt", [e]), loc)] - | TRecord [] => str "null" - | TFfi ("Basis", "string") => e - | _ => (EM.errorAt loc "Don't know how to embed type in JavaScript"; - Print.prefaces "Can't embed" [("t", MonoPrint.p_typ MonoEnv.empty t)]; - str "ERROR") - fun jsPrim p = case p of Prim.String s => @@ -241,7 +246,11 @@ fun process file = EPrim (Prim.String s) => s | EStrcat (e1, e2) => deStrcat e1 ^ deStrcat e2 | _ => raise Fail "Jscomp: deStrcat" + + val quoteExp = quoteExp loc in + (*Print.prefaces "jsE" [("e", MonoPrint.p_exp MonoEnv.empty e)];*) + case #1 e of EPrim p => (jsPrim p, st) | ERel n => @@ -513,12 +522,15 @@ fun process file = str ")"], st) end + | EJavaScript (_, _, SOME e) => (e, st) + | EClosure _ => unsupported "EClosure" | EQuery _ => unsupported "Query" | EDml _ => unsupported "DML" | ENextval _ => unsupported "Nextval" | EUnurlify _ => unsupported "EUnurlify" - | EJavaScript _ => unsupported "Nested JavaScript" + | EJavaScript (_, e, _) => unsupported "Nested JavaScript" + | ESignalReturn e => let val (e, st) = jsE inner (e, st) @@ -572,9 +584,28 @@ fun process file = end in case e of - EJavaScript (m, orig as (EAbs (_, t, _, e), _), _) => - doCode m 1 (t :: env) orig e - | EJavaScript (m, e, _) => doCode m 0 env e e + EJavaScript (m as Source t, orig, _) => + (doCode m 0 env orig orig + handle Unsupported (s, loc) => + let + val e = ELet ("js", t, orig, quoteExp (#2 orig) t + (ERel 0, #2 orig)) + in + (EJavaScript (m, orig, SOME (e, #2 orig)), st) + end) + + | EJavaScript (m, orig as (EAbs (_, t, _, e), _), _) => + (doCode m 1 (t :: env) orig e + handle Unsupported (s, loc) => + (EM.errorAt loc (s ^ " in code to be compiled to JavaScript"); + (EPrim (Prim.String "ERROR"), st))) + + | EJavaScript (m, orig, _) => + (doCode m 0 env orig orig + handle Unsupported (s, loc) => + (EM.errorAt loc (s ^ " in code to be compiled to JavaScript"); + (EPrim (Prim.String "ERROR"), st))) + | _ => (e, st) end, decl = fn (_, e, st) => (e, st), diff --git a/src/mono.sml b/src/mono.sml index b58396fa..8999704c 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -60,7 +60,7 @@ withtype pat = pat' located datatype javascript_mode = Attribute | Script - | File + | Source of typ datatype exp' = EPrim of Prim.t diff --git a/src/monoize.sml b/src/monoize.sml index f62848c5..6c4534ac 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -976,7 +976,7 @@ fun monoExp (env, st, fm) (all as (e, 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), NONE), loc)]), + [(L'.EJavaScript (L'.Source t, (L'.ERel 1, loc), NONE), loc)]), loc)), loc)), loc), fm) @@ -991,7 +991,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc), (L'.EFfiApp ("Basis", "set_client_source", [(L'.ERel 2, loc), - (L'.EJavaScript (L'.File, (L'.ERel 1, loc), NONE), loc)]), + (L'.EJavaScript (L'.Source t, + (L'.ERel 1, loc), NONE), loc)]), loc)), loc)), loc)), loc), fm) end diff --git a/tests/jsinj.ur b/tests/jsinj.ur new file mode 100644 index 00000000..194d26be --- /dev/null +++ b/tests/jsinj.ur @@ -0,0 +1,14 @@ +cookie int : int + +fun getOpt (t ::: Type) (o : option t) (v : t) : t = + case o of + None => v + | Some x => x + +fun main () : transaction page = + n <- getCookie int; + sn <- source (getOpt n 7); + return + {[n]}}/> + CHANGE + diff --git a/tests/jsinj.urp b/tests/jsinj.urp new file mode 100644 index 00000000..dc929b9d --- /dev/null +++ b/tests/jsinj.urp @@ -0,0 +1,3 @@ +debug + +jsinj -- cgit v1.2.3 From e27335a18e8f4b1cca2749e8d41863b3cbef9b62 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 15 Feb 2009 09:27:36 -0500 Subject: Export RPC functions and push RPC calls through to Mono --- src/cjr_print.sml | 2 ++ src/cjrize.sml | 2 ++ src/core.sml | 1 + src/core_print.sml | 1 + src/jscomp.sml | 4 ++++ src/mono.sml | 2 ++ src/mono_print.sml | 9 +++++++++ src/mono_reduce.sml | 3 +++ src/mono_util.sml | 7 +++++++ src/monoize.sml | 8 +++++++- src/rpcify.sml | 47 +++++++++++++++++++++++++++++++++++------------ 11 files changed, 73 insertions(+), 13 deletions(-) (limited to 'src/mono.sml') diff --git a/src/cjr_print.sml b/src/cjr_print.sml index f8b1f23b..8f5c8551 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -1849,6 +1849,7 @@ fun p_file env (ds, ps) = val fields = foldl (fn ((ek, _, _, ts), fields) => case ek of Core.Link => fields + | Core.Rpc => fields | Core.Action => case List.nth (ts, length ts - 2) of (TRecord i, _) => @@ -1971,6 +1972,7 @@ fun p_file env (ds, ps) = val (ts, defInputs, inputsVar) = case ek of Core.Link => (List.take (ts, length ts - 1), string "", string "") + | Core.Rpc => (List.take (ts, length ts - 1), string "", string "") | Core.Action => case List.nth (ts, length ts - 2) of (TRecord i, _) => diff --git a/src/cjrize.sml b/src/cjrize.sml index 1a5d10c0..77674158 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -429,6 +429,8 @@ fun cifyExp (eAll as (e, loc), sm) = | L.ESignalBind _ => raise Fail "Cjrize: ESignalBind remains" | L.ESignalSource _ => raise Fail "Cjrize: ESignalSource remains" + | L.EServerCall _ => raise Fail "Cjrize EServerCall" + fun cifyDecl ((d, loc), sm) = case d of L.DDatatype (x, n, xncs) => diff --git a/src/core.sml b/src/core.sml index fbe150c1..62f046fe 100644 --- a/src/core.sml +++ b/src/core.sml @@ -113,6 +113,7 @@ withtype exp = exp' located datatype export_kind = Link | Action + | Rpc datatype decl' = DCon of string * int * kind * con diff --git a/src/core_print.sml b/src/core_print.sml index 64cead70..e9a36fbb 100644 --- a/src/core_print.sml +++ b/src/core_print.sml @@ -436,6 +436,7 @@ fun p_export_kind ck = case ck of Link => string "link" | Action => string "action" + | Rpc => string "rpc" fun p_datatype env (x, n, xs, cons) = let diff --git a/src/jscomp.sml b/src/jscomp.sml index f61ec3f0..627ba8f6 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -98,6 +98,7 @@ fun varDepth (e, _) = | ESignalReturn e => varDepth e | ESignalBind (e1, e2) => Int.max (varDepth e1, varDepth e2) | ESignalSource e => varDepth e + | EServerCall (_, es, ek) => foldl Int.max (varDepth ek) (map varDepth es) fun closedUpto d = let @@ -138,6 +139,7 @@ fun closedUpto d = | ESignalReturn e => cu inner e | ESignalBind (e1, e2) => cu inner e1 andalso cu inner e2 | ESignalSource e => cu inner e + | EServerCall (_, es, ek) => List.all (cu inner) es andalso cu inner ek in cu 0 end @@ -809,6 +811,8 @@ fun process file = str ")"], st) end + + | EServerCall _ => raise Fail "Jscomp EServerCall" end in jsE diff --git a/src/mono.sml b/src/mono.sml index 8999704c..547f8a55 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -109,6 +109,8 @@ datatype exp' = | ESignalBind of exp * exp | ESignalSource of exp + | EServerCall of int * exp list * exp + withtype exp = exp' located datatype decl' = diff --git a/src/mono_print.sml b/src/mono_print.sml index 1e9de3d8..a859a1bd 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -308,6 +308,15 @@ fun p_exp' par env (e, _) = p_exp env e, string ")"] + | EServerCall (n, es, e) => box [string "Server(", + p_enamed env n, + string ",", + space, + p_list (p_exp env) es, + string ")[", + p_exp env e, + string "]"] + and p_exp env = p_exp' false env fun p_vali env (x, n, t, e, s) = diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index 878fec92..7d39648a 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -81,6 +81,7 @@ fun impure (e, _) = | ESignalReturn e => impure e | ESignalBind (e1, e2) => impure e1 orelse impure e2 | ESignalSource e => impure e + | EServerCall _ => true val liftExpInExp = Monoize.liftExpInExp @@ -344,6 +345,8 @@ fun reduce file = | ESignalReturn e => summarize d e | ESignalBind (e1, e2) => summarize d e1 @ summarize d e2 | ESignalSource e => summarize d e + + | EServerCall (_, es, ek) => List.concat (map (summarize d) es) @ summarize d ek @ [Unsure] in (*Print.prefaces "Summarize" [("e", MonoPrint.p_exp MonoEnv.empty (e, ErrorMsg.dummySpan)), diff --git a/src/mono_util.sml b/src/mono_util.sml index 9ce3293b..13e0d32c 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -349,6 +349,13 @@ fun mapfoldB {typ = fc, exp = fe, bind} = S.map2 (mfe ctx e, fn e' => (ESignalSource e', loc)) + + | EServerCall (n, es, ek) => + S.bind2 (ListUtil.mapfold (fn e => mfe ctx e) es, + fn es' => + S.map2 (mfe ctx ek, + fn ek' => + (EServerCall (n, es', ek'), loc))) in mfe end diff --git a/src/monoize.sml b/src/monoize.sml index a1f61143..fb1ac2f1 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -2225,7 +2225,13 @@ fun monoExp (env, st, fm) (all as (e, loc)) = ((L'.ELet (x, t', e1, e2), loc), fm) end - | L.EServerCall _ => raise Fail "Monoize EServerCall" + | L.EServerCall (n, es, ek) => + let + val (es, fm) = ListUtil.foldlMap (fn (e, fm) => monoExp (env, st, fm) e) fm es + val (ek, fm) = monoExp (env, st, fm) ek + in + ((L'.EServerCall (n, es, ek), loc), fm) + end end fun monoDecl (env, fm) (all as (d, loc)) = diff --git a/src/rpcify.sml b/src/rpcify.sml index dec8dc18..09c44a7a 100644 --- a/src/rpcify.sml +++ b/src/rpcify.sml @@ -53,8 +53,11 @@ val csBasis = SS.addList (SS.empty, "alert"]) type state = { - exps : int IM.map, - decls : (string * int * con * exp * string) list + cpsed : int IM.map, + cps_decls : (string * int * con * exp * string) list, + + exported : IS.set, + export_decls : decl list } fun frob file = @@ -114,6 +117,19 @@ fun frob file = (0, [])) val (n, args) = getApp (trans1, []) + + val (exported, export_decls) = + if IS.member (#exported st, n) then + (#exported st, #export_decls st) + else + (IS.add (#exported st, n), + (DExport (Rpc, n), loc) :: #export_decls st) + + val st = {cpsed = #cpsed st, + cps_decls = #cps_decls st, + + exported = exported, + export_decls = export_decls} in (EServerCall (n, args, trans2), st) end @@ -128,19 +144,26 @@ fun frob file = decl = fn x => x} st d in - (case #decls st of - [] => [d] - | ds => - case d of - (DValRec vis, loc) => [(DValRec (ds @ vis), loc)] - | (_, loc) => [(DValRec ds, loc), d], - {decls = [], - exps = #exps st}) + (List.revAppend (case #cps_decls st of + [] => [d] + | ds => + case d of + (DValRec vis, loc) => [(DValRec (ds @ vis), loc)] + | (_, loc) => [d, (DValRec ds, loc)], + #export_decls st), + {cpsed = #cpsed st, + cps_decls = [], + + exported = #exported st, + export_decls = []}) end val (file, _) = ListUtil.foldlMapConcat decl - {decls = [], - exps = IM.empty} + {cpsed = IM.empty, + cps_decls = [], + + exported = IS.empty, + export_decls = []} file in file -- cgit v1.2.3 From 1557ac806159fe58eaa442527f73e569dd04f88e Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 15 Feb 2009 10:32:50 -0500 Subject: First gimpy RPC --- lib/js/urweb.js | 29 +++++++++++++++++++++++++++++ src/cjr.sml | 2 +- src/cjr_print.sml | 32 ++++++++++++++++++++++---------- src/cjrize.sml | 5 +++-- src/core.sml | 2 +- src/core_print.sml | 16 ++++++++-------- src/core_util.sml | 10 ++++++---- src/jscomp.sml | 14 +++++++++++--- src/mono.sml | 4 ++-- src/mono_print.sml | 46 +++++++++++++++++++++++++--------------------- src/mono_reduce.sml | 2 +- src/mono_shake.sml | 2 +- src/mono_util.sml | 16 ++++++++++------ src/monoize.sml | 38 ++++++++++++++++++++++++++++---------- src/pathcheck.sml | 2 +- src/reduce.sml | 2 +- src/reduce_local.sml | 2 +- src/rpcify.sml | 30 +++++++++++++++++++++++++++++- src/shake.sml | 2 +- tests/rpc.ur | 4 +++- tests/rpc.urp | 2 +- 21 files changed, 185 insertions(+), 77 deletions(-) (limited to 'src/mono.sml') diff --git a/lib/js/urweb.js b/lib/js/urweb.js index c46263b8..9dd4dbbe 100644 --- a/lib/js/urweb.js +++ b/lib/js/urweb.js @@ -111,3 +111,32 @@ function cr(n) { return closures[n](); } + +function getXHR() +{ + try { + return new XMLHttpRequest(); + } catch (e) { + try { + return new ActiveXObject("Msxml2.XMLHTTP"); + } catch (e) { + try { + return new ActiveXObject("Microsoft.XMLHTTP"); + } catch (e) { + throw "Your browser doesn't seem to support AJAX."; + } + } + } +} + +function rc(uri, k) { + var xhr = getXHR(); + + xhr.onreadystatechange = function() { + if (xhr.readyState == 4) + k(xhr.responseText); + }; + + xhr.open("GET", uri, true); + xhr.send(null); +} diff --git a/src/cjr.sml b/src/cjr.sml index 43a29a6c..a38a1b0d 100644 --- a/src/cjr.sml +++ b/src/cjr.sml @@ -113,6 +113,6 @@ datatype decl' = withtype decl = decl' located -type file = decl list * (Core.export_kind * string * int * typ list) list +type file = decl list * (Core.export_kind * string * int * typ list * typ) list end diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 8f5c8551..6074ca3b 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -1846,7 +1846,7 @@ fun p_file env (ds, ps) = E.declBinds env d)) env ds - val fields = foldl (fn ((ek, _, _, ts), fields) => + val fields = foldl (fn ((ek, _, _, ts, _), fields) => case ek of Core.Link => fields | Core.Rpc => fields @@ -1967,7 +1967,7 @@ fun p_file env (ds, ps) = string "}"] end - fun p_page (ek, s, n, ts) = + fun p_page (ek, s, n, ts, ran) = let val (ts, defInputs, inputsVar) = case ek of @@ -2054,12 +2054,14 @@ fun p_file env (ds, ps) = newline, string "if (*request == '/') ++request;", newline, - string "uw_write_header(ctx, \"Content-type: text/html\\r\\n\");", - newline, - string "uw_write_header(ctx, \"Content-script-type: text/javascript\\r\\n\");", - newline, - string "uw_write(ctx, \"\");", - newline, + box (case ek of + Core.Rpc => [] + | _ => [string "uw_write_header(ctx, \"Content-type: text/html\\r\\n\");", + newline, + string "uw_write_header(ctx, \"Content-script-type: text/javascript\\r\\n\");", + newline, + string "uw_write(ctx, \"\");", + newline]), box [string "{", newline, box (ListUtil.mapi (fn (i, t) => box [p_typ env t, @@ -2073,6 +2075,14 @@ fun p_file env (ds, ps) = string ";", newline]) ts), defInputs, + box (case ek of + Core.Rpc => [p_typ env ran, + space, + string "res", + space, + string "=", + space] + | _ => []), p_enamed env n, string "(", p_list_sep (box [string ",", space]) @@ -2082,8 +2092,10 @@ fun p_file env (ds, ps) = inputsVar, string ", uw_unit_v);", newline, - string "uw_write(ctx, \"\");", - newline, + box (case ek of + Core.Rpc => [] + | _ => [string "uw_write(ctx, \"\");", + newline]), string "return;", newline, string "}", diff --git a/src/cjrize.sml b/src/cjrize.sml index 77674158..16a82ec8 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -514,11 +514,12 @@ fun cifyDecl ((d, loc), sm) = (SOME (L'.DFunRec vis, loc), NONE, sm) end - | L.DExport (ek, s, n, ts) => + | L.DExport (ek, s, n, ts, t) => let val (ts, sm) = ListUtil.foldlMap cifyTyp sm ts + val (t, sm) = cifyTyp (t, sm) in - (NONE, SOME (ek, "/" ^ s, n, ts), sm) + (NONE, SOME (ek, "/" ^ s, n, ts, t), sm) end | L.DTable (s, xts) => diff --git a/src/core.sml b/src/core.sml index 62f046fe..c6e0cfef 100644 --- a/src/core.sml +++ b/src/core.sml @@ -106,7 +106,7 @@ datatype exp' = | ELet of string * con * exp * exp - | EServerCall of int * exp list * exp + | EServerCall of int * exp list * exp * con withtype exp = exp' located diff --git a/src/core_print.sml b/src/core_print.sml index e9a36fbb..405ae14e 100644 --- a/src/core_print.sml +++ b/src/core_print.sml @@ -394,14 +394,14 @@ fun p_exp' par env (e, _) = newline, p_exp (E.pushERel env x t) e2] - | EServerCall (n, es, e) => box [string "Server(", - p_enamed env n, - string ",", - space, - p_list (p_exp env) es, - string ")[", - p_exp env e, - string "]"] + | EServerCall (n, es, e, _) => box [string "Server(", + p_enamed env n, + string ",", + space, + p_list (p_exp env) es, + string ")[", + p_exp env e, + string "]"] and p_exp env = p_exp' false env diff --git a/src/core_util.sml b/src/core_util.sml index 3d6808f9..a222dca4 100644 --- a/src/core_util.sml +++ b/src/core_util.sml @@ -482,7 +482,7 @@ fun compare ((e1, _), (e2, _)) = | (ELet _, _) => LESS | (_, ELet _) => GREATER - | (EServerCall (n1, es1, e1), EServerCall (n2, es2, e2)) => + | (EServerCall (n1, es1, e1, _), EServerCall (n2, es2, e2, _)) => join (Int.compare (n1, n2), fn () => join (joinL compare (es1, es2), fn () => compare (e1, e2))) @@ -660,12 +660,14 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = fn e2' => (ELet (x, t', e1', e2'), loc)))) - | EServerCall (n, es, e) => + | EServerCall (n, es, e, t) => S.bind2 (ListUtil.mapfold (mfe ctx) es, fn es' => - S.map2 (mfe ctx e, + S.bind2 (mfe ctx e, fn e' => - (EServerCall (n, es', e'), loc))) + S.map2 (mfc ctx t, + fn t' => + (EServerCall (n, es', e', t'), loc)))) and mfp ctx (pAll as (p, loc)) = case p of diff --git a/src/jscomp.sml b/src/jscomp.sml index 627ba8f6..de671fef 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -98,7 +98,7 @@ fun varDepth (e, _) = | ESignalReturn e => varDepth e | ESignalBind (e1, e2) => Int.max (varDepth e1, varDepth e2) | ESignalSource e => varDepth e - | EServerCall (_, es, ek) => foldl Int.max (varDepth ek) (map varDepth es) + | EServerCall (_, es, ek, _) => foldl Int.max (varDepth ek) (map varDepth es) fun closedUpto d = let @@ -139,7 +139,7 @@ fun closedUpto d = | ESignalReturn e => cu inner e | ESignalBind (e1, e2) => cu inner e1 andalso cu inner e2 | ESignalSource e => cu inner e - | EServerCall (_, es, ek) => List.all (cu inner) es andalso cu inner ek + | EServerCall (_, es, ek, _) => List.all (cu inner) es andalso cu inner ek in cu 0 end @@ -812,7 +812,15 @@ fun process file = st) end - | EServerCall _ => raise Fail "Jscomp EServerCall" + | EServerCall (x, es, ek, _) => + let + val (ek, st) = jsE inner (ek, st) + in + (strcat [str ("rc(\"" ^ !Monoize.urlPrefix ^ x ^ "\","), + ek, + str ")"], + st) + end end in jsE diff --git a/src/mono.sml b/src/mono.sml index 547f8a55..ea2b9720 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -109,7 +109,7 @@ datatype exp' = | ESignalBind of exp * exp | ESignalSource of exp - | EServerCall of int * exp list * exp + | EServerCall of string * exp list * exp * typ withtype exp = exp' located @@ -117,7 +117,7 @@ datatype decl' = DDatatype of string * int * (string * int * typ option) list | DVal of string * int * typ * exp * string | DValRec of (string * int * typ * exp * string) list - | DExport of Core.export_kind * string * int * typ list + | DExport of Core.export_kind * string * int * typ list * typ | DTable of string * (string * typ) list | DSequence of string diff --git a/src/mono_print.sml b/src/mono_print.sml index a859a1bd..ba4c57f1 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -308,14 +308,14 @@ fun p_exp' par env (e, _) = p_exp env e, string ")"] - | EServerCall (n, es, e) => box [string "Server(", - p_enamed env n, - string ",", - space, - p_list (p_exp env) es, - string ")[", - p_exp env e, - string "]"] + | EServerCall (n, es, e, _) => box [string "Server(", + string n, + string ",", + space, + p_list (p_exp env) es, + string ")[", + p_exp env e, + string "]"] and p_exp env = p_exp' false env @@ -378,19 +378,23 @@ fun p_decl env (dAll as (d, _) : decl) = p_list_sep (box [newline, string "and", space]) (p_vali env) vis] end - | DExport (ek, s, n, ts) => box [string "export", - space, - CorePrint.p_export_kind ek, - space, - p_enamed env n, - space, - string "as", - space, - string s, - p_list_sep (string "") (fn t => box [space, - string "(", - p_typ env t, - string ")"]) ts] + | DExport (ek, s, n, ts, t) => box [string "export", + space, + CorePrint.p_export_kind ek, + space, + p_enamed env n, + space, + string "as", + space, + string s, + p_list_sep (string "") (fn t => box [space, + string "(", + p_typ env t, + string ")"]) ts, + space, + string "->", + space, + p_typ env t] | DTable (s, xts) => box [string "(* SQL table ", string s, diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index 7d39648a..2d0412fd 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -346,7 +346,7 @@ fun reduce file = | ESignalBind (e1, e2) => summarize d e1 @ summarize d e2 | ESignalSource e => summarize d e - | EServerCall (_, es, ek) => List.concat (map (summarize d) es) @ summarize d ek @ [Unsure] + | EServerCall (_, es, ek, _) => List.concat (map (summarize d) es) @ summarize d ek @ [Unsure] in (*Print.prefaces "Summarize" [("e", MonoPrint.p_exp MonoEnv.empty (e, ErrorMsg.dummySpan)), diff --git a/src/mono_shake.sml b/src/mono_shake.sml index 34bd98be..4fd3caeb 100644 --- a/src/mono_shake.sml +++ b/src/mono_shake.sml @@ -44,7 +44,7 @@ type free = { fun shake file = let val page_es = List.foldl - (fn ((DExport (_, _, n, _), _), page_es) => n :: page_es + (fn ((DExport (_, _, n, _, _), _), page_es) => n :: page_es | (_, page_es) => page_es) [] file val (cdef, edef) = foldl (fn ((DDatatype (_, n, xncs), _), (cdef, edef)) => diff --git a/src/mono_util.sml b/src/mono_util.sml index 13e0d32c..d1157218 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -350,12 +350,14 @@ fun mapfoldB {typ = fc, exp = fe, bind} = fn e' => (ESignalSource e', loc)) - | EServerCall (n, es, ek) => + | EServerCall (n, es, ek, t) => S.bind2 (ListUtil.mapfold (fn e => mfe ctx e) es, fn es' => - S.map2 (mfe ctx ek, + S.bind2 (mfe ctx ek, fn ek' => - (EServerCall (n, es', ek'), loc))) + S.map2 (mft t, + fn t' => + (EServerCall (n, es', ek', t'), loc)))) in mfe end @@ -443,10 +445,12 @@ fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} = fn vis' => (DValRec vis', loc)) end - | DExport (ek, s, n, ts) => - S.map2 (ListUtil.mapfold mft ts, + | DExport (ek, s, n, ts, t) => + S.bind2 (ListUtil.mapfold mft ts, fn ts' => - (DExport (ek, s, n, ts'), loc)) + S.map2 (mft t, + fn t' => + (DExport (ek, s, n, ts', t'), loc))) | DTable _ => S.return2 dAll | DSequence _ => S.return2 dAll | DDatabase _ => S.return2 dAll diff --git a/src/monoize.sml b/src/monoize.sml index fb1ac2f1..43c3f47d 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -2225,12 +2225,28 @@ fun monoExp (env, st, fm) (all as (e, loc)) = ((L'.ELet (x, t', e1, e2), loc), fm) end - | L.EServerCall (n, es, ek) => + | L.EServerCall (n, es, ek, t) => let + val t = monoType env t + val (_, _, _, name) = Env.lookupENamed env n val (es, fm) = ListUtil.foldlMap (fn (e, fm) => monoExp (env, st, fm) e) fm es val (ek, fm) = monoExp (env, st, fm) ek - in - ((L'.EServerCall (n, es, ek), loc), fm) + + val ekf = (L'.EAbs ("f", + (L'.TFun (t, + (L'.TFun ((L'.TRecord [], loc), + (L'.TRecord [], loc)), loc)), loc), + (L'.TFun (t, + (L'.TRecord [], loc)), loc), + (L'.EAbs ("x", + t, + (L'.TRecord [], loc), + (L'.EApp ((L'.EApp ((L'.ERel 1, loc), + (L'.ERel 0, loc)), loc), + (L'.ERecord [], loc)), loc)), loc)), loc) + val ek = (L'.EApp (ekf, ek), loc) + in + ((L'.EServerCall (name, es, ek, t), loc), fm) end end @@ -2280,16 +2296,18 @@ fun monoDecl (env, fm) (all as (d, loc)) = let val (_, t, _, s) = Env.lookupENamed env n - fun unwind (t, _) = - case t of - L.TFun (dom, ran) => dom :: unwind ran + fun unwind (t, args) = + case #1 t of + L.TFun (dom, ran) => unwind (ran, dom :: args) | L.CApp ((L.CFfi ("Basis", "transaction"), _), t) => - (L.TRecord (L.CRecord ((L.KType, loc), []), loc), loc) :: unwind t - | _ => [] + unwind (t, (L.TRecord (L.CRecord ((L.KType, loc), []), loc), loc) :: args) + | _ => (rev args, t) - val ts = map (monoType env) (unwind t) + val (ts, ran) = unwind (t, []) + val ts = map (monoType env) ts + val ran = monoType env ran in - SOME (env, fm, [(L'.DExport (ek, s, n, ts), loc)]) + SOME (env, fm, [(L'.DExport (ek, s, n, ts, ran), loc)]) end | L.DTable (x, n, (L.CRecord (_, xts), _), s) => let diff --git a/src/pathcheck.sml b/src/pathcheck.sml index ed6a4124..036d286f 100644 --- a/src/pathcheck.sml +++ b/src/pathcheck.sml @@ -46,7 +46,7 @@ fun checkDecl ((d, loc), (funcs, rels)) = (funcs, SS.add (rels, s))) in case d of - DExport (_, s, _, _) => + DExport (_, s, _, _, _) => (if SS.member (funcs, s) then E.errorAt loc ("Duplicate function path " ^ s) else diff --git a/src/reduce.sml b/src/reduce.sml index 89fce664..b428c01f 100644 --- a/src/reduce.sml +++ b/src/reduce.sml @@ -368,7 +368,7 @@ fun conAndExp (namedC, namedE) = | ELet (x, t, e1, e2) => (ELet (x, con env t, exp env e1, exp (UnknownE :: env) e2), loc) - | EServerCall (n, es, e) => (EServerCall (n, map (exp env) es, exp env e), loc)) + | EServerCall (n, es, e, t) => (EServerCall (n, map (exp env) es, exp env e, con env t), loc)) in {con = con, exp = exp} end diff --git a/src/reduce_local.sml b/src/reduce_local.sml index 55bb5198..7de7d799 100644 --- a/src/reduce_local.sml +++ b/src/reduce_local.sml @@ -131,7 +131,7 @@ fun exp env (all as (e, loc)) = | ELet (x, t, e1, e2) => (ELet (x, t, exp env e1, exp (Unknown :: env) e2), loc) - | EServerCall (n, es, e) => (EServerCall (n, map (exp env) es, exp env e), loc) + | EServerCall (n, es, e, t) => (EServerCall (n, map (exp env) es, exp env e, t), loc) fun reduce file = let diff --git a/src/rpcify.sml b/src/rpcify.sml index 09c44a7a..45d178ee 100644 --- a/src/rpcify.sml +++ b/src/rpcify.sml @@ -98,6 +98,29 @@ fun frob file = val serverSide = sideish (ssBasis, ssids) val clientSide = sideish (csBasis, csids) + val tfuncs = foldl + (fn ((d, _), tfuncs) => + let + fun doOne ((_, n, t, _, _), tfuncs) = + let + fun crawl ((t, _), args) = + case t of + CApp ((CFfi ("Basis", "transaction"), _), ran) => SOME (rev args, ran) + | TFun (arg, rest) => crawl (rest, arg :: args) + | _ => NONE + in + case crawl (t, []) of + NONE => tfuncs + | SOME sg => IM.insert (tfuncs, n, sg) + end + in + case d of + DVal vi => doOne (vi, tfuncs) + | DValRec vis => foldl doOne tfuncs vis + | _ => tfuncs + end) + IM.empty file + fun exp (e, st) = case e of EApp ( @@ -130,8 +153,13 @@ fun frob file = exported = exported, export_decls = export_decls} + + val ran = + case IM.find (tfuncs, n) of + NONE => raise Fail "Rpcify: Undetected transaction function" + | SOME (_, ran) => ran in - (EServerCall (n, args, trans2), st) + (EServerCall (n, args, trans2, ran), st) end | _ => (e, st)) | _ => (e, st) diff --git a/src/shake.sml b/src/shake.sml index 58c1d2c6..4df64efa 100644 --- a/src/shake.sml +++ b/src/shake.sml @@ -116,7 +116,7 @@ fun shake file = in case e of ENamed n => check n - | EServerCall (n, _, _) => check n + | EServerCall (n, _, _, _) => check n | _ => s end diff --git a/tests/rpc.ur b/tests/rpc.ur index 85191229..b2e9722c 100644 --- a/tests/rpc.ur +++ b/tests/rpc.ur @@ -8,6 +8,8 @@ fun main () : transaction page = return