Mercurial > urweb
changeset 609:56aaa1941dad
First gimpy RPC
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Sun, 15 Feb 2009 10:32:50 -0500 |
| parents | 330a7de47914 |
| children | c41b2abf156b |
| files | lib/js/urweb.js src/cjr.sml src/cjr_print.sml src/cjrize.sml src/core.sml src/core_print.sml src/core_util.sml src/jscomp.sml src/mono.sml src/mono_print.sml src/mono_reduce.sml src/mono_shake.sml src/mono_util.sml src/monoize.sml src/pathcheck.sml src/reduce.sml src/reduce_local.sml src/rpcify.sml src/shake.sml tests/rpc.ur tests/rpc.urp |
| diffstat | 21 files changed, 184 insertions(+), 76 deletions(-) [+] |
line wrap: on
line diff
--- a/lib/js/urweb.js Sun Feb 15 09:27:36 2009 -0500 +++ b/lib/js/urweb.js Sun Feb 15 10:32:50 2009 -0500 @@ -111,3 +111,32 @@ 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); +}
--- a/src/cjr.sml Sun Feb 15 09:27:36 2009 -0500 +++ b/src/cjr.sml Sun Feb 15 10:32:50 2009 -0500 @@ -113,6 +113,6 @@ 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
--- a/src/cjr_print.sml Sun Feb 15 09:27:36 2009 -0500 +++ b/src/cjr_print.sml Sun Feb 15 10:32:50 2009 -0500 @@ -1846,7 +1846,7 @@ 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 @@ 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 @@ 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, \"<html>\");", - 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, \"<html>\");", + newline]), box [string "{", newline, box (ListUtil.mapi (fn (i, t) => box [p_typ env t, @@ -2073,6 +2075,14 @@ 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 @@ inputsVar, string ", uw_unit_v);", newline, - string "uw_write(ctx, \"</html>\");", - newline, + box (case ek of + Core.Rpc => [] + | _ => [string "uw_write(ctx, \"</html>\");", + newline]), string "return;", newline, string "}",
--- a/src/cjrize.sml Sun Feb 15 09:27:36 2009 -0500 +++ b/src/cjrize.sml Sun Feb 15 10:32:50 2009 -0500 @@ -514,11 +514,12 @@ (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) =>
--- a/src/core.sml Sun Feb 15 09:27:36 2009 -0500 +++ b/src/core.sml Sun Feb 15 10:32:50 2009 -0500 @@ -106,7 +106,7 @@ | ELet of string * con * exp * exp - | EServerCall of int * exp list * exp + | EServerCall of int * exp list * exp * con withtype exp = exp' located
--- a/src/core_print.sml Sun Feb 15 09:27:36 2009 -0500 +++ b/src/core_print.sml Sun Feb 15 10:32:50 2009 -0500 @@ -394,14 +394,14 @@ 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
--- a/src/core_util.sml Sun Feb 15 09:27:36 2009 -0500 +++ b/src/core_util.sml Sun Feb 15 10:32:50 2009 -0500 @@ -482,7 +482,7 @@ | (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 @@ 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
--- a/src/jscomp.sml Sun Feb 15 09:27:36 2009 -0500 +++ b/src/jscomp.sml Sun Feb 15 10:32:50 2009 -0500 @@ -98,7 +98,7 @@ | 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 @@ | 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 @@ 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
--- a/src/mono.sml Sun Feb 15 09:27:36 2009 -0500 +++ b/src/mono.sml Sun Feb 15 10:32:50 2009 -0500 @@ -109,7 +109,7 @@ | 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 @@ 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
--- a/src/mono_print.sml Sun Feb 15 09:27:36 2009 -0500 +++ b/src/mono_print.sml Sun Feb 15 10:32:50 2009 -0500 @@ -308,14 +308,14 @@ 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 @@ 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,
--- a/src/mono_reduce.sml Sun Feb 15 09:27:36 2009 -0500 +++ b/src/mono_reduce.sml Sun Feb 15 10:32:50 2009 -0500 @@ -346,7 +346,7 @@ | 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)),
--- a/src/mono_shake.sml Sun Feb 15 09:27:36 2009 -0500 +++ b/src/mono_shake.sml Sun Feb 15 10:32:50 2009 -0500 @@ -44,7 +44,7 @@ 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)) =>
--- a/src/mono_util.sml Sun Feb 15 09:27:36 2009 -0500 +++ b/src/mono_util.sml Sun Feb 15 10:32:50 2009 -0500 @@ -350,12 +350,14 @@ 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 @@ 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
--- a/src/monoize.sml Sun Feb 15 09:27:36 2009 -0500 +++ b/src/monoize.sml Sun Feb 15 10:32:50 2009 -0500 @@ -2225,12 +2225,28 @@ ((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 + + 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 (n, es, ek), loc), fm) + ((L'.EServerCall (name, es, ek, t), loc), fm) end end @@ -2280,16 +2296,18 @@ 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
--- a/src/pathcheck.sml Sun Feb 15 09:27:36 2009 -0500 +++ b/src/pathcheck.sml Sun Feb 15 10:32:50 2009 -0500 @@ -46,7 +46,7 @@ (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
--- a/src/reduce.sml Sun Feb 15 09:27:36 2009 -0500 +++ b/src/reduce.sml Sun Feb 15 10:32:50 2009 -0500 @@ -368,7 +368,7 @@ | 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
--- a/src/reduce_local.sml Sun Feb 15 09:27:36 2009 -0500 +++ b/src/reduce_local.sml Sun Feb 15 10:32:50 2009 -0500 @@ -131,7 +131,7 @@ | 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
--- a/src/rpcify.sml Sun Feb 15 09:27:36 2009 -0500 +++ b/src/rpcify.sml Sun Feb 15 10:32:50 2009 -0500 @@ -98,6 +98,29 @@ 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 @@ 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)
--- a/src/shake.sml Sun Feb 15 09:27:36 2009 -0500 +++ b/src/shake.sml Sun Feb 15 10:32:50 2009 -0500 @@ -116,7 +116,7 @@ in case e of ENamed n => check n - | EServerCall (n, _, _) => check n + | EServerCall (n, _, _, _) => check n | _ => s end
--- a/tests/rpc.ur Sun Feb 15 09:27:36 2009 -0500 +++ b/tests/rpc.ur Sun Feb 15 10:32:50 2009 -0500 @@ -8,6 +8,8 @@ return <xml><body> <button value="Get It On!" onclick={n <- getNext (); - set s n}/> + set s n}/><br/> + <br/> + Current: <dyn signal={n <- signal s; return <xml>{[n]}</xml>}/> </body></xml> end