summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--lib/basis.urs5
-rw-r--r--src/cjrize.sml4
-rw-r--r--src/jscomp.sml66
-rw-r--r--src/mono.sml9
-rw-r--r--src/mono_print.sml13
-rw-r--r--src/mono_reduce.sml7
-rw-r--r--src/mono_util.sml16
-rw-r--r--src/monoize.sml33
-rw-r--r--tests/sreturn.ur5
-rw-r--r--tests/sreturn.urp3
10 files changed, 133 insertions, 28 deletions
diff --git a/lib/basis.urs b/lib/basis.urs
index ac4c4832..a61bf3ce 100644
--- a/lib/basis.urs
+++ b/lib/basis.urs
@@ -376,6 +376,9 @@ con form = [Body, Form]
con tabl = [Body, Table]
con tr = [Body, Tr]
+val dyn : ctx ::: {Unit} -> use ::: {Type} -> bind ::: {Type} -> unit
+ -> tag [Signal = signal (xml ctx use bind)] ctx [] use bind
+
val head : unit -> tag [] html head [] []
val title : unit -> tag [] head [] [] []
@@ -433,7 +436,7 @@ con select = [Select]
val select : formTag string select []
val option : unit -> tag [Value = string, Selected = bool] select [] [] []
-val submit : ctx ::: {Unit} -> use ::: {Type}
+val submit : ctx ::: {Unit} -> use ::: {Type}
-> fn [[Form] ~ ctx] =>
unit
-> tag [Value = string, Action = $use -> transaction page]
diff --git a/src/cjrize.sml b/src/cjrize.sml
index 1152b0ef..f3c5e5a7 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -120,6 +120,7 @@ fun cifyTyp x =
in
((L'.TOption t, loc), sm)
end
+ | L.TSignal _ => raise Fail "Cjrize: TSignal remains"
in
cify IM.empty x
end
@@ -420,7 +421,8 @@ fun cifyExp (eAll as (e, loc), sm) =
((L'.EUnurlify (e, t), loc), sm)
end
- | L.EJavaScript _ => raise Fail "EJavaScript remains"
+ | L.EJavaScript _ => raise Fail "Cjrize: EJavaScript remains"
+ | L.ESignalReturn _ => raise Fail "Cjrize: ESignalReturn remains"
fun cifyDecl ((d, loc), sm) =
case d of
diff --git a/src/jscomp.sml b/src/jscomp.sml
index 0dd7882a..b0842c6b 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -69,8 +69,15 @@ fun varDepth (e, _) =
| ENextval _ => 0
| EUnurlify _ => 0
| EJavaScript _ => 0
+ | ESignalReturn e => varDepth e
-fun jsExp inAttr outer =
+fun strcat loc es =
+ case es of
+ [] => (EPrim (Prim.String ""), loc)
+ | [x] => x
+ | x :: es' => (EStrcat (x, strcat loc es'), loc)
+
+fun jsExp mode outer =
let
val len = length outer
@@ -85,11 +92,7 @@ fun jsExp inAttr outer =
PConVar n => str (Int.toString n)
| PConFfi {con, ...} => str ("\"_" ^ con ^ "\"")
- fun strcat es =
- case es of
- [] => (EPrim (Prim.String ""), loc)
- | [x] => x
- | x :: es' => (EStrcat (x, strcat es'), loc)
+
fun isNullable (t, _) =
case t of
@@ -99,17 +102,19 @@ fun jsExp inAttr outer =
fun unsupported s =
(EM.errorAt loc (s ^ " in code to be compiled to JavaScript");
(str "ERROR", st))
+
+ val strcat = strcat loc
in
case #1 e of
EPrim (Prim.String s) =>
(str ("\""
^ String.translate (fn #"'" =>
- if inAttr then
+ if mode = Attribute then
"\\047"
else
"'"
| #"<" =>
- if inAttr then
+ if mode = Script then
"<"
else
"\\074"
@@ -274,7 +279,14 @@ fun jsExp inAttr outer =
st)
end
- | EWrite _ => unsupported "EWrite"
+ | EWrite e =>
+ let
+ val (e, st) = jsE inner (e, st)
+ in
+ (strcat [str "document.write(",
+ e,
+ str ")"], st)
+ end
| ESeq (e1, e2) =>
let
@@ -301,6 +313,15 @@ fun jsExp inAttr outer =
| ENextval _ => unsupported "Nextval"
| EUnurlify _ => unsupported "EUnurlify"
| EJavaScript _ => unsupported "Nested JavaScript"
+ | ESignalReturn e =>
+ let
+ val (e, st) = jsE inner (e, st)
+ in
+ (strcat [(*str "sreturn(",*)
+ e(*,
+ str ")"*)],
+ st)
+ end
end
in
jsE
@@ -309,14 +330,25 @@ fun jsExp inAttr outer =
val decl : state -> decl -> decl * state =
U.Decl.foldMapB {typ = fn x => x,
exp = fn (env, e, st) =>
- case e of
- EJavaScript (EAbs (_, t, _, e), _) =>
- let
- val (e, st) = jsExp true (t :: env) 0 (e, st)
- in
- (#1 e, st)
- end
- | _ => (e, st),
+ let
+ fun doCode m env e =
+ let
+ val len = length env
+ fun str s = (EPrim (Prim.String s), #2 e)
+
+ val locals = List.tabulate
+ (varDepth e,
+ fn i => str ("var uwr" ^ Int.toString (len + i) ^ ";"))
+ val (e, st) = jsExp m env 0 (e, st)
+ in
+ (#1 (strcat (#2 e) (locals @ [e])), st)
+ end
+ in
+ case e of
+ EJavaScript (m, (EAbs (_, t, _, e), _)) => doCode m (t :: env) e
+ | EJavaScript (m, e) => doCode m env e
+ | _ => (e, st)
+ end,
decl = fn (_, e, st) => (e, st),
bind = fn (env, U.Decl.RelE (_, t)) => t :: env
| (env, _) => env}
diff --git a/src/mono.sml b/src/mono.sml
index 187b1853..c6e0ae8a 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -37,6 +37,7 @@ datatype typ' =
| TDatatype of int * (datatype_kind * (string * int * typ option) list) ref
| TFfi of string * string
| TOption of typ
+ | TSignal of typ
withtype typ = typ' located
@@ -55,6 +56,11 @@ datatype pat' =
withtype pat = pat' located
+datatype javascript_mode =
+ Attribute
+ | Script
+ | File
+
datatype exp' =
EPrim of Prim.t
| ERel of int
@@ -96,8 +102,9 @@ datatype exp' =
| EUnurlify of exp * typ
- | EJavaScript of exp
+ | EJavaScript of javascript_mode * exp
+ | ESignalReturn of exp
withtype exp = exp' located
diff --git a/src/mono_print.sml b/src/mono_print.sml
index 7b675438..89b6c35b 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -65,6 +65,9 @@ fun p_typ' par env (t, _) =
| TOption t => box [string "option(",
p_typ env t,
string ")"]
+ | TSignal t => box [string "signal(",
+ p_typ env t,
+ string ")"]
and p_typ env = p_typ' false env
@@ -275,9 +278,13 @@ fun p_exp' par env (e, _) =
| EUnurlify (e, _) => box [string "unurlify(",
p_exp env e,
string ")"]
- | EJavaScript e => box [string "JavaScript(",
- p_exp env e,
- string ")"]
+ | EJavaScript (_, e) => box [string "JavaScript(",
+ p_exp env e,
+ string ")"]
+
+ | ESignalReturn e => box [string "Return(",
+ p_exp env e,
+ string ")"]
and p_exp env = p_exp' false env
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index 040414f3..e1da02c9 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -75,7 +75,8 @@ fun impure (e, _) =
| ELet (_, _, e1, e2) => impure e1 orelse impure e2
| EClosure (_, es) => List.exists impure es
- | EJavaScript e => impure e
+ | EJavaScript (_, e) => impure e
+ | ESignalReturn e => impure e
val liftExpInExp = Monoize.liftExpInExp
@@ -330,7 +331,8 @@ fun reduce file =
| EDml e => summarize d e @ [WriteDb]
| ENextval e => summarize d e @ [WriteDb]
| EUnurlify (e, _) => summarize d e
- | EJavaScript e => summarize d e
+ | EJavaScript (_, e) => summarize d e
+ | ESignalReturn e => summarize d e
fun exp env e =
@@ -421,6 +423,7 @@ fun reduce file =
fun trySub () =
case t of
(TFfi ("Basis", "string"), _) => doSub ()
+ | (TSignal _, _) => e
| _ =>
case e' of
(ECase _, _) => e
diff --git a/src/mono_util.sml b/src/mono_util.sml
index ebc30984..553f802e 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -51,6 +51,7 @@ fun compare ((t1, _), (t2, _)) =
| (TDatatype (n1, _), TDatatype (n2, _)) => Int.compare (n1, n2)
| (TFfi (m1, x1), TFfi (m2, x2)) => join (String.compare (m1, m2), fn () => String.compare (x1, x2))
| (TOption t1, TOption t2) => compare (t1, t2)
+ | (TSignal t1, TSignal t2) => compare (t1, t2)
| (TFun _, _) => LESS
| (_, TFun _) => GREATER
@@ -64,6 +65,9 @@ fun compare ((t1, _), (t2, _)) =
| (TFfi _, _) => LESS
| (_, TFfi _) => GREATER
+ | (TOption _, _) => LESS
+ | (_, TOption _) => GREATER
+
and compareFields ((x1, t1), (x2, t2)) =
join (String.compare (x1, x2),
fn () => compare (t1, t2))
@@ -96,6 +100,10 @@ fun mapfold fc =
S.map2 (mft t,
fn t' =>
(TOption t, loc))
+ | TSignal t =>
+ S.map2 (mft t,
+ fn t' =>
+ (TSignal t, loc))
in
mft
end
@@ -311,10 +319,14 @@ fun mapfoldB {typ = fc, exp = fe, bind} =
S.map2 (mft t,
fn t' =>
(EUnurlify (e', t'), loc)))
- | EJavaScript e =>
+ | EJavaScript (m, e) =>
+ S.map2 (mfe ctx e,
+ fn e' =>
+ (EJavaScript (m, e'), loc))
+ | ESignalReturn e =>
S.map2 (mfe ctx e,
fn e' =>
- (EJavaScript e', loc))
+ (ESignalReturn e', loc))
in
mfe
end
diff --git a/src/monoize.sml b/src/monoize.sml
index e92a1c8a..1b7b467d 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -135,6 +135,8 @@ fun monoType env =
(L'.TFun ((L'.TRecord [], loc), mt env dtmap t), loc)
| L.CApp ((L.CFfi ("Basis", "source"), _), t) =>
(L'.TFfi ("Basis", "int"), loc)
+ | L.CApp ((L.CFfi ("Basis", "signal"), _), t) =>
+ (L'.TSignal (mt env dtmap t), loc)
| L.CApp ((L.CFfi ("Basis", "http_cookie"), _), _) =>
(L'.TFfi ("Basis", "string"), loc)
| L.CApp ((L.CFfi ("Basis", "sql_table"), _), _) =>
@@ -978,6 +980,16 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
fm)
end
+ | L.EApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "return"), _), _), _), t), _),
+ (L.EFfi ("Basis", "signal_monad"), _)) =>
+ let
+ val t = monoType env t
+ in
+ ((L'.EAbs ("x", t, (L'.TSignal t, loc),
+ (L'.ESignalReturn (L'.ERel 0, loc), loc)), loc),
+ fm)
+ end
+
| L.ECApp ((L.EFfi ("Basis", "getCookie"), _), t) =>
let
val s = (L'.TFfi ("Basis", "string"), loc)
@@ -1752,7 +1764,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
(L'.EStrcat (
(L'.EPrim (Prim.String s'), loc),
(L'.EStrcat (
- (L'.EJavaScript e, loc),
+ (L'.EJavaScript (L'.Attribute, e), loc),
(L'.EPrim (Prim.String "'"), loc)), loc)),
loc)), loc),
fm)
@@ -1833,6 +1845,25 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
case tag of
"body" => normal ("body", NONE,
SOME (L'.EFfiApp ("Basis", "get_script", [(L'.ERecord [], loc)]), loc))
+
+ | "dyn" =>
+ (case #1 attrs of
+ (*L'.ERecord [("Signal", (L'.ESignalReturn e, _), _)] => (e, fm)
+ | L'.ERecord [("Signal", (L'.EApp ((L'.EAbs (_, _, _, (L'.ESignalReturn (L'.ERel 0, _), _)), _),
+ e), _), _)] => (e, fm) *)
+
+ L'.ERecord [("Signal", e, _)] =>
+ ((L'.EStrcat
+ ((L'.EPrim (Prim.String "<script type=\"text/javascript\">"), loc),
+ (L'.EStrcat ((L'.EJavaScript (L'.Script,
+ (L'.ELet ("signal", (L'.TSignal
+ (L'.TFfi ("Basis", "string"), loc),
+ loc),
+ e,
+ (L'.EWrite (L'.ERel 0, loc), loc)), loc)), loc),
+ (L'.EPrim (Prim.String "</script>"), loc)), loc)), loc),
+ fm)
+ | _ => raise Fail "Monoize: Bad dyn attributes")
| "submit" => normal ("input type=\"submit\"", NONE, NONE)
diff --git a/tests/sreturn.ur b/tests/sreturn.ur
new file mode 100644
index 00000000..62db377d
--- /dev/null
+++ b/tests/sreturn.ur
@@ -0,0 +1,5 @@
+fun main () : transaction page = return <xml><body>
+ <p>Before</p>
+ <p><dyn signal={return <xml>Hi!</xml>}/></p>
+ <p>After</p>
+</body></xml>
diff --git a/tests/sreturn.urp b/tests/sreturn.urp
new file mode 100644
index 00000000..5591aa5e
--- /dev/null
+++ b/tests/sreturn.urp
@@ -0,0 +1,3 @@
+debug
+
+sreturn
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-04 05:39:19 +0000