aboutsummaryrefslogtreecommitdiffhomepage
diff options
context:
space:
mode:
Diffstat
-rw-r--r--lib/js/urweb.js10
-rw-r--r--lib/ur/list.ur10
-rw-r--r--lib/ur/list.urs3
-rw-r--r--src/especialize.sml36
-rw-r--r--src/jscomp.sml72
-rw-r--r--src/mono_env.sml18
-rw-r--r--src/mono_reduce.sml19
-rw-r--r--src/monoize.sml4
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),
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-20 09:46:00 +0000