Mercurial > urweb
changeset 1800:38297294cf98
New NameJs phase, still needing some debugging
| author | Adam Chlipala <adam@chlipala.net> |
|---|---|
| date | Thu, 02 Aug 2012 18:12:37 -0400 |
| parents | 3d922a28370b |
| children | 5c51ae0d643b |
| files | src/compiler.sig src/compiler.sml src/mono_util.sig src/mono_util.sml src/monoize.sml src/name_js.sig src/name_js.sml src/sources tests/dynlines.ur tests/namejs.ur |
| diffstat | 10 files changed, 252 insertions(+), 3 deletions(-) [+] |
line wrap: on
line diff
--- 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
--- 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
--- 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,
--- 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)),
--- 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)),
--- /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
--- /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', "<script>") + + val e = (ENamed nextName, loc) + val e = foldr (fn (n, e) => (EApp (e, (ERel n, loc)), loc)) e vs + val e = (EApp (e, (ERecord [], loc)), loc) + val e = EJavaScript (Script, e) + in + (e, (nextName+1, d :: newDs)) + end + end) + | _ => (e, st), + bind = fn (env, b) => + case b of + U.Decl.RelE x => x :: env + | _ => env} + [] (nextName, []) d + in + (case newDs of + [] => [d] + | _ => case #1 d of + DValRec vis => [(DValRec (vis @ newDs), #2 d)] + | _ => List.revAppend (map (fn vi => (DVal vi, #2 d)) newDs, [d]), + nextName) + end) (U.File.maxName file + 1) file + in + file + end + +end
--- a/src/sources Thu Aug 02 16:33:25 2012 -0400 +++ b/src/sources Thu Aug 02 18:12:37 2012 -0400 @@ -188,6 +188,9 @@ iflow.sig iflow.sml +name_js.sig +name_js.sml + jscomp.sig jscomp.sml
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/dynlines.ur Thu Aug 02 18:12:37 2012 -0400 @@ -0,0 +1,33 @@ +datatype lines = End | Line of source lines + +type t = { Head : source lines, Tail : source (source lines) } + +val create = + head <- source End; + tail <- source head; + return {Head = head, Tail = tail} + +fun renderL lines = + case lines of + End => <xml/> + | Line linesS => <xml>X<br/><dyn signal={renderS linesS}/></xml> + +and renderS linesS = + lines <- signal linesS; + return (renderL lines) + +fun render t = renderS t.Head + +fun write t = + oldTail <- get t.Tail; + newTail <- source End; + set oldTail (Line newTail); + set t.Tail newTail + +fun main () : transaction page = + b <- create; + + return <xml><body> + <button onclick={fn _ => write b}/> + <dyn signal={render b}/> + </body></xml>