diff options
Diffstat (limited to 'src/jscomp.sml')
| -rw-r--r-- | src/jscomp.sml | 142 |
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), |