aboutsummaryrefslogtreecommitdiffhomepage
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2009-09-08 10:18:19 -0400
committerGravatar Adam Chlipala <adamc@hcoop.net>2009-09-08 10:18:19 -0400
commitd07c91bf275874a5f6f13af5f338def78eea7ae0 (patch)
tree700a022259cb238d022c76cb0b6c30fb44985aed
parent815c52605cdba3c95d7e4e6fd3f1eddf0939bc6a (diff)
dragList almost kinda works
Diffstat
-rw-r--r--demo/more/dragList.ur33
-rw-r--r--demo/more/dragList.urp4
-rw-r--r--demo/more/dragList.urs1
-rw-r--r--lib/ur/list.ur10
-rw-r--r--lib/ur/list.urs2
-rw-r--r--src/c/urweb.c40
-rw-r--r--src/compiler.sig4
-rw-r--r--src/compiler.sml6
-rw-r--r--src/mono_reduce.sml86
-rw-r--r--src/monoize.sml10
10 files changed, 152 insertions, 44 deletions
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 <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>
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<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 @@ 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, "<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) {
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" =>
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-20 05:03:29 +0000