adam@1847: (* Copyright (c) 2012-2013, Adam Chlipala adam@1800: * All rights reserved. adam@1800: * adam@1800: * Redistribution and use in source and binary forms, with or without adam@1800: * modification, are permitted provided that the following conditions are met: adam@1800: * adam@1800: * - Redistributions of source code must retain the above copyright notice, adam@1800: * this list of conditions and the following disclaimer. adam@1800: * - Redistributions in binary form must reproduce the above copyright notice, adam@1800: * this list of conditions and the following disclaimer in the documentation adam@1800: * and/or other materials provided with the distribution. adam@1800: * - The names of contributors may not be used to endorse or promote products adam@1800: * derived from this software without specific prior written permission. adam@1800: * adam@1800: * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" adam@1800: * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE adam@1800: * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE adam@1800: * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE ziv@2252: * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR adam@1800: * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF adam@1800: * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS adam@1800: * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN adam@1800: * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) adam@1800: * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE adam@1800: * POSSIBILITY OF SUCH DAMAGE. adam@1800: *) adam@1800: adam@1800: (* Phase that introduces names for fragments of JavaScript code, so that they adam@1800: * may be moved to app.js and not repeated in each generated page *) adam@1800: adam@1800: structure NameJS :> NAME_JS = struct adam@1800: adam@1800: open Mono adam@1800: adam@1800: structure U = MonoUtil adam@1800: structure IS = IntBinarySet adam@1800: adam@1800: val freeVars = U.Exp.foldB {typ = #2, adam@1800: exp = fn (free, e, vs) => adam@1800: case e of adam@1800: ERel n => adam@1800: if n < free then adam@1800: vs adam@1800: else adam@1800: IS.add (vs, n - free) adam@1800: | _ => vs, adam@1800: bind = fn (free, b) => adam@1800: case b of adam@1800: U.Exp.RelE _ => free+1 adam@1800: | _ => free} adam@1800: 0 IS.empty adam@1800: adam@1800: fun index (ls, v) = adam@1800: case ls of adam@1800: [] => raise Fail "NameJs.index" adam@1800: | v' :: ls' => if v = v' then 0 else 1 + index (ls', v) adam@1800: adam@1800: fun squish vs = U.Exp.mapB {typ = fn x => x, adam@1800: exp = fn free => fn e => adam@1800: case e of adam@1800: ERel n => adam@1800: if n < free then adam@1800: e adam@1800: else adam@1800: ERel (free + index (vs, n - free) + 1) adam@1800: | _ => e, adam@1800: bind = fn (free, b) => adam@1800: case b of adam@1800: U.Exp.RelE _ => free+1 adam@1800: | _ => free} adam@1800: 0 adam@1800: adam@1800: fun rewrite file = adam@1800: let adam@1847: fun isTricky' dontName e = adam@1847: case e of adam@1847: ENamed n => IS.member (dontName, n) adam@1847: | EFfiApp ("Basis", "sigString", _) => true adam@1847: | _ => false adam@1847: adam@1847: fun isTricky dontName = U.Decl.exists {typ = fn _ => false, adam@1847: exp = isTricky' dontName, adam@1847: decl = fn _ => false} adam@1847: adam@1847: fun isTrickyE dontName = U.Exp.exists {typ = fn _ => false, adam@1847: exp = isTricky' dontName} adam@1847: adam@1847: val dontName = foldl (fn (d, dontName) => adam@1847: if isTricky dontName d then adam@1847: case #1 d of adam@1847: DVal (_, n, _, _, _) => IS.add (dontName, n) adam@1847: | DValRec vis => foldl (fn ((_, n, _, _, _), dontName) => IS.add (dontName, n)) dontName vis adam@1847: | _ => dontName adam@1847: else ziv@2252: dontName) IS.empty (#1 file) adam@1847: adam@1845: val (ds, _) = ListUtil.foldlMapConcat (fn (d, nextName) => adam@1800: let adam@1800: val (d, (nextName, newDs)) = adam@1800: U.Decl.foldMapB {typ = fn x => x, adam@1800: decl = fn (_, e, s) => (e, s), adam@1800: exp = fn (env, e, st as (nextName, newDs)) => adam@1800: case e of adam@1800: EJavaScript (mode, e') => adam@1800: (case mode of adam@1800: Source _ => (e, st) adam@1800: | _ => adam@1800: let adam@1800: fun isTrulySimple (e, _) = adam@1800: case e of adam@1800: ERel _ => true adam@1800: | ENamed _ => true adam@1800: | ERecord [] => true adam@1800: | _ => false adam@1800: adam@1800: fun isAlreadySimple e = adam@1800: case #1 e of adam@1800: EApp (e, arg) => isTrulySimple arg andalso isAlreadySimple e adam@1800: | _ => isTrulySimple e adam@1800: in adam@1847: if isAlreadySimple e' orelse isTrickyE dontName e' then adam@1800: (e, st) adam@1800: else adam@1800: let adam@1800: val loc = #2 e' adam@1800: adam@1800: val vs = freeVars e' adam@1800: val vs = IS.listItems vs ziv@2252: adam@1800: val x = "script" ^ Int.toString nextName ziv@2252: adam@1800: val un = (TRecord [], loc) adam@1800: val s = (TFfi ("Basis", "string"), loc) adam@1800: val base = (TFun (un, s), loc) adam@1800: val t = foldl (fn (n, t) => (TFun (#2 (List.nth (env, n)), t), loc)) base vs adam@1800: val e' = squish vs e' adam@1800: val e' = (EAbs ("_", un, s, e'), loc) adam@1800: val (e', _) = foldl (fn (n, (e', t)) => adam@1800: let adam@1800: val (x, this) = List.nth (env, n) adam@1800: in adam@1800: ((EAbs (x, this, t, e'), loc), adam@1800: (TFun (this, t), loc)) adam@1800: end) (e', base) vs adam@1800: val d = (x, nextName, t, e', "