summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/jscomp.sml18
-rw-r--r--src/mono_reduce.sml184
2 files changed, 109 insertions, 93 deletions
diff --git a/src/jscomp.sml b/src/jscomp.sml
index a4e3dd35..bc407db8 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -35,7 +35,8 @@ structure U = MonoUtil
val funcs = [(("Basis", "alert"), "alert"),
(("Basis", "htmlifyString"), "escape"),
- (("Basis", "new_client_source"), "sc")]
+ (("Basis", "new_client_source"), "sc"),
+ (("Basis", "set_client_source"), "sv")]
structure FM = BinaryMapFn(struct
type ord_key = string * string
@@ -94,7 +95,7 @@ fun strcat loc es =
| [x] => x
| x :: es' => (EStrcat (x, strcat loc es'), loc)
-fun jsExp mode outer =
+fun jsExp mode skip outer =
let
val len = length outer
@@ -126,7 +127,10 @@ fun jsExp mode outer =
case #1 t of
TSource => strcat [str "s",
(EFfiApp ("Basis", "htmlifyInt", [e]), loc)]
+ | TRecord [] => str "null"
+ | TFfi ("Basis", "string") => e
| _ => (EM.errorAt loc "Don't know how to embed type in JavaScript";
+ Print.prefaces "Can't embed" [("t", MonoPrint.p_typ MonoEnv.empty t)];
str "ERROR")
in
case #1 e of
@@ -154,7 +158,7 @@ fun jsExp mode outer =
let
val n = n - inner
in
- (quoteExp (List.nth (outer, n)) (ERel n, loc), st)
+ (quoteExp (List.nth (outer, n)) (ERel (n - skip), loc), st)
end
| ENamed _ => raise Fail "Named"
| ECon (_, pc, NONE) => (patCon pc, st)
@@ -403,7 +407,7 @@ val decl : state -> decl -> decl * state =
U.Decl.foldMapB {typ = fn x => x,
exp = fn (env, e, st) =>
let
- fun doCode m env orig e =
+ fun doCode m skip env orig e =
let
val len = length env
fun str s = (EPrim (Prim.String s), #2 e)
@@ -411,14 +415,14 @@ val decl : state -> decl -> decl * state =
val locals = List.tabulate
(varDepth e,
fn i => str ("var uwr" ^ Int.toString (len + i) ^ ";"))
- val (e, st) = jsExp m env 0 (e, st)
+ val (e, st) = jsExp m skip env 0 (e, st)
in
(EJavaScript (m, orig, SOME (strcat (#2 e) (locals @ [e]))), st)
end
in
case e of
- EJavaScript (m, orig as (EAbs (_, t, _, e), _), _) => doCode m (t :: env) orig e
- | EJavaScript (m, e, _) => doCode m env e e
+ EJavaScript (m, orig as (EAbs (_, t, _, e), _), _) => doCode m 1 (t :: env) orig e
+ | EJavaScript (m, e, _) => doCode m 0 env e e
| _ => (e, st)
end,
decl = fn (_, e, st) => (e, st),
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index c96f97cf..0117623f 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -56,6 +56,7 @@ fun impure (e, _) =
| EFfiApp ("Basis", "set_cookie", _) => true
| EFfiApp ("Basis", "new_client_source", _) => true
| EFfiApp ("Basis", "set_client_source", _) => true
+ | EFfiApp ("Basis", "alert", _) => true
| EFfiApp _ => false
| EApp ((EFfi _, _), _) => false
| EApp _ => true
@@ -253,92 +254,103 @@ fun reduce file =
IM.empty file
fun summarize d (e, _) =
- case e of
- EPrim _ => []
- | ERel n => if n = d then [UseRel] else []
- | ENamed _ => []
- | ECon (_, _, NONE) => []
- | ECon (_, _, SOME e) => summarize d e
- | ENone _ => []
- | ESome (_, e) => summarize d e
- | EFfi _ => []
- | EFfiApp ("Basis", "set_cookie", _) => [Unsure]
- | EFfiApp ("Basis", "new_client_source", _) => [Unsure]
- | EFfiApp ("Basis", "set_client_source", _) => [Unsure]
- | EFfiApp (_, _, es) => List.concat (map (summarize d) es)
- | EApp ((EFfi _, _), e) => summarize d e
- | EApp _ =>
- let
- fun unravel (e, ls) =
- case e of
- ENamed n =>
- let
- val ls = rev ls
- in
- case IM.find (absCounts, n) of
- NONE => [Unsure]
- | SOME len =>
- if length ls < len then
- ls
- else
- [Unsure]
- end
- | ERel n => List.revAppend (ls,
- if n = d then
- [UseRel, Unsure]
- else
- [Unsure])
- | EApp (f, x) =>
- unravel (#1 f, summarize d x @ ls)
- | _ => [Unsure]
- in
- unravel (e, [])
- end
-
- | EAbs _ => []
-
- | EUnop (_, e) => summarize d e
- | EBinop (_, e1, e2) => summarize d e1 @ summarize d e2
-
- | ERecord xets => List.concat (map (summarize d o #2) xets)
- | EField (e, _) => summarize d e
-
- | ECase (e, pes, _) =>
- let
- val lss = map (fn (p, e) => summarize (d + patBinds p) e) pes
- in
- case lss of
- [] => raise Fail "Empty pattern match"
- | ls :: lss =>
- if List.all (fn ls' => ls' = ls) lss then
- summarize d e @ ls
- else
- [Unsure]
- end
- | EStrcat (e1, e2) => summarize d e1 @ summarize d e2
-
- | EError (e, _) => summarize d e @ [Unsure]
-
- | EWrite e => summarize d e @ [WritePage]
-
- | ESeq (e1, e2) => summarize d e1 @ summarize d e2
- | ELet (_, _, e1, e2) => summarize d e1 @ summarize (d + 1) e2
-
- | EClosure (_, es) => List.concat (map (summarize d) es)
-
- | EQuery {query, body, initial, ...} =>
- List.concat [summarize d query,
- summarize (d + 2) body,
- summarize d initial,
- [ReadDb]]
-
- | EDml e => summarize d e @ [WriteDb]
- | ENextval e => summarize d e @ [WriteDb]
- | EUnurlify (e, _) => summarize d e
- | EJavaScript (_, e, _) => summarize d e
- | ESignalReturn e => summarize d e
- | ESignalBind (e1, e2) => summarize d e1 @ summarize d e2
- | ESignalSource e => summarize d e
+ let
+ val s =
+ case e of
+ EPrim _ => []
+ | ERel n => if n = d then [UseRel] else []
+ | ENamed _ => []
+ | ECon (_, _, NONE) => []
+ | ECon (_, _, SOME e) => summarize d e
+ | ENone _ => []
+ | ESome (_, e) => summarize d e
+ | EFfi _ => []
+ | EFfiApp ("Basis", "set_cookie", es) => List.concat (map (summarize d) es) @ [Unsure]
+ | EFfiApp ("Basis", "new_client_source", es) => List.concat (map (summarize d) es) @ [Unsure]
+ | EFfiApp ("Basis", "set_client_source", es) => List.concat (map (summarize d) es) @ [Unsure]
+ | EFfiApp ("Basis", "alert", es) => List.concat (map (summarize d) es) @ [Unsure]
+ | EFfiApp (_, _, es) => List.concat (map (summarize d) es)
+ | EApp ((EFfi _, _), e) => summarize d e
+ | EApp _ =>
+ let
+ fun unravel (e, ls) =
+ case e of
+ ENamed n =>
+ let
+ val ls = rev ls
+ in
+ case IM.find (absCounts, n) of
+ NONE => [Unsure]
+ | SOME len =>
+ if length ls < len then
+ ls
+ else
+ [Unsure]
+ end
+ | ERel n => List.revAppend (ls,
+ if n = d then
+ [UseRel, Unsure]
+ else
+ [Unsure])
+ | EApp (f, x) =>
+ unravel (#1 f, summarize d x @ ls)
+ | _ => [Unsure]
+ in
+ unravel (e, [])
+ end
+
+ | EAbs (_, _, _, e) => List.filter (fn UseRel => true
+ | _ => false) (summarize (d + 1) e)
+
+ | EUnop (_, e) => summarize d e
+ | EBinop (_, e1, e2) => summarize d e1 @ summarize d e2
+
+ | ERecord xets => List.concat (map (summarize d o #2) xets)
+ | EField (e, _) => summarize d e
+
+ | ECase (e, pes, _) =>
+ let
+ val lss = map (fn (p, e) => summarize (d + patBinds p) e) pes
+ in
+ case lss of
+ [] => raise Fail "Empty pattern match"
+ | ls :: lss =>
+ if List.all (fn ls' => ls' = ls) lss then
+ summarize d e @ ls
+ else
+ [Unsure]
+ end
+ | EStrcat (e1, e2) => summarize d e1 @ summarize d e2
+
+ | EError (e, _) => summarize d e @ [Unsure]
+
+ | EWrite e => summarize d e @ [WritePage]
+
+ | ESeq (e1, e2) => summarize d e1 @ summarize d e2
+ | ELet (_, _, e1, e2) => summarize d e1 @ summarize (d + 1) e2
+
+ | EClosure (_, es) => List.concat (map (summarize d) es)
+
+ | EQuery {query, body, initial, ...} =>
+ List.concat [summarize d query,
+ summarize (d + 2) body,
+ summarize d initial,
+ [ReadDb]]
+
+ | EDml e => summarize d e @ [WriteDb]
+ | ENextval e => summarize d e @ [WriteDb]
+ | EUnurlify (e, _) => summarize d e
+ | EJavaScript (_, e, _) => summarize d e
+ | ESignalReturn e => summarize d e
+ | ESignalBind (e1, e2) => summarize d e1 @ summarize d e2
+ | ESignalSource e => summarize d e
+ in
+ (*Print.prefaces "Summarize"
+ [("e", MonoPrint.p_exp MonoEnv.empty (e, ErrorMsg.dummySpan)),
+ ("d", Print.PD.string (Int.toString d)),
+ ("s", p_events s)];*)
+ s
+ end
fun exp env e =
let
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-02 10:45:20 +0000