From 7bfdd9349b08b82f4e8fceb75749c17f8e8324e2 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(-) 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