Mercurial > urweb
changeset 847:0f7e2cca6d9b
<dyn> inside <table>; fix Specialize bug with datatype decls generating other mutually-recursive datatype decls
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Sat, 13 Jun 2009 14:29:36 -0400 |
| parents | 0d30e6338c65 |
| children | e8594cfa3236 |
| files | lib/js/urweb.js lib/ur/basis.urs src/jscomp.sml src/list_util.sig src/list_util.sml src/monoize.sml src/specialize.sml tests/tbody.ur tests/tbody.urp |
| diffstat | 9 files changed, 87 insertions(+), 25 deletions(-) [+] |
line wrap: on
line diff
--- a/lib/js/urweb.js Tue Jun 09 18:11:59 2009 -0400 +++ b/lib/js/urweb.js Sat Jun 13 14:29:36 2009 -0400 @@ -278,15 +278,20 @@ for (var ls = x.closures; ls; ls = ls.next) freeClosure(ls.data); - var spans = x.getElementsByTagName("span"); - for (var i = 0; i < spans.length; ++i) { - var span = spans[i]; - span.dead = true; - for (var ls = span.sources; ls; ls = ls.next) - ls.data.dyns = remove(span, ls.data.dyns); - for (var ls = span.closures; ls; ls = ls.next) - freeClosure(ls.data); - } + var doKind = function(kind) { + var arr = x.getElementsByTagName(kind); + for (var i = 0; i < arr.length; ++i) { + var span = arr[i]; + span.dead = true; + for (var ls = span.sources; ls; ls = ls.next) + ls.data.dyns = remove(span, ls.data.dyns); + for (var ls = span.closures; ls; ls = ls.next) + freeClosure(ls.data); + } + }; + + doKind("span"); + doKind("tbody"); var cls = {v : null}; x.innerHTML = flatten(cls, v);
--- a/lib/ur/basis.urs Tue Jun 09 18:11:59 2009 -0400 +++ b/lib/ur/basis.urs Sat Jun 13 14:29:36 2009 -0400 @@ -530,8 +530,8 @@ val bless : string -> url val checkUrl : string -> option url -val dyn : use ::: {Type} -> bind ::: {Type} -> unit - -> tag [Signal = signal (xml body use bind)] body [] use bind +val dyn : ctx ::: {Unit} -> use ::: {Type} -> bind ::: {Type} -> [ctx ~ body] => unit + -> tag [Signal = signal (xml (body ++ ctx) use bind)] (body ++ ctx) [] use bind val head : unit -> tag [] html head [] [] val title : unit -> tag [] head [] [] []
--- a/src/jscomp.sml Tue Jun 09 18:11:59 2009 -0400 +++ b/src/jscomp.sml Sat Jun 13 14:29:36 2009 -0400 @@ -171,6 +171,13 @@ exception CantEmbed of typ +fun inString {needle, haystack} = + let + val (_, suffix) = Substring.position needle (Substring.full haystack) + in + not (Substring.isEmpty suffix) + end + fun process file = let val (someTs, nameds) = @@ -1086,7 +1093,14 @@ fun exp outer (e as (_, loc), st) = ((*Print.preface ("exp", MonoPrint.p_exp MonoEnv.empty e);*) case #1 e of - EPrim _ => (e, st) + EPrim p => + (case p of + Prim.String s => if inString {needle = "<script", haystack = s} then + foundJavaScript := true + else + () + | _ => (); + (e, st)) | ERel _ => (e, st) | ENamed _ => (e, st) | ECon (_, _, NONE) => (e, st)
--- a/src/list_util.sig Tue Jun 09 18:11:59 2009 -0400 +++ b/src/list_util.sig Sat Jun 13 14:29:36 2009 -0400 @@ -37,6 +37,8 @@ val foldlMap : ('data1 * 'state -> 'data2 * 'state) -> 'state -> 'data1 list -> 'data2 list * 'state val foldlMapPartial : ('data1 * 'state -> 'data2 option * 'state) -> 'state -> 'data1 list -> 'data2 list * 'state val foldlMapConcat : ('data1 * 'state -> 'data2 list * 'state) -> 'state -> 'data1 list -> 'data2 list * 'state + val foldlMapAbort : ('data1 * 'state -> ('data2 * 'state) option) + -> 'state -> 'data1 list -> ('data2 list * 'state) option val search : ('a -> 'b option) -> 'a list -> 'b option val searchi : (int * 'a -> 'b option) -> 'a list -> 'b option
--- a/src/list_util.sml Tue Jun 09 18:11:59 2009 -0400 +++ b/src/list_util.sml Sat Jun 13 14:29:36 2009 -0400 @@ -123,6 +123,19 @@ fm ([], s) end +fun foldlMapAbort f s = + let + fun fm (ls', s) ls = + case ls of + nil => SOME (rev ls', s) + | h :: t => + case f (h, s) of + NONE => NONE + | SOME (h', s') => fm (h' :: ls', s') t + in + fm ([], s) + end + fun search f = let fun s ls =
--- a/src/monoize.sml Tue Jun 09 18:11:59 2009 -0400 +++ b/src/monoize.sml Sat Jun 13 14:29:36 2009 -0400 @@ -2595,11 +2595,24 @@ | "dyn" => (case attrs of [("Signal", e, _)] => - ((L'.EStrcat - ((L'.EPrim (Prim.String "<span><script type=\"text/javascript\">dyn("), loc), - (L'.EStrcat ((L'.EJavaScript (L'.Script, e), loc), - (L'.EPrim (Prim.String ")</script></span>"), loc)), loc)), loc), - fm) + let + val inTable = case targs of + (L.CRecord (_, ctx), _) :: _ => + List.exists (fn ((L.CName "Table", _), _) => true + | _ => false) ctx + | _ => false + + val tag = if inTable then + "tbody" + else + "span" + in + ((L'.EStrcat + ((L'.EPrim (Prim.String ("<" ^ tag ^ "><script type=\"text/javascript\">dyn(")), loc), + (L'.EStrcat ((L'.EJavaScript (L'.Script, e), loc), + (L'.EPrim (Prim.String (")</script></" ^ tag ^ ">")), loc)), loc)), loc), + fm) + end | _ => raise Fail "Monoize: Bad dyn attributes") | "submit" => normal ("input type=\"submit\"", NONE, NONE)
--- a/src/specialize.sml Tue Jun 09 18:11:59 2009 -0400 +++ b/src/specialize.sml Sat Jun 13 14:29:36 2009 -0400 @@ -246,15 +246,12 @@ let (*val () = Print.preface ("decl:", CorePrint.p_decl CoreEnv.empty all)*) val (d, st) = specDecl st d - - val ds = - case #decls st of - [] => [] - | dts => [(DDatatype dts, #2 d)] in case #1 d of DDatatype dts => - (rev (d :: ds), + ((case #decls st of + [] => [d] + | dts' => [(DDatatype (dts' @ dts), #2 d)]), {count = #count st, datatypes = foldl (fn ((x, n, xs, xnts), dts) => IM.insert (dts, n, @@ -270,7 +267,9 @@ (#constructors st) dts, decls = []}) | _ => - (rev (d :: ds), + (case #decls st of + [] => [d] + | dts => [(DDatatype dts, #2 d), d], {count = #count st, datatypes = #datatypes st, constructors = #constructors st, @@ -286,5 +285,4 @@ ds end - end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/tbody.ur Sat Jun 13 14:29:36 2009 -0400 @@ -0,0 +1,13 @@ +fun main () : transaction page = + s <- source []; + entry <- source ""; + return <xml><body> + <table> + <dyn signal={s <- signal s; + return (List.mapX (fn s => <xml><tr><td>{[s]}</td></tr></xml>) s)}/> + </table> + + Add one: <ctextbox source={entry}/> <button onclick={e <- get entry; + v <- get s; + set s (e :: v)}/> + </body></xml>