dragList almost kinda works

5 files changed, 102 insertions, 44 deletions

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" =>