summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/compiler.sig3
-rw-r--r--src/compiler.sml11
-rw-r--r--src/mono_util.sig5
-rw-r--r--src/mono_util.sml7
-rw-r--r--src/monoize.sml4
-rw-r--r--src/name_js.sig35
-rw-r--r--src/name_js.sml151
-rw-r--r--src/sources3
-rw-r--r--tests/dynlines.ur33
-rw-r--r--tests/namejs.ur3
10 files changed, 252 insertions, 3 deletions
diff --git a/src/compiler.sig b/src/compiler.sig
index f23728f0..7e4f2f6a 100644
--- a/src/compiler.sig
+++ b/src/compiler.sig
@@ -115,6 +115,7 @@ signature COMPILER = sig
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 @@ signature COMPILER = sig
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 --git a/src/compiler.sml b/src/compiler.sml
index a9720cf6..d1d0484a 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -1346,12 +1346,21 @@ val iflow = {
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 --git a/src/mono_util.sig b/src/mono_util.sig
index 7ce545e1..a5118072 100644
--- a/src/mono_util.sig
+++ b/src/mono_util.sig
@@ -107,6 +107,11 @@ structure Decl : sig
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 --git a/src/mono_util.sml b/src/mono_util.sml
index 38016f85..58498996 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -639,6 +639,13 @@ fun map {typ, exp, decl} e =
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 --git a/src/monoize.sml b/src/monoize.sml
index 371e1d43..1b9c97ed 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -3478,9 +3478,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
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 --git a/src/name_js.sig b/src/name_js.sig
new file mode 100644
index 00000000..6750b7a7
--- /dev/null
+++ b/src/name_js.sig
@@ -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 --git a/src/name_js.sml b/src/name_js.sml
new file mode 100644
index 00000000..70ac000c
--- /dev/null
+++ b/src/name_js.sml
@@ -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
diff --git a/src/sources b/src/sources
index 551d4ca5..b49f0ba8 100644
--- a/src/sources
+++ b/src/sources
@@ -188,6 +188,9 @@ sql.sml
iflow.sig
iflow.sml
+name_js.sig
+name_js.sml
+
jscomp.sig
jscomp.sml
diff --git a/tests/dynlines.ur b/tests/dynlines.ur
new file mode 100644
index 00000000..92866e69
--- /dev/null
+++ b/tests/dynlines.ur
@@ -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>
diff --git a/tests/namejs.ur b/tests/namejs.ur
new file mode 100644
index 00000000..50f6f52c
--- /dev/null
+++ b/tests/namejs.ur
@@ -0,0 +1,3 @@
+fun main (n : int) (s : string) : transaction page = return <xml><body>
+ <button onclick={fn _ => alert ("n = " ^ show n ^ "; s = " ^ s)}/>
+</body></xml>
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-02 02:12:34 +0000