Proper lifting of MonoEnv stored expressions; avoidance of onchange clobbering

8 files changed, 154 insertions, 18 deletions

diff --git a/lib/js/urweb.js b/lib/js/urweb.js
index 2943c897..d0322bff 100644
--- a/lib/js/urweb.js
+++ b/lib/js/urweb.js
@@ -301,11 +301,19 @@ function inp(t, s, content) {
   return x;
 }
 
+function addOnChange(x, f) {
+  var old = x.onchange;
+  x.onchange = function() { old(); f (); };
+}
+
 
 // Basic string operations
 
 function eh(x) {
-  return x.split("&").join("&amp;").split("<").join("&lt;").split(">").join("&gt;");
+  if (x == null)
+    return "NULL";
+  else
+    return x.split("&").join("&amp;").split("<").join("&lt;").split(">").join("&gt;");
 }
 
 function ts(x) { return x.toString() }
diff --git a/lib/ur/list.ur b/lib/ur/list.ur
index ecec2bec..2ee60538 100644
--- a/lib/ur/list.ur
+++ b/lib/ur/list.ur
@@ -39,3 +39,13 @@ fun mapX (a ::: Type) (ctx ::: {Unit}) f =
     in
         mapX'
     end
+
+fun mapM (m ::: (Type -> Type)) (_ : monad m) (a ::: Type) (b ::: Type) f =
+    let
+        fun mapM' acc ls =
+            case ls of
+                [] => acc
+              | x :: ls => mapM' (x' <- f x; ls' <- acc; return (x' :: ls')) ls
+    in
+        mapM' (return [])
+    end
diff --git a/lib/ur/list.urs b/lib/ur/list.urs
index e9e097d4..d27ad997 100644
--- a/lib/ur/list.urs
+++ b/lib/ur/list.urs
@@ -7,3 +7,6 @@ val rev : a ::: Type -> t a -> t a
 val mp : a ::: Type -> b ::: Type -> (a -> b) -> t a -> t b
 
 val mapX : a ::: Type -> ctx ::: {Unit} -> (a -> xml ctx [] []) -> t a -> xml ctx [] []
