summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--jslib/urweb.js3
-rw-r--r--lib/basis.urs11
-rw-r--r--src/compiler.sig1
-rw-r--r--src/compiler.sml3
-rw-r--r--src/elaborate.sml4
-rw-r--r--src/jscomp.sml33
-rw-r--r--src/mono_reduce.sml11
-rw-r--r--src/monoize.sml29
-rw-r--r--tests/dlist.ur22
-rw-r--r--tests/dlist.urp3
10 files changed, 105 insertions, 15 deletions
diff --git a/jslib/urweb.js b/jslib/urweb.js
index 8e39f9f3..0ee19992 100644
--- a/jslib/urweb.js
+++ b/jslib/urweb.js
@@ -13,6 +13,9 @@ function sv(s, v) {
s.v = v;
callAll(s.h);
}
+function sg(s) {
+ return s.v;
+}
function ss(s) {
return s;
diff --git a/lib/basis.urs b/lib/basis.urs
index 9b09e8d2..b4a40fde 100644
--- a/lib/basis.urs
+++ b/lib/basis.urs
@@ -86,6 +86,7 @@ val transaction_monad : monad transaction
con source :: Type -> Type
val source : t ::: Type -> t -> transaction (source t)
val set : t ::: Type -> source t -> t -> transaction unit
+val get : t ::: Type -> source t -> transaction t
con signal :: Type -> Type
val signal_monad : monad signal
@@ -443,6 +444,16 @@ val submit : ctx ::: {Unit} -> use ::: {Type}
-> tag [Value = string, Action = $use -> transaction page]
([Form] ++ ctx) ([Form] ++ ctx) use []
+(*** AJAX-oriented widgets *)
+
+con cformTag = fn (attrs :: {Type}) =>
+ ctx ::: {Unit}
+ -> fn [[Body] ~ ctx] =>
+ unit -> tag attrs ([Body] ++ ctx) [] [] []
+
+val ctextbox : cformTag [Value = string, Size = int, Source = source string]
+val button : cformTag [Value = string, Onclick = transaction unit]
+
(*** Tables *)
val tabl : other ::: {Unit} -> fn [other ~ [Body, Table]] =>
diff --git a/src/compiler.sig b/src/compiler.sig
index c156b268..b126fb51 100644
--- a/src/compiler.sig
+++ b/src/compiler.sig
@@ -107,6 +107,7 @@ signature COMPILER = sig
val toMono_opt3 : (string, Mono.file) transform
val toFuse : (string, Mono.file) transform
val toUntangle2 : (string, Mono.file) transform
+ val toMono_reduce2 : (string, Mono.file) transform
val toMono_shake2 : (string, Mono.file) transform
val toPathcheck : (string, Mono.file) transform
val toCjrize : (string, Cjr.file) transform
diff --git a/src/compiler.sml b/src/compiler.sml
index 6d499283..52181401 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -531,7 +531,8 @@ val toFuse = transform fuse "fuse" o toMono_opt3
val toUntangle2 = transform untangle "untangle2" o toFuse
-val toMono_shake2 = transform mono_shake "mono_shake2" o toUntangle2
+val toMono_reduce2 = transform mono_reduce "mono_reduce2" o toUntangle2
+val toMono_shake2 = transform mono_shake "mono_shake2" o toMono_reduce2
val pathcheck = {
func = (fn file => (PathCheck.check file; file)),
diff --git a/src/elaborate.sml b/src/elaborate.sml
index c18cfb49..39cb85b2 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -3003,10 +3003,10 @@ fun elabDecl (dAll as (d, loc), (env, denv, gs : constraint list)) =
val env = E.pushDatatype env n xs xcs
val d' = (L'.DDatatype (x, n, xs, xcs), loc)
in
- if positive then
+ (*if positive then
()
else
- declError env (Nonpositive d');
+ declError env (Nonpositive d');*)
([d'], (env, denv, gs' @ gs))
end
diff --git a/src/jscomp.sml b/src/jscomp.sml
index 64cb1771..1b675abd 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -37,6 +37,7 @@ structure IS = IntBinarySet
structure IM = IntBinaryMap
val funcs = [(("Basis", "alert"), "alert"),
+ (("Basis", "get_client_source"), "sg"),
(("Basis", "htmlifyBool"), "bs"),
(("Basis", "htmlifyFloat"), "ts"),
(("Basis", "htmlifyInt"), "ts"),
@@ -435,11 +436,22 @@ fun process file =
fail,
str ")"])
- fun deStrcat (e, _) =
+ val jsifyString = String.translate (fn #"\"" => "\\\""
+ | #"\\" => "\\\\"
+ | ch => String.str ch)
+
+ fun jsifyStringMulti (n, s) =
+ case n of
+ 0 => s
+ | _ => jsifyStringMulti (n - 1, jsifyString s)
+
+ fun deStrcat level (all as (e, _)) =
case e of
- EPrim (Prim.String s) => s
- | EStrcat (e1, e2) => deStrcat e1 ^ deStrcat e2
- | _ => raise Fail "Jscomp: deStrcat"
+ EPrim (Prim.String s) => jsifyStringMulti (level, s)
+ | EStrcat (e1, e2) => deStrcat level e1 ^ deStrcat level e2
+ | EFfiApp ("Basis", "jsifyString", [e]) => "\"" ^ deStrcat (level + 1) e ^ "\""
+ | _ => (Print.prefaces "deStrcat" [("e", MonoPrint.p_exp MonoEnv.empty all)];
+ raise Fail "Jscomp: deStrcat")
val quoteExp = quoteExp loc
in
@@ -474,7 +486,8 @@ fun process file =
maxName = #maxName st}
val (e, st) = jsExp mode skip [] 0 (e, st)
- val e = deStrcat e
+ val () = Print.prefaces "Pre-e" [("e", MonoPrint.p_exp MonoEnv.empty e)]
+ val e = deStrcat 0 e
val sc = "_n" ^ Int.toString n ^ "=" ^ e ^ ";\n"
in
@@ -745,14 +758,20 @@ fun process file =
str ")"], st)
end
- | EJavaScript (_, _, SOME _) => (e, st)
+ | EJavaScript (Source _, _, SOME _) => (e, st)
+ | EJavaScript (_, _, SOME e) => ((EFfiApp ("Basis", "jsifyString", [e]), loc), st)
| EClosure _ => unsupported "EClosure"
| EQuery _ => unsupported "Query"
| EDml _ => unsupported "DML"
| ENextval _ => unsupported "Nextval"
| EUnurlify _ => unsupported "EUnurlify"
- | EJavaScript (_, e, _) => unsupported "Nested JavaScript"
+ | EJavaScript (_, e, _) =>
+ let
+ val (e, st) = jsE inner (e, st)
+ in
+ ((EFfiApp ("Basis", "jsifyString", [e]), loc), st)
+ end
| ESignalReturn e =>
let
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index 0117623f..878fec92 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -479,11 +479,12 @@ fun reduce file =
| WriteDb => not writesDb andalso not readsDb andalso verifyCompatible effs
in
(*Print.prefaces "verifyCompatible"
- [("e'", MonoPrint.p_exp env e'),
- ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b),
- ("effs_e'", Print.p_list p_event effs_e'),
- ("effs_b", Print.p_list p_event effs_b)];*)
- if List.null effs_e' orelse verifyCompatible effs_b then
+ [("e'", MonoPrint.p_exp env e'),
+ ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b),
+ ("effs_e'", Print.p_list p_event effs_e'),
+ ("effs_b", Print.p_list p_event effs_b)];*)
+ if List.null effs_e' orelse (List.all (fn eff => eff <> Unsure) effs_e'
+ andalso verifyCompatible effs_b) then
trySub ()
else
e
diff --git a/src/monoize.sml b/src/monoize.sml
index 56310c1b..993034e4 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -1000,6 +1000,18 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
loc)), loc)), loc)), loc),
fm)
end
+ | L.ECApp ((L.EFfi ("Basis", "get"), _), t) =>
+ let
+ val t = monoType env t
+ in
+ ((L'.EAbs ("src", (L'.TSource, loc),
+ (L'.TFun ((L'.TRecord [], loc), t), loc),
+ (L'.EAbs ("_", (L'.TRecord [], loc), t,
+ (L'.EFfiApp ("Basis", "get_client_source",
+ [(L'.ERel 1, loc)]),
+ loc)), loc)), loc),
+ fm)
+ end
| L.EApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "return"), _), _), _), t), _),
(L.EFfi ("Basis", "signal_monad"), _)) =>
@@ -1905,6 +1917,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
| _ => raise Fail "Monoize: Bad dyn attributes")
| "submit" => normal ("input type=\"submit\"", NONE, NONE)
+ | "button" => normal ("input type=\"submit\"", NONE, NONE)
| "textbox" =>
(case targs of
@@ -1978,6 +1991,22 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
| _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
raise Fail "No name passed to lselect tag"))
+ | "ctextbox" =>
+ (case List.find (fn ("Source", _, _) => true | _ => false) attrs of
+ NONE =>
+ let
+ val (ts, fm) = tagStart "input"
+ in
+ ((L'.EStrcat (ts,
+ (L'.EPrim (Prim.String "/>"), loc)),
+ loc), fm)
+ end
+ | SOME (_, src, _) =>
+ (strcat [str "<script>inp(\"input\",",
+ (L'.EJavaScript (L'.Script, src, NONE), loc),
+ str ")</script>"],
+ fm))
+
| "option" => normal ("option", NONE, NONE)
| "tabl" => normal ("table", NONE, NONE)
diff --git a/tests/dlist.ur b/tests/dlist.ur
new file mode 100644
index 00000000..211291bc
--- /dev/null
+++ b/tests/dlist.ur
@@ -0,0 +1,22 @@
+datatype dlist = Nil | Cons of string * source dlist
+
+fun delist dl =
+ case dl of
+ Nil => <xml>[]</xml>
+ | Cons (x, s) => <xml>{[x]} :: {delistSource s}</xml>
+
+and delistSource s = <xml><dyn signal={dl <- signal s; return (delist dl)}/></xml>
+
+fun main () : transaction page =
+ ns <- source Nil;
+ s <- source ns;
+ tb <- source "";
+ return <xml><body>
+ <dyn signal={s <- signal s; return (delistSource s)}/><br/>
+ <br/>
+ <ctextbox source={tb}/>
+ <button value="Add" onclick={hd <- get tb;
+ tl <- get s;
+ s' <- source (Cons (hd, tl));
+ set s s'}/>
+ </body></xml>
diff --git a/tests/dlist.urp b/tests/dlist.urp
new file mode 100644
index 00000000..16037274
--- /dev/null
+++ b/tests/dlist.urp
@@ -0,0 +1,3 @@
+debug
+
+dlist
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-29 05:02:41 +0000