Mercurial > urweb
changeset 567:1901db85acb4
Start of JsComp
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Sat, 20 Dec 2008 14:19:21 -0500 |
| parents | a152905c3c3b |
| children | 55fc747a67dc |
| files | src/compiler.sig src/compiler.sml src/jscomp.sig src/jscomp.sml src/mono_env.sig src/mono_env.sml src/mono_opt.sml src/mono_util.sig src/mono_util.sml src/prim.sig src/prim.sml src/sources tests/alert.ur |
| diffstat | 13 files changed, 436 insertions(+), 7 deletions(-) [+] |
line wrap: on
line diff
--- a/src/compiler.sig Fri Dec 19 12:38:11 2008 -0500 +++ b/src/compiler.sig Sat Dec 20 14:19:21 2008 -0500 @@ -75,6 +75,7 @@ val untangle : (Mono.file, Mono.file) phase val mono_reduce : (Mono.file, Mono.file) phase val mono_shake : (Mono.file, Mono.file) phase + val jscomp : (Mono.file, Mono.file) phase val fuse : (Mono.file, Mono.file) phase val pathcheck : (Mono.file, Mono.file) phase val cjrize : (Mono.file, Cjr.file) phase @@ -101,6 +102,7 @@ val toUntangle : (string, Mono.file) transform val toMono_reduce : (string, Mono.file) transform val toMono_shake : (string, Mono.file) transform + val toJscomp : (string, Mono.file) transform val toMono_opt2 : (string, Mono.file) transform val toFuse : (string, Mono.file) transform val toUntangle2 : (string, Mono.file) transform
--- a/src/compiler.sml Fri Dec 19 12:38:11 2008 -0500 +++ b/src/compiler.sml Sat Dec 20 14:19:21 2008 -0500 @@ -511,7 +511,14 @@ val toMono_shake = transform mono_shake "mono_shake1" o toMono_reduce -val toMono_opt2 = transform mono_opt "mono_opt2" o toMono_shake +val jscomp = { + func = JsComp.process, + print = MonoPrint.p_file MonoEnv.empty +} + +val toJscomp = transform jscomp "jscomp" o toMono_reduce + +val toMono_opt2 = transform mono_opt "mono_opt2" o toJscomp val fuse = { func = Fuse.fuse,
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/jscomp.sig Sat Dec 20 14:19:21 2008 -0500 @@ -0,0 +1,32 @@ +(* Copyright (c) 2008, Adam Chlipala + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * - Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * - Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * - The names of contributors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + *) + +signature JSCOMP = sig + + val process : Mono.file -> Mono.file + +end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/jscomp.sml Sat Dec 20 14:19:21 2008 -0500 @@ -0,0 +1,344 @@ +(* Copyright (c) 2008, Adam Chlipala + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * - Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * - Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * - The names of contributors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + *) + +structure JsComp :> JSCOMP = struct + +open Mono + +structure EM = ErrorMsg +structure E = MonoEnv +structure U = MonoUtil + +type state = { + decls : decl list, + script : string +} + +fun varDepth (e, _) = + case e of + EPrim _ => 0 + | ERel _ => 0 + | ENamed _ => 0 + | ECon (_, _, NONE) => 0 + | ECon (_, _, SOME e) => varDepth e + | ENone _ => 0 + | ESome (_, e) => varDepth e + | EFfi _ => 0 + | EFfiApp (_, _, es) => foldl Int.max 0 (map varDepth es) + | EApp (e1, e2) => Int.max (varDepth e1, varDepth e2) + | EAbs _ => 0 + | EUnop (_, e) => varDepth e + | EBinop (_, e1, e2) => Int.max (varDepth e1, varDepth e2) + | ERecord xes => foldl Int.max 0 (map (fn (_, e, _) => varDepth e) xes) + | EField (e, _) => varDepth e + | ECase (e, pes, _) => + foldl Int.max (varDepth e) + (map (fn (p, e) => E.patBindsN p + varDepth e) pes) + | EStrcat (e1, e2) => Int.max (varDepth e1, varDepth e2) + | EError (e, _) => varDepth e + | EWrite e => varDepth e + | ESeq (e1, e2) => Int.max (varDepth e1, varDepth e2) + | ELet (_, _, e1, e2) => Int.max (varDepth e1, 1 + varDepth e2) + | EClosure _ => 0 + | EQuery _ => 0 + | EDml _ => 0 + | ENextval _ => 0 + | EUnurlify _ => 0 + | EJavaScript _ => 0 + +fun jsExp inAttr outer = + let + val len = length outer + + fun jsE inner (e as (_, loc), st) = + let + fun str s = (EPrim (Prim.String s), loc) + + fun var n = Int.toString (len + inner - n - 1) + + fun patCon pc = + case pc of + PConVar n => str (Int.toString n) + | PConFfi {con, ...} => str ("\"_" ^ con ^ "\"") + + fun strcat es = + case es of + [] => (EPrim (Prim.String ""), loc) + | [x] => x + | x :: es' => (EStrcat (x, strcat es'), loc) + + fun isNullable (t, _) = + case t of + TOption _ => true + | _ => false + + fun unsupported s = + (EM.errorAt loc (s ^ " in code to be compiled to JavaScript"); + (str "ERROR", st)) + in + case #1 e of + EPrim (Prim.String s) => + (str ("\"" + ^ String.translate (fn #"'" => + if inAttr then + "\\047" + else + "'" + | #"<" => + if inAttr then + "<" + else + "\\074" + | #"\\" => "\\\\" + | ch => String.str ch) s + ^ "\""), st) + | EPrim p => (str (Prim.toString p), st) + | ERel n => + if n < inner then + (str ("uwr" ^ var n), st) + else + (str ("uwo" ^ var n), st) + | ENamed _ => raise Fail "Named" + | ECon (_, pc, NONE) => (patCon pc, st) + | ECon (_, pc, SOME e) => + let + val (s, st) = jsE inner (e, st) + in + (strcat [str "{n:", + patCon pc, + str ",v:", + s, + str "}"], st) + end + | ENone _ => (str "null", st) + | ESome (t, e) => + let + val (e, st) = jsE inner (e, st) + in + (if isNullable t then + strcat [str "{v:", e, str "}"] + else + e, st) + end + + | EFfi (_, s) => (str s, st) + | EFfiApp (_, s, []) => (str (s ^ "()"), st) + | EFfiApp (_, s, [e]) => + let + val (e, st) = jsE inner (e, st) + + in + (strcat [str (s ^ "("), + e, + str ")"], st) + end + | EFfiApp (_, s, e :: es) => + let + val (e, st) = jsE inner (e, st) + val (es, st) = ListUtil.foldlMapConcat + (fn (e, st) => + let + val (e, st) = jsE inner (e, st) + in + ([str ",", e], st) + end) + st es + in + (strcat (str (s ^ "(") + :: e + :: es + @ [str ")"]), st) + end + + | EApp (e1, e2) => + let + val (e1, st) = jsE inner (e1, st) + val (e2, st) = jsE inner (e2, st) + in + (strcat [e1, str "(", e2, str ")"], st) + end + | EAbs (_, _, _, e) => + let + val locals = List.tabulate + (varDepth e, + fn i => str ("var uwr" ^ Int.toString (len + inner + i) ^ ";")) + val (e, st) = jsE (inner + 1) (e, st) + in + (strcat (str ("function(uwr" + ^ Int.toString (len + inner) + ^ "){") + :: locals + @ [str "return ", + e, + str "}"]), + st) + end + + | EUnop (s, e) => + let + val (e, st) = jsE inner (e, st) + in + (strcat [str ("(" ^ s), + e, + str ")"], + st) + end + | EBinop (s, e1, e2) => + let + val (e1, st) = jsE inner (e1, st) + val (e2, st) = jsE inner (e2, st) + in + (strcat [str "(", + e1, + str s, + e2, + str ")"], + st) + end + + | ERecord [] => (str "null", st) + | ERecord [(x, e, _)] => + let + val (e, st) = jsE inner (e, st) + in + (strcat [str "{uw_x:", e, str "}"], st) + end + | ERecord ((x, e, _) :: xes) => + let + val (e, st) = jsE inner (e, st) + + val (es, st) = + foldr (fn ((x, e, _), (es, st)) => + let + val (e, st) = jsE inner (e, st) + in + (str (",uw_" ^ x ^ ":") + :: e + :: es, + st) + end) + ([str "}"], st) xes + in + (strcat (str ("{uw_" ^ x ^ ":") + :: e + :: es), + st) + end + | EField (e, x) => + let + val (e, st) = jsE inner (e, st) + in + (strcat [e, + str ("." ^ x)], st) + end + + | ECase _ => raise Fail "Jscomp: ECase" + + | EStrcat (e1, e2) => + let + val (e1, st) = jsE inner (e1, st) + val (e2, st) = jsE inner (e2, st) + in + (strcat [str "(", e1, str "+", e2, str ")"], st) + end + + | EError (e, _) => + let + val (e, st) = jsE inner (e, st) + in + (strcat [str "alert(\"ERROR: \"+", e, str ")"], + st) + end + + | EWrite _ => unsupported "EWrite" + + | ESeq (e1, e2) => + let + val (e1, st) = jsE inner (e1, st) + val (e2, st) = jsE inner (e2, st) + in + (strcat [str "(", e1, str ",", e2, str ")"], st) + end + | ELet (_, _, e1, e2) => + let + val (e1, st) = jsE inner (e1, st) + val (e2, st) = jsE (inner + 1) (e2, st) + in + (strcat [str ("(uwr" ^ Int.toString (len + inner) ^ "="), + e1, + str ",", + e2, + str ")"], st) + end + + | EClosure _ => unsupported "EClosure" + | EQuery _ => unsupported "Query" + | EDml _ => unsupported "DML" + | ENextval _ => unsupported "Nextval" + | EUnurlify _ => unsupported "EUnurlify" + | EJavaScript _ => unsupported "Nested JavaScript" + end + in + jsE + end + +val decl : state -> decl -> decl * state = + U.Decl.foldMapB {typ = fn x => x, + exp = fn (env, e, st) => + case e of + EJavaScript (EAbs (_, t, _, e), _) => + let + val (e, st) = jsExp true (t :: env) 0 (e, st) + in + (#1 e, st) + end + | _ => (e, st), + decl = fn (_, e, st) => (e, st), + bind = fn (env, U.Decl.RelE (_, t)) => t :: env + | (env, _) => env} + [] + +fun process file = + let + fun doDecl (d, st) = + let + val (d, st) = decl st d + in + (List.revAppend (#decls st, [d]), + {decls = [], + script = #script st}) + end + + val (ds, st) = ListUtil.foldlMapConcat doDecl + {decls = [], + script = ""} + file + in + ds + end + +end
--- a/src/mono_env.sig Fri Dec 19 12:38:11 2008 -0500 +++ b/src/mono_env.sig Sat Dec 20 14:19:21 2008 -0500 @@ -47,5 +47,6 @@ val declBinds : env -> Mono.decl -> env val patBinds : env -> Mono.pat -> env + val patBindsN : Mono.pat -> int end
--- a/src/mono_env.sml Fri Dec 19 12:38:11 2008 -0500 +++ b/src/mono_env.sml Sat Dec 20 14:19:21 2008 -0500 @@ -122,4 +122,15 @@ | PNone _ => env | PSome (_, p) => patBinds env p +fun patBindsN (p, loc) = + case p of + PWild => 0 + | PVar _ => 1 + | PPrim _ => 0 + | PCon (_, _, NONE) => 0 + | PCon (_, _, SOME p) => patBindsN p + | PRecord xps => foldl (fn ((_, p, _), count) => count + patBindsN p) 0 xps + | PNone _ => 0 + | PSome (_, p) => patBindsN p + end
--- a/src/mono_opt.sml Fri Dec 19 12:38:11 2008 -0500 +++ b/src/mono_opt.sml Sat Dec 20 14:19:21 2008 -0500 @@ -360,11 +360,6 @@ | EWrite (EPrim (Prim.String ""), loc) => ERecord [] - | EJavaScript (EAbs (_, (TRecord [], _), _, (EFfiApp ("Basis", "alert", [s]), _)), loc) => - EStrcat ((EPrim (Prim.String "alert("), loc), - (EStrcat ((EFfiApp ("Basis", "jsifyString", [s]), loc), - (EPrim (Prim.String ")"), loc)), loc)) - | _ => e and optExp e = #1 (U.Exp.map {typ = typ, exp = exp} e)
--- a/src/mono_util.sig Fri Dec 19 12:38:11 2008 -0500 +++ b/src/mono_util.sig Sat Dec 20 14:19:21 2008 -0500 @@ -71,6 +71,11 @@ val exists : {typ : Mono.typ' -> bool, exp : Mono.exp' -> bool} -> Mono.exp -> bool + + val foldB : {typ : Mono.typ' * 'state -> 'state, + exp : 'context * Mono.exp' * 'state -> 'state, + bind : 'context * binder -> 'context} + -> 'context -> 'state -> Mono.exp -> 'state end structure Decl : sig @@ -95,6 +100,12 @@ exp : Mono.exp' -> Mono.exp', decl : Mono.decl' -> Mono.decl'} -> Mono.decl -> Mono.decl + + val foldMapB : {typ : Mono.typ' * 'state -> Mono.typ' * 'state, + exp : 'context * Mono.exp' * 'state -> Mono.exp' * 'state, + decl : 'context * Mono.decl' * 'state -> Mono.decl' * 'state, + bind : 'context * binder -> 'context} + -> 'context -> 'state -> Mono.decl -> Mono.decl * 'state end structure File : sig
--- a/src/mono_util.sml Fri Dec 19 12:38:11 2008 -0500 +++ b/src/mono_util.sml Sat Dec 20 14:19:21 2008 -0500 @@ -357,6 +357,13 @@ S.Return _ => true | S.Continue _ => false +fun foldB {typ, exp, bind} ctx s e = + case mapfoldB {typ = fn t => fn s => S.Continue (t, typ (t, s)), + exp = fn ctx => fn e => fn s => S.Continue (e, exp (ctx, e, s)), + bind = bind} ctx e s of + S.Continue (_, s) => s + | S.Return _ => raise Fail "MonoUtil.Exp.foldB: Impossible" + end structure Decl = struct @@ -433,6 +440,14 @@ S.Return () => raise Fail "MonoUtil.Decl.map: Impossible" | S.Continue (e, ()) => e +fun foldMapB {typ, exp, decl, bind} ctx s d = + case mapfoldB {typ = fn c => fn s => S.Continue (typ (c, s)), + exp = fn ctx => fn e => fn s => S.Continue (exp (ctx, e, s)), + decl = fn ctx => fn d => fn s => S.Continue (decl (ctx, d, s)), + bind = bind} ctx d s of + S.Continue v => v + | S.Return _ => raise Fail "MonoUtil.Decl.foldMapB: Impossible" + end structure File = struct
--- a/src/prim.sig Fri Dec 19 12:38:11 2008 -0500 +++ b/src/prim.sig Sat Dec 20 14:19:21 2008 -0500 @@ -38,4 +38,6 @@ val equal : t * t -> bool val compare : t * t -> order + val toString : t -> string + end
--- a/src/prim.sml Fri Dec 19 12:38:11 2008 -0500 +++ b/src/prim.sml Sat Dec 20 14:19:21 2008 -0500 @@ -53,6 +53,12 @@ else Real64.toString n +fun toString t = + case t of + Int n => int2s n + | Float n => float2s n + | String s => s + fun p_t_GCC t = case t of Int n => string (int2s n)
--- a/src/sources Fri Dec 19 12:38:11 2008 -0500 +++ b/src/sources Sat Dec 20 14:19:21 2008 -0500 @@ -137,6 +137,9 @@ mono_shake.sig mono_shake.sml +jscomp.sig +jscomp.sml + pathcheck.sig pathcheck.sml
--- a/tests/alert.ur Fri Dec 19 12:38:11 2008 -0500 +++ b/tests/alert.ur Sat Dec 20 14:19:21 2008 -0500 @@ -1,3 +1,3 @@ fun main () : transaction page = return <xml><body> - <a onclick={alert "You clicked it!"}>Click Me!</a> + <a onclick={alert "You clicked it! That's some fancy shooting!"}>Click Me!</a> </body></xml>