summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/cjr_print.sml73
-rw-r--r--src/jscomp.sml114
-rw-r--r--tests/rpcDE.ur30
-rw-r--r--tests/rpcDE.urp5
4 files changed, 126 insertions, 96 deletions
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index c1911c8d..8b15af4d 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -501,25 +501,32 @@ fun p_ensql t e =
fun notLeaky env allowHeapAllocated =
let
- fun nl (t, _) =
+ fun nl ok (t, _) =
case t of
TFun _ => false
| TRecord n =>
let
val xts = E.lookupStruct env n
in
- List.all (fn (_, t) => nl t) xts
+ List.all (fn (_, t) => nl ok t) xts
end
- | TDatatype (dk, _, ref cons) =>
- (allowHeapAllocated orelse dk = Enum)
- andalso List.all (fn (_, _, to) => case to of
- NONE => true
- | SOME t => nl t) cons
+ | TDatatype (dk, n, ref cons) =>
+ IS.member (ok, n)
+ orelse
+ ((allowHeapAllocated orelse dk = Enum)
+ andalso
+ let
+ val ok' = IS.add (ok, n)
+ in
+ List.all (fn (_, _, to) => case to of
+ NONE => true
+ | SOME t => nl ok' t) cons
+ end)
| TFfi ("Basis", "string") => false
| TFfi _ => true
- | TOption t => allowHeapAllocated andalso nl t
+ | TOption t => allowHeapAllocated andalso nl ok t
in
- nl
+ nl IS.empty
end
fun capitalize s =
@@ -896,33 +903,29 @@ fun urlify env t =
box (rev blocks)
end
- | TDatatype (Enum, i, _) => box []
- (*let
+ | TDatatype (Enum, i, _) =>
+ let
val (x, xncs) = E.lookupDatatype env i
fun doEm xncs =
case xncs of
- [] => string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype "
- ^ x ^ "\"), (enum __uwe_"
- ^ x ^ "_" ^ Int.toString i ^ ")0)")
+ [] => box [string ("uw_error(ctx, FATAL, \"Error urlifying datatype "
+ ^ x ^ "\");"),
+ newline]
| (x', n, to) :: rest =>
- box [string "((!strncmp(request, \"",
- string x',
- string "\", ",
- string (Int.toString (size x')),
- string ") && (request[",
- string (Int.toString (size x')),
- string "] == 0 || request[",
- string (Int.toString (size x')),
- string ("] == '/')) ? __uwc_" ^ ident x' ^ "_" ^ Int.toString n),
- space,
- string ":",
- space,
- doEm rest,
- string ")"]
+ box [string ("if (it" ^ Int.toString level
+ ^ "==__uwc_" ^ ident x' ^ "_" ^ Int.toString n ^ ") {"),
+ newline,
+ box [string ("uw_write(ctx, \"" ^ x' ^ "\");"),
+ newline],
+ string "} else {",
+ newline,
+ box [doEm rest,
+ newline],
+ string "}"]
in
doEm xncs
- end*)
+ end
| TDatatype (Option, i, xncs) => box []
(*if IS.member (rf, i) then
@@ -1453,7 +1456,7 @@ fun p_exp' par env (e, loc) =
val tables = ListUtil.mapConcat (fn (x, xts) =>
map (fn (x', t) => ("__uwf_" ^ ident x ^ ".__uwf_" ^ ident x', t)) xts)
tables
-
+
val outputs = exps @ tables
val outputs = ListMergeSort.sort (fn ((s1, _), (s2, _)) => String.compare (s1, s2) = GREATER) outputs
@@ -1837,9 +1840,9 @@ fun p_fun env (fx, n, args, ran, e) =
space,
string "{",
newline,
- box[string "return(",
- p_exp env' e,
- string ");"],
+ box [string "return(",
+ p_exp env' e,
+ string ");"],
newline,
string "}"]
end
@@ -2164,8 +2167,8 @@ fun is_not_null t =
fun p_file env (ds, ps) =
let
val (pds, env) = ListUtil.foldlMap (fn (d, env) =>
- (p_decl env d,
- E.declBinds env d))
+ (p_decl env d,
+ E.declBinds env d))
env ds
val fields = foldl (fn ((ek, _, _, ts, _), fields) =>
diff --git a/src/jscomp.sml b/src/jscomp.sml
index 383a9f6f..1a85bba2 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -64,6 +64,7 @@ type state = {
script : string list,
included : IS.set,
injectors : int IM.map,
+ decoders : int IM.map,
maxName : int
}
@@ -251,13 +252,12 @@ fun process file =
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'),
+ decoders = #decoders st,
maxName = n' + 1}
val (pes, st) = ListUtil.foldlMap
@@ -275,7 +275,7 @@ fun process file =
case dk of
Option =>
if isNullable t then
- strcat loc [str loc "{_v:",
+ strcat loc [str loc "{v:",
e,
str loc "}"]
else
@@ -298,6 +298,7 @@ fun process file =
script = #script st,
included = #included st,
injectors = #injectors st,
+ decoders= #decoders st,
maxName = #maxName st}
in
((EApp ((ENamed n', loc), e), loc), st)
@@ -321,13 +322,13 @@ fun process file =
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
+ (fn ((x, t), st) =>
+ let
+ val (e, st) = unurlifyExp loc (t, st)
+ in
+ (",_" ^ x ^ ":" ^ e, st)
+ end)
+ st xts
in
(String.concat ("{_"
:: x
@@ -343,79 +344,66 @@ fun process file =
| TFfi ("Basis", "bool") => ("t[i++] == \"True\"", st)
- | TOption t => raise Fail "!!" (*
+ | TOption t =>
let
- val (e', st) = quoteExp loc t ((ERel 0, loc), st)
+ val (e, st) = unurlifyExp loc (t, st)
+ val e = if isNullable t then
+ "{v:" ^ e ^ "}"
+ else
+ e
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*)
+ ("(uu=t[i++],uu==\"Some\"?" ^ e ^ ":null)", 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)
+ | TDatatype (n, ref (dk, cs)) =>
+ (case IM.find (#decoders st, n) of
+ SOME n' => ("(tmp=_n" ^ Int.toString n' ^ "(t,i),i=tmp._1,tmp._2)", 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'),
+ injectors = #injectors st,
+ decoders = IM.insert (#decoders 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)),
+ val (e, st) = foldl (fn ((x, cn, NONE), (e, st)) =>
+ ("x==\"" ^ x ^ "\"?"
+ ^ (case dk of
+ Option => "null"
+ | _ => Int.toString cn)
+ ^ ":" ^ e,
st)
- | ((_, cn, SOME t), st) =>
+ | ((x, cn, SOME t), (e, st)) =>
let
- val (e, st) = quoteExp loc t ((ERel 0, loc), st)
+ val (e', st) = unurlifyExp loc (t, 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 "}"]),
+ ("x==\"" ^ x ^ "\"?"
+ ^ (case dk of
+ Option =>
+ if isNullable t then
+ "{v:" ^ e' ^ "}"
+ else
+ e'
+ | _ => "{n:" ^ Int.toString cn ^ ",v:" ^ e' ^ "}")
+ ^ ":" ^ e,
st)
end)
- st cs
+ ("pf()", 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 body = "function _n" ^ Int.toString n' ^ "(t,i){var x=t[i++];var r="
+ ^ e ^ ";return {_1:i,_2:r}}\n\n"
- val st = {decls = (DValRec [("jsify", n', (TFun (t, s), loc),
- body, "jsify")], loc) :: #decls st,
- script = #script st,
+ val st = {decls = #decls st,
+ script = body :: #script st,
included = #included st,
injectors = #injectors st,
+ decoders = #decoders st,
maxName = #maxName st}
in
- ((EApp ((ENamed n', loc), e), loc), st)
- end)*)
+ ("(tmp=_n" ^ Int.toString n' ^ "(t,i),i=tmp._1,tmp._2)", 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)];
@@ -602,6 +590,7 @@ fun process file =
script = #script st,
included = IS.add (#included st, n),
injectors = #injectors st,
+ decoders = #decoders st,
maxName = #maxName st}
val (e, st) = jsExp mode skip [] 0 (e, st)
@@ -613,6 +602,7 @@ fun process file =
script = sc :: #script st,
included = #included st,
injectors = #injectors st,
+ decoders= #decoders st,
maxName = #maxName st}
end
in
@@ -986,6 +976,7 @@ fun process file =
script = #script st,
included = #included st,
injectors = #injectors st,
+ decoders = #decoders st,
maxName = #maxName st})
end
@@ -994,6 +985,7 @@ fun process file =
script = [],
included = IS.empty,
injectors = IM.empty,
+ decoders = IM.empty,
maxName = U.File.maxName file + 1}
file
diff --git a/tests/rpcDE.ur b/tests/rpcDE.ur
new file mode 100644
index 00000000..64e190f5
--- /dev/null
+++ b/tests/rpcDE.ur
@@ -0,0 +1,30 @@
+datatype result = Neg | Zero | Pos
+
+table t : {A : int}
+
+fun main () : transaction page =
+ let
+ fun check () =
+ r <- oneRow (SELECT SUM(t.A) AS X FROM t);
+ return (if r.X < 0 then
+ Neg
+ else if r.X = 0 then
+ Zero
+ else
+ Pos)
+
+ fun show r =
+ case r of
+ Neg => <xml>-</xml>
+ | Zero => <xml>0</xml>
+ | Pos => <xml>+</xml>
+ in
+ s <- source Zero;
+ return <xml><body>
+ <button value="Get It On!"
+ onclick={r <- check ();
+ set s r}/><br/>
+ <br/>
+ Current: <dyn signal={r <- signal s; return (show r)}/>
+ </body></xml>
+ end
diff --git a/tests/rpcDE.urp b/tests/rpcDE.urp
new file mode 100644
index 00000000..2027ff85
--- /dev/null
+++ b/tests/rpcDE.urp
@@ -0,0 +1,5 @@
+debug
+sql rpcDE.sql
+database dbname=rpcde
+
+rpcDE
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-31 06:53:54 +0000