Mercurial > urweb
changeset 601:7c3c21eb5b4c
Initial experiments with nested <dyn>
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Tue, 13 Jan 2009 15:17:11 -0500 |
| parents | d1cce194180d |
| children | 1d34d916c206 |
| files | jslib/urweb.js lib/basis.urs src/compiler.sig src/compiler.sml src/elaborate.sml src/jscomp.sml src/mono_reduce.sml src/monoize.sml tests/dlist.ur tests/dlist.urp |
| diffstat | 10 files changed, 105 insertions(+), 15 deletions(-) [+] |
line wrap: on
line diff
--- a/jslib/urweb.js Sun Jan 11 10:41:38 2009 -0500 +++ b/jslib/urweb.js Tue Jan 13 15:17:11 2009 -0500 @@ -13,6 +13,9 @@ s.v = v; callAll(s.h); } +function sg(s) { + return s.v; +} function ss(s) { return s;
--- a/lib/basis.urs Sun Jan 11 10:41:38 2009 -0500 +++ b/lib/basis.urs Tue Jan 13 15:17:11 2009 -0500 @@ -86,6 +86,7 @@ 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 @@ -> 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]] =>
--- a/src/compiler.sig Sun Jan 11 10:41:38 2009 -0500 +++ b/src/compiler.sig Tue Jan 13 15:17:11 2009 -0500 @@ -107,6 +107,7 @@ 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
--- a/src/compiler.sml Sun Jan 11 10:41:38 2009 -0500 +++ b/src/compiler.sml Tue Jan 13 15:17:11 2009 -0500 @@ -531,7 +531,8 @@ 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)),
--- a/src/elaborate.sml Sun Jan 11 10:41:38 2009 -0500 +++ b/src/elaborate.sml Tue Jan 13 15:17:11 2009 -0500 @@ -3003,10 +3003,10 @@ 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
--- a/src/jscomp.sml Sun Jan 11 10:41:38 2009 -0500 +++ b/src/jscomp.sml Tue Jan 13 15:17:11 2009 -0500 @@ -37,6 +37,7 @@ 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 @@ 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 @@ 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 @@ 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
--- a/src/mono_reduce.sml Sun Jan 11 10:41:38 2009 -0500 +++ b/src/mono_reduce.sml Tue Jan 13 15:17:11 2009 -0500 @@ -479,11 +479,12 @@ | 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
--- a/src/monoize.sml Sun Jan 11 10:41:38 2009 -0500 +++ b/src/monoize.sml Tue Jan 13 15:17:11 2009 -0500 @@ -1000,6 +1000,18 @@ 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 @@ | _ => 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 @@ | _ => (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)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/dlist.ur Tue Jan 13 15:17:11 2009 -0500 @@ -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>