+
+val mapM : m ::: (Type -> Type) -> monad m -> a ::: Type -> b ::: Type
+           -> (a -> m b) -> list a -> m (list b)
diff --git a/src/especialize.sml b/src/especialize.sml
index 03be01b1..3ea4dcbd 100644
--- a/src/especialize.sml
+++ b/src/especialize.sml
@@ -112,6 +112,13 @@ type state = {
 
 fun default (_, x, st) = (x, st)
 
+structure SS = BinarySetFn(struct
+                           type ord_key = string
+                           val compare = String.compare
+                           end)
+
+val mayNotSpec = ref SS.empty
+
 fun specialize' file =
     let
         fun bind (env, b) =
@@ -179,13 +186,14 @@ fun specialize' file =
                                     (ERel _, _) :: _ => true
                                   | _ => false
                         in
+                            (*Print.preface ("fxs'", Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs');*)
                             if firstRel ()
                                orelse List.all (fn (ERel _, _) => true
                                                  | _ => false) fxs' then
                                 (e, st)
                             else
-                                case KM.find (args, fxs') of
-                                    SOME f' =>
+                                case (KM.find (args, fxs'), SS.member (!mayNotSpec, name)) of
+                                    (SOME f', _) =>
                                     let
                                         val e = (ENamed f', loc)
                                         val e = IS.foldr (fn (arg, e) => (EApp (e, (ERel arg, loc)), loc))
@@ -197,8 +205,14 @@ fun specialize' file =
                                                        [("e'", CorePrint.p_exp CoreEnv.empty e)];*)
                                         (#1 e, st)
                                     end
-                                  | NONE =>
+                                  | (_, true) => (e, st)
+                                  | (NONE, false) =>
                                     let
+                                        (*val () = Print.prefaces "New one"
+                                                 [("f", Print.PD.string (Int.toString f)),
+                                                  ("mns", Print.p_list Print.PD.string
+                                                                       (SS.listItems (!mayNotSpec)))]*)
+
                                         fun subBody (body, typ, fxs') =
                                             case (#1 body, #1 typ, fxs') of
                                                 (_, _, []) => SOME (body, typ)
@@ -245,7 +259,11 @@ fun specialize' file =
                                                                                       (TFun (xt, typ'), loc))
                                                                                  end)
                                                                              (body', typ') fvs
+                                                val mns = !mayNotSpec
+                                                val () = mayNotSpec := SS.add (mns, name)
+                                                (*val () = Print.preface ("body'", CorePrint.p_exp CoreEnv.empty body')*)
                                                 val (body', st) = specExp env st body'
+                                                val () = mayNotSpec := mns
 
                                                 val e' = (ENamed f', loc)
                                                 val e' = IS.foldr (fn (arg, e) => (EApp (e, (ERel arg, loc)), loc))
@@ -297,7 +315,13 @@ fun specialize' file =
                     if isPoly d then
                         (d, st)
                     else
-                        specDecl [] st d
+                        (mayNotSpec := (case #1 d of
+                                            DValRec vis => foldl (fn ((x, _, _, _, _), mns) =>
+                                                                     SS.add (mns, x)) SS.empty vis
+                                          | DVal (x, _, _, _, _) => SS.singleton x
+                                          | _ => SS.empty);
+                         specDecl [] st d
+                         before mayNotSpec := SS.empty)
 
                 (*val () = print "/decl\n"*)
 
@@ -324,9 +348,7 @@ fun specialize' file =
                                    (DValRec vis', _) => [(DValRec (vis @ vis'), ErrorMsg.dummySpan)]
                                  | _ => [(DValRec vis, ErrorMsg.dummySpan), d'])
             in
-                (*Print.prefaces "doDecl" [("d", CorePrint.p_decl E.empty d),
-                                         ("t", Print.PD.string (Real.toString (Time.toReal
-                                                                                   (Time.- (Time.now (), befor)))))];*)
+                (*Print.prefaces "doDecl" [("d", CorePrint.p_decl E.empty d)];*)
                 (ds, ({maxName = #maxName st,
                        funcs = funcs,
                        decls = []}, changed))
diff --git a/src/jscomp.sml b/src/jscomp.sml
index c01b9e10..3e8e939e 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -36,11 +36,17 @@ structure U = MonoUtil
 structure IS = IntBinarySet
 structure IM = IntBinaryMap
 
+structure TM = BinaryMapFn(struct
+                           type ord_key = typ
+                           val compare = U.Typ.compare
+                           end)
+
 type state = {
      decls : decl list,
      script : string list,
      included : IS.set,
      injectors : int IM.map,
+     listInjectors : int TM.map,
      decoders : int IM.map,
      maxName : int
 }
@@ -231,6 +237,52 @@ fun process file =
                      st)
                 end
 
+              | TList t' =>
+                (case TM.find (#listInjectors st, t') of
+                     SOME n' => ((EApp ((ENamed n', loc), e), loc), st)
+                   | NONE =>
+                     let
+                         val rt = (TRecord [("1", t'), ("2", t)], loc)
+
+                         val n' = #maxName st
+                         val st = {decls = #decls st,
+                                   script = #script st,
+                                   included = #included st,
+                                   injectors = #injectors st,
+                                   listInjectors = TM.insert (#listInjectors st, t', n'),
+                                   decoders = #decoders st,
+                                   maxName = n' + 1}
+
+                         val s = (TFfi ("Basis", "string"), loc)
+                         val (e', st) = quoteExp loc t ((EField ((ERel 0, loc), "1"), loc), st)
+
+                         val body = (ECase ((ERel 0, loc),
+                                            [((PNone rt, loc),
+                                              str loc "null"),
+                                             ((PSome (rt, (PVar ("x", rt), loc)), loc),
+                                              strcat loc [str loc "{v:{_1:",
+                                                          e',
+                                                          str loc ",_2:",
+                                                          (EApp ((ENamed n', loc),
+                                                                 (EField ((ERel 0, loc), "2"), loc)), loc),
+                                                          str loc "}}"])],
+                                            {disc = t, result = s}), loc)
+                         val body = (EAbs ("x", t, s, body), loc)
+                                    
+                         val st = {decls = (DValRec [("jsify", n', (TFun (t, s), loc),
+                                                      body, "jsify")], loc) :: #decls st,
+                                   script = #script st,
+                                   included = #included st,
+                                   injectors = #injectors st,
+                                   listInjectors = #listInjectors st,
+                                   decoders= #decoders st,
+                                   maxName = #maxName st}
+
+
+                     in
+                         ((EApp ((ENamed n', loc), e), loc), st)
+                     end)
+
               | TDatatype (n, ref (dk, cs)) =>
                 (case IM.find (#injectors st, n) of
                      SOME n' => ((EApp ((ENamed n', loc), e), loc), st)
@@ -241,6 +293,7 @@ fun process file =
                                    script = #script st,
                                    included = #included st,
                                    injectors = IM.insert (#injectors st, n, n'),
+                                   listInjectors = #listInjectors st,
                                    decoders = #decoders st,
                                    maxName = n' + 1}
 
@@ -282,6 +335,7 @@ fun process file =
                                    script = #script st,
                                    included = #included st,
                                    injectors = #injectors st,
+                                   listInjectors = #listInjectors st,
                                    decoders= #decoders st,
                                    maxName = #maxName st}
                      in
@@ -350,6 +404,7 @@ fun process file =
                                    script = #script st,
                                    included = #included st,
                                    injectors = #injectors st,
+                                   listInjectors = #listInjectors st,
                                    decoders = IM.insert (#decoders st, n, n'),
                                    maxName = n' + 1}
 
@@ -384,6 +439,7 @@ fun process file =
                                    script = body :: #script st,
                                    included = #included st,
                                    injectors = #injectors st,
+                                   listInjectors = #listInjectors st,
                                    decoders = #decoders st,
                                    maxName = #maxName st}
                      in
@@ -402,7 +458,7 @@ fun process file =
 
         val foundJavaScript = ref false
 
-        fun jsExp mode skip outer =
+        fun jsExp mode outer =
             let
                 val len = length outer
 
@@ -575,7 +631,7 @@ fun process file =
                                 let
                                     val n = n - inner
                                 in
-                                    quoteExp (List.nth (outer, n)) ((ERel (n - skip), loc), st)
+                                    quoteExp (List.nth (outer, n)) ((ERel n, loc), st)
                                 end
 
                           | ENamed n =>
@@ -592,10 +648,11 @@ fun process file =
                                                           script = #script st,
                                                           included = IS.add (#included st, n),
                                                           injectors = #injectors st,
+                                                          listInjectors = #listInjectors st,
                                                           decoders = #decoders st,
                                                           maxName = #maxName st}
 
-                                                val (e, st) = jsExp mode skip [] 0 (e, st)
+                                                val (e, st) = jsExp mode [] 0 (e, st)
                                                 val e = deStrcat 0 e
                                                 
                                                 val sc = "_n" ^ Int.toString n ^ "=" ^ e ^ ";\n"
@@ -604,6 +661,7 @@ fun process file =
                                                  script = sc :: #script st,
                                                  included = #included st,
                                                  injectors = #injectors st,
+                                                 listInjectors = #listInjectors st,
                                                  decoders= #decoders st,
                                                  maxName = #maxName st}
                                             end
@@ -988,7 +1046,7 @@ fun process file =
             U.Decl.foldMapB {typ = fn x => x,
                              exp = fn (env, e, st) =>
                                       let
-                                          fun doCode m skip env orig e =
+                                          fun doCode m env orig e =
                                               let
                                                   val len = length env
                                                   fun str s = (EPrim (Prim.String s), #2 e)
@@ -996,7 +1054,7 @@ fun process file =
                                                   val locals = List.tabulate
                                                                    (varDepth e,
                                                                  fn i => str ("var _" ^ Int.toString (len + i) ^ ";"))
-                                                  val (e, st) = jsExp m skip env 0 (e, st)
+                                                  val (e, st) = jsExp m env 0 (e, st)
                                               in
                                                   (EJavaScript (m, orig, SOME (strcat (#2 e) (locals @ [e]))), st)
                                               end
@@ -1004,7 +1062,7 @@ fun process file =
                                           case e of
                                               EJavaScript (m, orig, NONE) =>
                                               (foundJavaScript := true;
-                                               doCode m 0 env orig orig)
+                                               doCode m env orig orig)
                                             | _ => (e, st)
                                       end,
                              decl = fn (_, e, st) => (e, st),
@@ -1021,6 +1079,7 @@ fun process file =
                   script = #script st,
                   included = #included st,
                   injectors = #injectors st,
+                  listInjectors = #listInjectors st,
                   decoders = #decoders st,
                   maxName = #maxName st})
             end
@@ -1030,6 +1089,7 @@ fun process file =
                         script = [],
                         included = IS.empty,
                         injectors = IM.empty,
+                        listInjectors = TM.empty,
                         decoders = IM.empty,
                         maxName = U.File.maxName file + 1}
                        file
diff --git a/src/mono_env.sml b/src/mono_env.sml
index 739f2f89..2397637a 100644
--- a/src/mono_env.sml
+++ b/src/mono_env.sml
@@ -70,11 +70,25 @@ fun lookupConstructor (env : env) n =
         NONE => raise UnboundNamed n
       | SOME x => x
 
+structure U = MonoUtil
+
+val liftExpInExp =
+    U.Exp.mapB {typ = fn t => t,
+                exp = fn bound => fn e =>
+                                     case e of
+                                         ERel xn =>
+                                         if xn < bound then
+                                             e
+                                         else
+                                             ERel (xn + 1)
+                                       | _ => e,
+                bind = fn (bound, U.Exp.RelE _) => bound + 1
+                        | (bound, _) => bound}
+
 fun pushERel (env : env) x t eo =
     {datatypes = #datatypes env,
      constructors = #constructors env,
-
-     relE = (x, t, eo) :: #relE env,
+     relE = (x, t, eo) :: map (fn (x, t, eo) => (x, t, Option.map (liftExpInExp 0) eo)) (#relE env),
      namedE = #namedE env}
 
 fun lookupERel (env : env) n =
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index 5d8afee3..5a2aca85 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -409,7 +409,15 @@ fun reduce file =
                                     case match (env, p, e') of
                                         No => search pes
                                       | Maybe => push ()
-                                      | Yes env => #1 (reduceExp env body)
+                                      | Yes env' =>
+                                        let
+                                            val r = reduceExp env' body
+                                        in
+                                            (*Print.prefaces "ECase"
+                                                           [("body", MonoPrint.p_exp env' body),
+                                                            ("r", MonoPrint.p_exp env r)];*)
+                                            #1 r
+                                        end
                         in
                             search pes
                         end
@@ -443,7 +451,14 @@ fun reduce file =
                       | ELet (x, t, e', b) =>
                         let
                             fun doSub () =
-                                #1 (reduceExp env (subExpInExp (0, e') b))
+                                let
+                                    val r = subExpInExp (0, e') b
+                                in
+                                    (*Print.prefaces "doSub" [("e'", MonoPrint.p_exp env e'),
+                                                            ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b),
+                                                            ("r", MonoPrint.p_exp env r)];*)
+                                    #1 (reduceExp env r)
+                                end
 
                             fun trySub () =
                                 case t of
diff --git a/src/monoize.sml b/src/monoize.sml
index 86a27543..e8d8a122 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -2498,6 +2498,10 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
 
                         val assgns = List.mapPartial
                                      (fn ("Source", _, _) => NONE
+                                       | ("Onchange", e, _) =>
+                                         SOME (strcat [str "addOnChange(d,",
+                                                       (L'.EJavaScript (L'.Script, e, NONE), loc),
+                                                       str ")"])
                                        | (x, e, _) =>
                                          SOME (strcat [str ("d." ^ lowercaseFirst x ^ "="),
                                                        (L'.EJavaScript (L'.Script, e, NONE), loc),