From d07c91bf275874a5f6f13af5f338def78eea7ae0 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 8 Sep 2009 10:18:19 -0400 Subject: dragList almost kinda works --- demo/more/dragList.ur | 33 +++++++++++++++++++ demo/more/dragList.urp | 4 +++ demo/more/dragList.urs | 1 + lib/ur/list.ur | 10 ++++++ lib/ur/list.urs | 2 ++ src/c/urweb.c | 40 ++++++++++++++++------- src/compiler.sig | 4 +++ src/compiler.sml | 6 +++- src/mono_reduce.sml | 86 ++++++++++++++++++++++++++++++++++---------------- src/monoize.sml | 10 +++--- 10 files changed, 152 insertions(+), 44 deletions(-) create mode 100644 demo/more/dragList.ur create mode 100644 demo/more/dragList.urp create mode 100644 demo/more/dragList.urs diff --git a/demo/more/dragList.ur b/demo/more/dragList.ur new file mode 100644 index 00000000..ddb50e82 --- /dev/null +++ b/demo/more/dragList.ur @@ -0,0 +1,33 @@ +fun draggableList title items = + itemSources <- List.mapM source items; + draggingItem <- source None; + return +

Great {[title]}

return () + | Some di => item1 <- get di; + item2 <- get itemSource; + set di item2; + set itemSource item1}> + {[s]}}/> +

+ + +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 + {bears} + {beers} + {boars} + diff --git a/demo/more/dragList.urp b/demo/more/dragList.urp new file mode 100644 index 00000000..56fb9cce --- /dev/null +++ b/demo/more/dragList.urp @@ -0,0 +1,4 @@ +debug + +$/list +dragList diff --git a/demo/more/dragList.urs b/demo/more/dragList.urs new file mode 100644 index 00000000..6ac44e0b --- /dev/null +++ b/demo/more/dragList.urs @@ -0,0 +1 @@ +val main : unit -> transaction page diff --git a/lib/ur/list.ur b/lib/ur/list.ur index 3d4134ea..9e2550ca 100644 --- a/lib/ur/list.ur +++ b/lib/ur/list.ur @@ -44,6 +44,16 @@ fun foldlAbort [a] [b] f = 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) = diff --git a/lib/ur/list.urs b/lib/ur/list.urs index ece85e8c..df1c8a52 100644 --- a/lib/ur/list.urs +++ b/lib/ur/list.urs @@ -8,6 +8,8 @@ val foldlAbort : a ::: Type -> b ::: Type -> (a -> b -> option b) -> b -> t a -> 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 diff --git a/src/c/urweb.c b/src/c/urweb.c index 068282f2..4160fa81 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -1153,17 +1153,7 @@ void uw_write_script(uw_context ctx, uw_Basis_string s) { } 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", - ctx->script_header, - ctx->script.start); - return r; - } + return ""; } uw_Basis_string uw_Basis_maybe_onload(uw_context ctx, uw_Basis_string s) { @@ -2557,6 +2547,34 @@ void uw_commit(uw_context ctx) { 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, ""); + 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, ""); + 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, "", 9); + printf("start=%s\n", start); + } + } } int uw_rollback(uw_context ctx) { diff --git a/src/compiler.sig b/src/compiler.sig index 73605d7c..7ce19580 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -136,6 +136,10 @@ signature COMPILER = sig 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 diff --git a/src/compiler.sml b/src/compiler.sml index b7550fed..05bd53d3 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -854,13 +854,17 @@ val toUntangle2 = transform untangle "untangle2" o toFuse 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, diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index 4bbb430d..0820d200 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -35,7 +35,22 @@ structure E = MonoEnv 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 @@ -82,7 +97,6 @@ fun impure (e, _) = | ERecv _ => true | ESleep _ => true - val liftExpInExp = Monoize.liftExpInExp fun multiLift n e = @@ -244,22 +258,33 @@ fun patBinds (p, _) = 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 @@ fun reduce file = 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 @@ fun reduce file = 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 @@ fun reduce file = 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 @@ fun reduce file = (*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' diff --git a/src/monoize.sml b/src/monoize.sml index 12112648..063802b3 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -2576,13 +2576,13 @@ fun monoExp (env, st, fm) (all as (e, loc)) = 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 @@ fun monoExp (env, st, fm) (all as (e, loc)) = [(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" => -- cgit v1.2.3