# HG changeset patch # User Adam Chlipala # Date 1343945557 14400 # Node ID 38297294cf9883970058c8a44495d37d1f46e237 # Parent 3d922a28370bc3543011ee0f55ad7000d4b6e6f0 New NameJs phase, still needing some debugging diff -r 3d922a28370b -r 38297294cf98 src/compiler.sig --- a/src/compiler.sig Thu Aug 02 16:33:25 2012 -0400 +++ b/src/compiler.sig Thu Aug 02 18:12:37 2012 -0400 @@ -115,6 +115,7 @@ val mono_reduce : (Mono.file, Mono.file) phase val mono_shake : (Mono.file, Mono.file) phase val iflow : (Mono.file, Mono.file) phase + val namejs : (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 @@ -167,6 +168,8 @@ val toMono_shake : (string, Mono.file) transform val toMono_opt2 : (string, Mono.file) transform val toIflow : (string, Mono.file) transform + val toNamejs : (string, Mono.file) transform + val toNamejs_untangle : (string, Mono.file) transform val toJscomp : (string, Mono.file) transform val toMono_opt3 : (string, Mono.file) transform val toFuse : (string, Mono.file) transform diff -r 3d922a28370b -r 38297294cf98 src/compiler.sml --- a/src/compiler.sml Thu Aug 02 16:33:25 2012 -0400 +++ b/src/compiler.sml Thu Aug 02 18:12:37 2012 -0400 @@ -1346,12 +1346,21 @@ val toIflow = transform iflow "iflow" o toMono_opt2 +val namejs = { + func = NameJS.rewrite, + print = MonoPrint.p_file MonoEnv.empty +} + +val toNamejs = transform namejs "namejs" o toIflow + +val toNamejs_untangle = transform untangle "namejs_untangle" o toNamejs + val jscomp = { func = JsComp.process, print = MonoPrint.p_file MonoEnv.empty } -val toJscomp = transform jscomp "jscomp" o toIflow +val toJscomp = transform jscomp "jscomp" o toNamejs_untangle val toMono_opt3 = transform mono_opt "mono_opt3" o toJscomp diff -r 3d922a28370b -r 38297294cf98 src/mono_util.sig --- a/src/mono_util.sig Thu Aug 02 16:33:25 2012 -0400 +++ b/src/mono_util.sig Thu Aug 02 18:12:37 2012 -0400 @@ -107,6 +107,11 @@ decl : Mono.decl' -> Mono.decl'} -> Mono.decl -> Mono.decl + val foldMap : {typ : Mono.typ' * 'state -> Mono.typ' * 'state, + exp : Mono.exp' * 'state -> Mono.exp' * 'state, + decl : Mono.decl' * 'state -> Mono.decl' * 'state} + -> 'state -> Mono.decl -> Mono.decl * 'state + 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, diff -r 3d922a28370b -r 38297294cf98 src/mono_util.sml --- a/src/mono_util.sml Thu Aug 02 16:33:25 2012 -0400 +++ b/src/mono_util.sml Thu Aug 02 18:12:37 2012 -0400 @@ -639,6 +639,13 @@ S.Return () => raise Fail "MonoUtil.Decl.map: Impossible" | S.Continue (e, ()) => e +fun foldMap {typ, exp, decl} s d = + case mapfold {typ = fn c => fn s => S.Continue (typ (c, s)), + exp = fn e => fn s => S.Continue (exp (e, s)), + decl = fn d => fn s => S.Continue (decl (d, s))} d s of + S.Continue v => v + | S.Return _ => raise Fail "MonoUtil.Decl.foldMap: Impossible" + 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)), diff -r 3d922a28370b -r 38297294cf98 src/monoize.sml --- a/src/monoize.sml Thu Aug 02 16:33:25 2012 -0400 +++ b/src/monoize.sml Thu Aug 02 18:12:37 2012 -0400 @@ -3478,9 +3478,9 @@ val t = (L'.TFfi ("Basis", "string"), loc) val setClass = (L'.ECase (class, - [((L'.PNone t, loc), + [((L'.PPrim (Prim.String ""), loc), str ""), - ((L'.PSome (t, (L'.PVar ("x", t), loc)), loc), + ((L'.PVar ("x", t), loc), (L'.EStrcat ((L'.EPrim (Prim.String "d.className=\""), loc), (L'.EStrcat ((L'.ERel 0, loc), (L'.EPrim (Prim.String "\";"), loc)), loc)), diff -r 3d922a28370b -r 38297294cf98 src/name_js.sig --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/name_js.sig Thu Aug 02 18:12:37 2012 -0400 @@ -0,0 +1,35 @@ +(* Copyright (c) 2012, 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. + *) + +(* Phase that introduces names for fragments of JavaScript code, so that they + * may be moved to app.js and not repeated in each generated page *) + +signature NAME_JS = sig + + val rewrite : Mono.file -> Mono.file + +end diff -r 3d922a28370b -r 38297294cf98 src/name_js.sml --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/name_js.sml Thu Aug 02 18:12:37 2012 -0400 @@ -0,0 +1,151 @@ +(* Copyright (c) 2012, 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. + *) + +(* Phase that introduces names for fragments of JavaScript code, so that they + * may be moved to app.js and not repeated in each generated page *) + +structure NameJS :> NAME_JS = struct + +open Mono + +structure U = MonoUtil +structure IS = IntBinarySet + +val freeVars = U.Exp.foldB {typ = #2, + exp = fn (free, e, vs) => + case e of + ERel n => + if n < free then + vs + else + IS.add (vs, n - free) + | _ => vs, + bind = fn (free, b) => + case b of + U.Exp.RelE _ => free+1 + | _ => free} + 0 IS.empty + +fun index (ls, v) = + case ls of + [] => raise Fail "NameJs.index" + | v' :: ls' => if v = v' then 0 else 1 + index (ls', v) + +fun squish vs = U.Exp.mapB {typ = fn x => x, + exp = fn free => fn e => + case e of + ERel n => + if n < free then + e + else + ERel (free + index (vs, n - free) + 1) + | _ => e, + bind = fn (free, b) => + case b of + U.Exp.RelE _ => free+1 + | _ => free} + 0 + +fun rewrite file = + let + val (file, _) = ListUtil.foldlMapConcat (fn (d, nextName) => + let + val (d, (nextName, newDs)) = + U.Decl.foldMapB {typ = fn x => x, + decl = fn (_, e, s) => (e, s), + exp = fn (env, e, st as (nextName, newDs)) => + case e of + EJavaScript (mode, e') => + (case mode of + Source _ => (e, st) + | _ => + let + fun isTrulySimple (e, _) = + case e of + ERel _ => true + | ENamed _ => true + | ERecord [] => true + | _ => false + + fun isAlreadySimple e = + case #1 e of + EApp (e, arg) => isTrulySimple arg andalso isAlreadySimple e + | _ => isTrulySimple e + in + if isAlreadySimple e' then + (e, st) + else + let + val loc = #2 e' + + val vs = freeVars e' + val vs = IS.listItems vs + + val x = "script" ^ Int.toString nextName + + val un = (TRecord [], loc) + val s = (TFfi ("Basis", "string"), loc) + val base = (TFun (un, s), loc) + val t = foldl (fn (n, t) => (TFun (#2 (List.nth (env, n)), t), loc)) base vs + val e' = squish vs e' + val e' = (EAbs ("_", un, s, e'), loc) + val (e', _) = foldl (fn (n, (e', t)) => + let + val (x, this) = List.nth (env, n) + in + ((EAbs (x, this, t, e'), loc), + (TFun (this, t), loc)) + end) (e', base) vs + val d = (x, nextName, t, e', "