summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--lib/js/urweb.js4
-rw-r--r--src/cjr_print.sml53
-rw-r--r--src/jscomp.sml120
-rw-r--r--src/rpcify.sml9
-rw-r--r--tests/rpc2.ur25
-rw-r--r--tests/rpc2.urp5
6 files changed, 185 insertions, 31 deletions
diff --git a/lib/js/urweb.js b/lib/js/urweb.js
index bfca94a4..c78229af 100644
--- a/lib/js/urweb.js
+++ b/lib/js/urweb.js
@@ -129,7 +129,7 @@ function getXHR()
}
}
-function rc(uri, k) {
+function rc(uri, parse, k) {
var xhr = getXHR();
xhr.onreadystatechange = function() {
@@ -142,7 +142,7 @@ function rc(uri, k) {
} catch (e) { }
if (isok)
- k(xhr.responseText);
+ k(parse(xhr.responseText));
else
alert("Error querying remote server!");
}
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index fcd18fb7..c1911c8d 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -863,30 +863,37 @@ fun urlify env t =
val xts = E.lookupStruct env i
- val (blocks, _) = ListUtil.foldlMap
- (fn ((x, t), wasEmpty) =>
- (box [string "{",
- newline,
- p_typ env t,
- space,
- string ("it" ^ Int.toString (level + 1)),
- space,
- string "=",
- space,
- string ("it" ^ Int.toString level ^ ".__uwf_" ^ x ^ ";"),
- newline,
- box (if wasEmpty then
- []
- else
- [string "uw_write(ctx, \"/\");",
- newline]),
- urlify' rf (level + 1) t,
- string "}",
- newline],
- empty t))
- false xts
+ val (blocks, _) = foldl
+ (fn ((x, t), (blocks, printingSinceLastSlash)) =>
+ let
+ val thisEmpty = empty t
+ in
+ if thisEmpty then
+ (blocks, printingSinceLastSlash)
+ else
+ (box [string "{",
+ newline,
+ p_typ env t,
+ space,
+ string ("it" ^ Int.toString (level + 1)),
+ space,
+ string "=",
+ space,
+ string ("it" ^ Int.toString level ^ ".__uwf_" ^ x ^ ";"),
+ newline,
+ box (if printingSinceLastSlash then
+ [string "uw_write(ctx, \"/\");",
+ newline]
+ else
+ []),
+ urlify' rf (level + 1) t,
+ string "}",
+ newline] :: blocks,
+ true)
+ end)
+ ([], false) xts
in
- box blocks
+ box (rev blocks)
end
| TDatatype (Enum, i, _) => box []
diff --git a/src/jscomp.sml b/src/jscomp.sml
index de671fef..9651f930 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -304,6 +304,120 @@ fun process file =
Print.prefaces "Can't embed" [("t", MonoPrint.p_typ MonoEnv.empty t)];
(str loc "ERROR", st))
+ fun unurlifyExp loc (t : typ, st) =
+ case #1 t of
+ TRecord [] => ("null", st)
+ | TRecord [(x, t)] =>
+ let
+ val (e, st) = unurlifyExp loc (t, st)
+ in
+ ("{_" ^ x ^ ":" ^ e ^ "}",
+ st)
+ end
+ | TRecord ((x, t) :: xts) =>
+ let
+ val (e', st) = unurlifyExp loc (t, st)
+ val (es, st) = ListUtil.foldlMap
+ (fn ((x, t), st) =>
+ let
+ val (e, st) = unurlifyExp loc (t, st)
+ in
+ (",_" ^ x ^ ":" ^ e, st)
+ end)
+ st xts
+ in
+ (String.concat ("{_"
+ :: x
+ :: ":"
+ :: e'
+ :: es
+ @ ["}"]), st)
+ end
+
+ | TFfi ("Basis", "string") => ("decode(t[i++])", st)
+ | TFfi ("Basis", "int") => ("parseInt(t[i++])", st)
+ | TFfi ("Basis", "float") => ("parseFloat(t[i++])", st)
+
+ | TFfi ("Basis", "bool") => ("t[i++] == \"True\"", st)
+
+ | TOption t => raise Fail "!!" (*
+ let
+ val (e', st) = quoteExp loc t ((ERel 0, loc), st)
+ in
+ ((ECase (e,
+ [((PNone t, loc),
+ str loc "null"),
+ ((PSome (t, (PVar ("x", t), loc)), loc),
+ if isNullable t then
+ strcat loc [str loc "{v:", e', str loc "}"]
+ else
+ e')],
+ {disc = (TOption t, loc),
+ result = (TFfi ("Basis", "string"), loc)}), loc),
+ st)
+ end*)
+
+ | TDatatype (n, ref (dk, cs)) => raise Fail "!!" (*
+ (case IM.find (#injectors st, n) of
+ SOME n' => ((EApp ((ENamed n', loc), e), loc), st)
+ | NONE =>
+ let
+ val dk = ElabUtil.classifyDatatype cs
+
+ val n' = #maxName st
+ val st = {decls = #decls st,
+ script = #script st,
+ included = #included st,
+ injectors = IM.insert (#injectors st, n, n'),
+ maxName = n' + 1}
+
+ val (pes, st) = ListUtil.foldlMap
+ (fn ((_, cn, NONE), st) =>
+ (((PCon (dk, PConVar cn, NONE), loc),
+ case dk of
+ Option => str loc "null"
+ | _ => str loc (Int.toString cn)),
+ st)
+ | ((_, cn, SOME t), st) =>
+ let
+ val (e, st) = quoteExp loc t ((ERel 0, loc), st)
+ in
+ (((PCon (dk, PConVar cn, SOME (PVar ("x", t), loc)), loc),
+ case dk of
+ Option =>
+ if isNullable t then
+ strcat loc [str loc "{_v:",
+ e,
+ str loc "}"]
+ else
+ e
+ | _ => strcat loc [str loc ("{n:" ^ Int.toString cn
+ ^ ",v:"),
+ e,
+ str loc "}"]),
+ st)
+ end)
+ st cs
+
+ val s = (TFfi ("Basis", "string"), loc)
+ val body = (ECase ((ERel 0, loc), pes,
+ {disc = t, result = s}), loc)
+ val body = (EAbs ("x", t, s, body), loc)
+
+ val st = {decls = (DValRec [("jsify", n', (TFun (t, s), loc),
+ body, "jsify")], loc) :: #decls st,
+ script = #script st,
+ included = #included st,
+ injectors = #injectors st,
+ maxName = #maxName st}
+ in
+ ((EApp ((ENamed n', loc), e), loc), st)
+ end)*)
+
+ | _ => (EM.errorAt loc "Don't know how to unurlify type in JavaScript";
+ Print.prefaces "Can't unurlify" [("t", MonoPrint.p_typ MonoEnv.empty t)];
+ ("ERROR", st))
+
fun jsExp mode skip outer =
let
val len = length outer
@@ -812,11 +926,13 @@ fun process file =
st)
end
- | EServerCall (x, es, ek, _) =>
+ | EServerCall (x, es, ek, t) =>
let
val (ek, st) = jsE inner (ek, st)
+ val (unurl, st) = unurlifyExp loc (t, st)
in
- (strcat [str ("rc(\"" ^ !Monoize.urlPrefix ^ x ^ "\","),
+ (strcat [str ("rc(\"" ^ !Monoize.urlPrefix ^ x ^ "\", function(s){var t=s.split(\"/\");var i=0;return "
+ ^ unurl ^ "},"),
ek,
str ")"],
st)
diff --git a/src/rpcify.sml b/src/rpcify.sml
index 45d178ee..6601a14b 100644
--- a/src/rpcify.sml
+++ b/src/rpcify.sml
@@ -103,8 +103,8 @@ fun frob file =
let
fun doOne ((_, n, t, _, _), tfuncs) =
let
- fun crawl ((t, _), args) =
- case t of
+ fun crawl (t, args) =
+ case #1 t of
CApp ((CFfi ("Basis", "transaction"), _), ran) => SOME (rev args, ran)
| TFun (arg, rest) => crawl (rest, arg :: args)
| _ => NONE
@@ -130,7 +130,7 @@ fun frob file =
trans1), _),
trans2) =>
(case (serverSide trans1, clientSide trans1, serverSide trans2, clientSide trans2) of
- (true, false, false, _) =>
+ (true, false, false, true) =>
let
fun getApp (e, args) =
case #1 e of
@@ -156,7 +156,8 @@ fun frob file =
val ran =
case IM.find (tfuncs, n) of
- NONE => raise Fail "Rpcify: Undetected transaction function"
+ NONE => (Print.prefaces "BAD" [("e", CorePrint.p_exp CoreEnv.empty (e, loc))];
+ raise Fail "Rpcify: Undetected transaction function")
| SOME (_, ran) => ran
in
(EServerCall (n, args, trans2, ran), st)
diff --git a/tests/rpc2.ur b/tests/rpc2.ur
new file mode 100644
index 00000000..47548e76
--- /dev/null
+++ b/tests/rpc2.ur
@@ -0,0 +1,25 @@
+sequence s
+sequence s2
+
+fun dint src = n <- signal src; return <xml>{[n]}</xml>
+
+fun main () : transaction page =
+ let
+ fun getNext () =
+ n <- nextval s;
+ n2 <- nextval s2;
+ return (n, n2)
+ in
+ src1 <- source 0;
+ src2 <- source 0;
+ return <xml><body>
+ <button value="Get It On!"
+ onclick={p <- getNext ();
+ case p of
+ (n1, n2) => set src1 n1;
+ set src2 n2}/>
+ <br/>
+ Current1: <dyn signal={dint src1}/>
+ Current2: <dyn signal={dint src2}/>
+ </body></xml>
+ end
diff --git a/tests/rpc2.urp b/tests/rpc2.urp
new file mode 100644
index 00000000..74f46f98
--- /dev/null
+++ b/tests/rpc2.urp
@@ -0,0 +1,5 @@
+debug
+sql rpc2.sql
+database dbname=rpc2
+
+rpc2
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-18 05:47:03 +0000