diff options
author | 2009-01-13 15:17:11 -0500 | |
---|---|---|
committer | 2009-01-13 15:17:11 -0500 | |
commit | 0d98ce87ef495ab8652327866b9a2253cbe824d7 (patch) | |
tree | a43e5082a4a3349616ad6b68329b7e363e1e7926 | |
parent | 0d9b4b2f411af95f9a886a3b188f0b2c688be27b (diff) |
Initial experiments with nested <dyn>
-rw-r--r-- | jslib/urweb.js | 3 | ||||
-rw-r--r-- | lib/basis.urs | 11 | ||||
-rw-r--r-- | src/compiler.sig | 1 | ||||
-rw-r--r-- | src/compiler.sml | 3 | ||||
-rw-r--r-- | src/elaborate.sml | 4 | ||||
-rw-r--r-- | src/jscomp.sml | 33 | ||||
-rw-r--r-- | src/mono_reduce.sml | 11 | ||||
-rw-r--r-- | src/monoize.sml | 29 | ||||
-rw-r--r-- | tests/dlist.ur | 22 | ||||
-rw-r--r-- | tests/dlist.urp | 3 |
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 |