summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2009-02-15 10:32:50 -0500
committerGravatar Adam Chlipala <adamc@hcoop.net>2009-02-15 10:32:50 -0500
commit7bfdd9349b08b82f4e8fceb75749c17f8e8324e2 (patch)
tree97a0ff4ed73faa83667f997d5fa13306ba98789b
parent4d6b4140314ee47c6278d75a196fb81da3fedc26 (diff)
First gimpy RPC
Diffstat
-rw-r--r--lib/js/urweb.js29
-rw-r--r--src/cjr.sml2
-rw-r--r--src/cjr_print.sml32
-rw-r--r--src/cjrize.sml5
-rw-r--r--src/core.sml2
-rw-r--r--src/core_print.sml16
-rw-r--r--src/core_util.sml10
-rw-r--r--src/jscomp.sml14
-rw-r--r--src/mono.sml4
-rw-r--r--src/mono_print.sml46
-rw-r--r--src/mono_reduce.sml2
-rw-r--r--src/mono_shake.sml2
-rw-r--r--src/mono_util.sml16
-rw-r--r--src/monoize.sml38
-rw-r--r--src/pathcheck.sml2
-rw-r--r--src/reduce.sml2
-rw-r--r--src/reduce_local.sml2
-rw-r--r--src/rpcify.sml30
-rw-r--r--src/shake.sml2
-rw-r--r--tests/rpc.ur4
-rw-r--r--tests/rpc.urp2
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, \"<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 @@ 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, \"</html>\");",
- newline,
+ box (case ek of
+ Core.Rpc => []
+ | _ => [string "uw_write(ctx, \"</html>\");",
+ 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 <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
diff --git a/tests/rpc.urp b/tests/rpc.urp
index 16b72b8b..02fd0f2b 100644
--- a/tests/rpc.urp
+++ b/tests/rpc.urp
@@ -1,5 +1,5 @@
debug
sql rpc.sql
-database rpc
+database dbname=rpc
rpc
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-29 08:57:16 +0000