summaryrefslogtreecommitdiff
path: root/src/jscomp.sml
diff options
context:
space:
mode:
Diffstat (limited to 'src/jscomp.sml')
-rw-r--r--src/jscomp.sml142
1 files changed, 86 insertions, 56 deletions
diff --git a/src/jscomp.sml b/src/jscomp.sml
index b27a860b..ca6508a9 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -96,14 +96,55 @@ fun varDepth (e, _) =
| ESignalBind (e1, e2) => Int.max (varDepth e1, varDepth e2)
| ESignalSource e => varDepth e
+fun closedUpto d =
+ let
+ fun cu inner (e, _) =
+ case e of
+ EPrim _ => true
+ | ERel n => n < inner orelse n - inner >= d
+ | ENamed _ => true
+ | ECon (_, _, NONE) => true
+ | ECon (_, _, SOME e) => cu inner e
+ | ENone _ => true
+ | ESome (_, e) => cu inner e
+ | EFfi _ => true
+ | EFfiApp (_, _, es) => List.all (cu inner) es
+ | EApp (e1, e2) => cu inner e1 andalso cu inner e2
+ | EAbs (_, _, _, e) => cu (inner + 1) e
+ | EUnop (_, e) => cu inner e
+ | EBinop (_, e1, e2) => cu inner e1 andalso cu inner e2
+ | ERecord xes => List.all (fn (_, e, _) => cu inner e) xes
+ | EField (e, _) => cu inner e
+ | ECase (e, pes, _) =>
+ cu inner e
+ andalso List.all (fn (p, e) => cu (inner + E.patBindsN p) e) pes
+ | EStrcat (e1, e2) => cu inner e1 andalso cu inner e2
+ | EError (e, _) => cu inner e
+ | EWrite e => cu inner e
+ | ESeq (e1, e2) => cu inner e1 andalso cu inner e2
+ | ELet (_, _, e1, e2) => cu inner e1 andalso cu (inner + 1) e2
+ | EClosure (_, es) => List.all (cu inner) es
+ | EQuery {query, body, initial, ...} =>
+ cu inner query
+ andalso cu (inner + 2) body
+ andalso cu inner initial
+ | EDml e => cu inner e
+ | ENextval e => cu inner e
+ | EUnurlify (e, _) => cu inner e
+ | EJavaScript (_, e, _) => cu inner e
+ | ESignalReturn e => cu inner e
+ | ESignalBind (e1, e2) => cu inner e1 andalso cu inner e2
+ | ESignalSource e => cu inner e
+ in
+ cu 0
+ end
+
fun strcat loc es =
case es of
[] => (EPrim (Prim.String ""), loc)
| [x] => x
| x :: es' => (EStrcat (x, strcat loc es'), loc)
-exception Unsupported of string * EM.span
-
fun process file =
let
val nameds = foldl (fn ((DVal (_, n, t, e, _), _), nameds) => IM.insert (nameds, n, e)
@@ -123,6 +164,7 @@ fun process file =
| TFfi ("Basis", "string") => e
| TFfi ("Basis", "int") => (EFfiApp ("Basis", "htmlifyInt", [e]), loc)
+ | TFfi ("Basis", "float") => (EFfiApp ("Basis", "htmlifyFloat", [e]), loc)
| _ => (EM.errorAt loc "Don't know how to embed type in JavaScript";
Print.prefaces "Can't embed" [("t", MonoPrint.p_typ MonoEnv.empty t)];
@@ -151,7 +193,9 @@ fun process file =
| TRecord [] => true
| _ => false
- fun unsupported s = raise Unsupported (s, loc)
+ fun unsupported s =
+ (EM.errorAt loc (s ^ " in code to be compiled to JavaScript[2]");
+ (str "ERROR", st))
val strcat = strcat loc
@@ -447,36 +491,40 @@ fun process file =
str ("._" ^ x)], st)
end
- | ECase (e, pes, _) =>
- let
- val plen = length pes
-
- val (cases, st) = ListUtil.foldliMap
- (fn (i, (p, e), st) =>
- let
- val (e, st) = jsE (inner + E.patBindsN p) (e, st)
- val fail =
- if i = plen - 1 then
- str "pf()"
- else
- str ("c" ^ Int.toString (i+1) ^ "()")
- val c = jsPat 0 inner p e fail
- in
- (strcat [str ("c" ^ Int.toString i ^ "=function(){return "),
- c,
- str "},"],
- st)
- end)
- st pes
-
- val (e, st) = jsE inner (e, st)
- in
- (strcat (str "("
- :: List.revAppend (cases,
- [str "d0=",
- e,
- str ",c0())"])), st)
- end
+ | ECase (e', pes, {result, ...}) =>
+ if closedUpto inner e andalso List.all (fn (_, e) => closedUpto inner e) pes then
+ ((ELet ("js", result, e, quoteExp result (ERel 0, loc)), loc),
+ st)
+ else
+ let
+ val plen = length pes
+
+ val (cases, st) = ListUtil.foldliMap
+ (fn (i, (p, e), st) =>
+ let
+ val (e, st) = jsE (inner + E.patBindsN p) (e, st)
+ val fail =
+ if i = plen - 1 then
+ str "pf()"
+ else
+ str ("c" ^ Int.toString (i+1) ^ "()")
+ val c = jsPat 0 inner p e fail
+ in
+ (strcat [str ("c" ^ Int.toString i ^ "=function(){return "),
+ c,
+ str "},"],
+ st)
+ end)
+ st pes
+
+ val (e, st) = jsE inner (e', st)
+ in
+ (strcat (str "("
+ :: List.revAppend (cases,
+ [str "d0=",
+ e,
+ str ",c0())"])), st)
+ end
| EStrcat (e1, e2) =>
let
@@ -522,7 +570,7 @@ fun process file =
str ")"], st)
end
- | EJavaScript (_, _, SOME e) => (e, st)
+ | EJavaScript (_, _, SOME _) => (e, st)
| EClosure _ => unsupported "EClosure"
| EQuery _ => unsupported "Query"
@@ -584,28 +632,10 @@ fun process file =
end
in
case e of
- EJavaScript (m as Source t, orig, _) =>
- (doCode m 0 env orig orig
- handle Unsupported (s, loc) =>
- let
- val e = ELet ("js", t, orig, quoteExp (#2 orig) t
- (ERel 0, #2 orig))
- in
- (EJavaScript (m, orig, SOME (e, #2 orig)), st)
- end)
-
- | EJavaScript (m, orig as (EAbs (_, t, _, e), _), _) =>
- (doCode m 1 (t :: env) orig e
- handle Unsupported (s, loc) =>
- (EM.errorAt loc (s ^ " in code to be compiled to JavaScript");
- (EPrim (Prim.String "ERROR"), st)))
-
- | EJavaScript (m, orig, _) =>
- (doCode m 0 env orig orig
- handle Unsupported (s, loc) =>
- (EM.errorAt loc (s ^ " in code to be compiled to JavaScript");
- (EPrim (Prim.String "ERROR"), st)))
-
+ EJavaScript (m, orig as (EAbs (_, t, _, e), _), NONE) =>
+ doCode m 1 (t :: env) orig e
+ | EJavaScript (m, orig, NONE) =>
+ doCode m 0 env orig orig
| _ => (e, st)
end,
decl = fn (_, e, st) => (e, st),