Mercurial > urweb
changeset 916:b873feb3eb52
dragList almost kinda works
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Tue, 08 Sep 2009 10:18:19 -0400 |
| parents | 5e8b6fa5b48f |
| children | 321a2d6feb40 |
| files | demo/more/dragList.ur demo/more/dragList.urp demo/more/dragList.urs lib/ur/list.ur lib/ur/list.urs src/c/urweb.c src/compiler.sig src/compiler.sml src/mono_reduce.sml src/monoize.sml |
| diffstat | 10 files changed, 151 insertions(+), 43 deletions(-) [+] |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/demo/more/dragList.ur Tue Sep 08 10:18:19 2009 -0400 @@ -0,0 +1,33 @@ +fun draggableList title items = + itemSources <- List.mapM source items; + draggingItem <- source None; + return <xml> + <h2>Great {[title]}</h2> + <ul> + {List.mapX (fn itemSource => <xml> + <li onmousedown={set draggingItem (Some itemSource)} + onmouseup={set draggingItem None} + onmouseover={di <- get draggingItem; + case di of + None => return () + | Some di => item1 <- get di; + item2 <- get itemSource; + set di item2; + set itemSource item1}> + <dyn signal={s <- signal itemSource; return <xml>{[s]}</xml>}/> + </li></xml>) itemSources} + </ul> + </xml> + +fun main () = + bears <- draggableList "Bears" ("Pooh" :: "Paddington" :: "Rupert" :: "Edward" :: []); + beers <- draggableList "Beers" ("Budvar" :: "Delirium Tremens" :: "Deuchars" :: []); + boars <- draggableList "Boars" ("Sus scrofa scrofa" + :: "Sus scrofa ussuricus" + :: "Sus scrofa cristatus" + :: "Sus scrofa taiwanus" :: []); + return <xml><body> + {bears} + {beers} + {boars} + </body></xml>
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/demo/more/dragList.urp Tue Sep 08 10:18:19 2009 -0400 @@ -0,0 +1,4 @@ +debug + +$/list +dragList
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/demo/more/dragList.urs Tue Sep 08 10:18:19 2009 -0400 @@ -0,0 +1,1 @@ +val main : unit -> transaction page
--- a/lib/ur/list.ur Tue Sep 08 07:48:57 2009 -0400 +++ b/lib/ur/list.ur Tue Sep 08 10:18:19 2009 -0400 @@ -44,6 +44,16 @@ foldlAbort' end +val length = fn [a] => + let + fun length' acc (ls : list a) = + case ls of + [] => acc + | _ :: ls => length' (acc + 1) ls + in + length' 0 + end + val rev = fn [a] => let fun rev' acc (ls : list a) =
--- a/lib/ur/list.urs Tue Sep 08 07:48:57 2009 -0400 +++ b/lib/ur/list.urs Tue Sep 08 10:18:19 2009 -0400 @@ -8,6 +8,8 @@ val foldlMapAbort : a ::: Type -> b ::: Type -> c ::: Type -> (a -> b -> option (c * b)) -> b -> t a -> option (t c * b) +val length : a ::: Type -> t a -> int + val rev : a ::: Type -> t a -> t a val revAppend : a ::: Type -> t a -> t a -> t a
--- a/src/c/urweb.c Tue Sep 08 07:48:57 2009 -0400 +++ b/src/c/urweb.c Tue Sep 08 10:18:19 2009 -0400 @@ -1153,17 +1153,7 @@ } const char *uw_Basis_get_script(uw_context ctx, uw_unit u) { - if (ctx->script_header[0] == 0) - return ""; - else if (buf_used(&ctx->script) == 0) - return ctx->script_header; - else { - char *r = uw_malloc(ctx, strlen(ctx->script_header) + 42 + buf_used(&ctx->script)); - sprintf(r, "%s<script type=\"text/javascript\">%s</script>", - ctx->script_header, - ctx->script.start); - return r; - } + return "<sc>"; } uw_Basis_string uw_Basis_maybe_onload(uw_context ctx, uw_Basis_string s) { @@ -2557,6 +2547,34 @@ for (i = 0; i < ctx->used_transactionals; ++i) ctx->transactionals[i].free(ctx->transactionals[i].data); + + // Splice script data into appropriate part of page + if (ctx->script_header[0] == 0) + ; + else if (buf_used(&ctx->script) == 0) { + size_t len = strlen(ctx->script_header); + char *start = strstr(ctx->page.start, "<sc>"); + if (start) { + buf_check(&ctx->page, buf_used(&ctx->page) - 4 + len); + memmove(start + len, start + 4, buf_used(&ctx->page) - (start - ctx->page.start) - 3); + ctx->page.front += len - 4; + memcpy(start, ctx->script_header, len); + } + } else { + size_t lenH = strlen(ctx->script_header), len = buf_used(&ctx->script); + size_t lenP = lenH + 40 + len; + char *start = strstr(ctx->page.start, "<sc>"); + if (start) { + buf_check(&ctx->page, buf_used(&ctx->page) - 4 + lenP); + memmove(start + lenP, start + 4, buf_used(&ctx->page) - (start - ctx->page.start) - 3); + ctx->page.front += lenP - 4; + memcpy(start, ctx->script_header, lenH); + memcpy(start + lenH, "<script type=\"text/javascript\">", 31); + memcpy(start + lenH + 31, ctx->script.start, len); + memcpy(start + lenH + 31 + len, "</script>", 9); + printf("start=%s\n", start); + } + } } int uw_rollback(uw_context ctx) {
--- a/src/compiler.sig Tue Sep 08 07:48:57 2009 -0400 +++ b/src/compiler.sig Tue Sep 08 10:18:19 2009 -0400 @@ -136,6 +136,10 @@ val toUntangle2 : (string, Mono.file) transform val toMono_reduce2 : (string, Mono.file) transform val toMono_shake2 : (string, Mono.file) transform + val toMono_opt4 : (string, Mono.file) transform + val toFuse2 : (string, Mono.file) transform + val toUntangle3 : (string, Mono.file) transform + val toMono_shake3 : (string, Mono.file) transform val toPathcheck : (string, Mono.file) transform val toCjrize : (string, Cjr.file) transform val toScriptcheck : (string, Cjr.file) transform
--- a/src/compiler.sml Tue Sep 08 07:48:57 2009 -0400 +++ b/src/compiler.sml Tue Sep 08 10:18:19 2009 -0400 @@ -854,13 +854,17 @@ val toMono_reduce2 = transform mono_reduce "mono_reduce2" o toUntangle2 val toMono_shake2 = transform mono_shake "mono_shake2" o toMono_reduce2 +val toMono_opt4 = transform mono_opt "mono_opt4" o toMono_shake2 +val toFuse2 = transform fuse "shake2" o toMono_opt4 +val toUntangle3 = transform untangle "untangle3" o toFuse2 +val toMono_shake3 = transform mono_shake "mono_shake3" o toUntangle3 val pathcheck = { func = (fn file => (PathCheck.check file; file)), print = MonoPrint.p_file MonoEnv.empty } -val toPathcheck = transform pathcheck "pathcheck" o toMono_shake2 +val toPathcheck = transform pathcheck "pathcheck" o toMono_shake3 val cjrize = { func = Cjrize.cjrize,
--- a/src/mono_reduce.sml Tue Sep 08 07:48:57 2009 -0400 +++ b/src/mono_reduce.sml Tue Sep 08 10:18:19 2009 -0400 @@ -35,8 +35,23 @@ structure U = MonoUtil structure IM = IntBinaryMap +structure IS = IntBinarySet +fun simpleImpure syms = + U.Exp.exists {typ = fn _ => false, + exp = fn EWrite _ => true + | EQuery _ => true + | EDml _ => true + | ENextval _ => true + | EUnurlify _ => true + | EFfiApp (m, x, _) => Settings.isEffectful (m, x) + | EServerCall _ => true + | ERecv _ => true + | ESleep _ => true + | ENamed n => IS.member (syms, n) + | _ => false} + fun impure (e, _) = case e of EWrite _ => true @@ -82,7 +97,6 @@ | ERecv _ => true | ESleep _ => true - val liftExpInExp = Monoize.liftExpInExp fun multiLift n e = @@ -244,22 +258,33 @@ fun reduce file = let - fun countAbs (e, _) = - case e of - EAbs (_, _, _, e) => 1 + countAbs e - | _ => 0 - - val absCounts = - foldl (fn ((d, _), absCounts) => - case d of - DVal (_, n, _, e, _) => - IM.insert (absCounts, n, countAbs e) - | DValRec vis => - foldl (fn ((_, n, _, e, _), absCounts) => - IM.insert (absCounts, n, countAbs e)) - absCounts vis - | _ => absCounts) - IM.empty file + val (impures, absCounts) = + foldl (fn ((d, _), (impures, absCounts)) => + let + fun countAbs (e, _) = + case e of + EAbs (_, _, _, e) => 1 + countAbs e + | _ => 0 + in + case d of + DVal (_, n, _, e, _) => + (if simpleImpure impures e then + IS.add (impures, n) + else + impures, + IM.insert (absCounts, n, countAbs e)) + | DValRec vis => + (if List.exists (fn (_, _, _, e, _) => simpleImpure impures e) vis then + foldl (fn ((_, n, _, _, _), impures) => + IS.add (impures, n)) impures vis + else + impures, + foldl (fn ((x, n, _, e, _), absCounts) => + IM.insert (absCounts, n, countAbs e)) + absCounts vis) + | _ => (impures, absCounts) + end) + (IS.empty, IM.empty) file fun summarize d (e, _) = let @@ -365,6 +390,10 @@ s end + val impure = fn e => + simpleImpure impures e andalso impure e + andalso not (List.null (summarize ~1 e)) + fun exp env e = let (*val () = Print.prefaces "exp" [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan))]*) @@ -464,7 +493,7 @@ if impure e' then e else - EAbs (x', t', ran, (ELet (x, t, liftExpInExp 0 e', swapExpVars 0 e''), loc)) + EAbs (x', t', ran, reduceExp env (ELet (x, t, liftExpInExp 0 e', swapExpVars 0 e''), loc)) | ELet (x, t, e', b) => let @@ -479,13 +508,15 @@ end fun trySub () = - case t of - (TFfi ("Basis", "string"), _) => doSub () - | (TSignal _, _) => e - | _ => - case e' of - (ECase _, _) => e - | _ => doSub () + ((*Print.prefaces "trySub" + [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan))];*) + case t of + (TFfi ("Basis", "string"), _) => doSub () + | (TSignal _, _) => e + | _ => + case e' of + (ECase _, _) => e + | _ => doSub ()) in if impure e' then let @@ -495,7 +526,8 @@ (*val () = Print.prefaces "Try" [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan)), - ("e'", p_events effs_e'), + ("e'", MonoPrint.p_exp env e'), + ("e'_eff", p_events effs_e'), ("b", p_events effs_b)]*) fun does eff = List.exists (fn eff' => eff' = eff) effs_e'
--- a/src/monoize.sml Tue Sep 08 07:48:57 2009 -0400 +++ b/src/monoize.sml Tue Sep 08 10:18:19 2009 -0400 @@ -2576,13 +2576,13 @@ NONE => tagStart | SOME extra => (L'.EStrcat (tagStart, extra), loc) - val xml = case extraInner of - NONE => xml - | SOME ei => (L.EFfiApp ("Basis", "strcat", [ei, xml]), loc) - fun normal () = let val (xml, fm) = monoExp (env, st, fm) xml + + val xml = case extraInner of + NONE => xml + | SOME ei => (L'.EStrcat (ei, xml), loc) in ((L'.EStrcat ((L'.EStrcat (tagStart, (L'.EPrim (Prim.String ">"), loc)), loc), (L'.EStrcat (xml, @@ -2646,7 +2646,7 @@ [(L'.ERecord [], loc)]), loc), onload), loc)]), loc), - SOME (L.EFfiApp ("Basis", "get_script", [(L.ERecord [], loc)]), loc)) + SOME (L'.EFfiApp ("Basis", "get_script", [(L'.ERecord [], loc)]), loc)) end | "dyn" =>