Mercurial > urweb

annotate src/name_js.sml @ 2143:4895c41b2ec6

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Make naughtyDebug use protocol-specific logging
author Adam Chlipala <adam@chlipala.net>
date Sun, 10 May 2015 12:13:12 -0400
parents 8958b580d026
children 25874084bf1f
rev   line source
adam@1847 1 (* Copyright (c) 2012-2013, Adam Chlipala
adam@1800 2 * All rights reserved.
adam@1800 3 *
adam@1800 4 * Redistribution and use in source and binary forms, with or without
adam@1800 5 * modification, are permitted provided that the following conditions are met:
adam@1800 6 *
adam@1800 7 * - Redistributions of source code must retain the above copyright notice,
adam@1800 8 * this list of conditions and the following disclaimer.
adam@1800 9 * - Redistributions in binary form must reproduce the above copyright notice,
adam@1800 10 * this list of conditions and the following disclaimer in the documentation
adam@1800 11 * and/or other materials provided with the distribution.
adam@1800 12 * - The names of contributors may not be used to endorse or promote products
adam@1800 13 * derived from this software without specific prior written permission.
adam@1800 14 *
adam@1800 15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adam@1800 16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adam@1800 17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adam@1800 18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adam@1800 19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
adam@1800 20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adam@1800 21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adam@1800 22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adam@1800 23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adam@1800 24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adam@1800 25 * POSSIBILITY OF SUCH DAMAGE.
adam@1800 26 *)
adam@1800 27
adam@1800 28 (* Phase that introduces names for fragments of JavaScript code, so that they
adam@1800 29 * may be moved to app.js and not repeated in each generated page *)
adam@1800 30
adam@1800 31 structure NameJS :> NAME_JS = struct
adam@1800 32
adam@1800 33 open Mono
adam@1800 34
adam@1800 35 structure U = MonoUtil
adam@1800 36 structure IS = IntBinarySet
adam@1800 37
adam@1800 38 val freeVars = U.Exp.foldB {typ = #2,
adam@1800 39 exp = fn (free, e, vs) =>
adam@1800 40 case e of
adam@1800 41 ERel n =>
adam@1800 42 if n < free then
adam@1800 43 vs
adam@1800 44 else
adam@1800 45 IS.add (vs, n - free)
adam@1800 46 | _ => vs,
adam@1800 47 bind = fn (free, b) =>
adam@1800 48 case b of
adam@1800 49 U.Exp.RelE _ => free+1
adam@1800 50 | _ => free}
adam@1800 51 0 IS.empty
adam@1800 52
adam@1800 53 fun index (ls, v) =
adam@1800 54 case ls of
adam@1800 55 [] => raise Fail "NameJs.index"
adam@1800 56 | v' :: ls' => if v = v' then 0 else 1 + index (ls', v)
adam@1800 57
adam@1800 58 fun squish vs = U.Exp.mapB {typ = fn x => x,
adam@1800 59 exp = fn free => fn e =>
adam@1800 60 case e of
adam@1800 61 ERel n =>
adam@1800 62 if n < free then
adam@1800 63 e
adam@1800 64 else
adam@1800 65 ERel (free + index (vs, n - free) + 1)
adam@1800 66 | _ => e,
adam@1800 67 bind = fn (free, b) =>
adam@1800 68 case b of
adam@1800 69 U.Exp.RelE _ => free+1
adam@1800 70 | _ => free}
adam@1800 71 0
adam@1800 72
adam@1800 73 fun rewrite file =
adam@1800 74 let
adam@1847 75 fun isTricky' dontName e =
adam@1847 76 case e of
adam@1847 77 ENamed n => IS.member (dontName, n)
adam@1847 78 | EFfiApp ("Basis", "sigString", _) => true
adam@1847 79 | _ => false
adam@1847 80
adam@1847 81 fun isTricky dontName = U.Decl.exists {typ = fn _ => false,
adam@1847 82 exp = isTricky' dontName,
adam@1847 83 decl = fn _ => false}
adam@1847 84
adam@1847 85 fun isTrickyE dontName = U.Exp.exists {typ = fn _ => false,
adam@1847 86 exp = isTricky' dontName}
adam@1847 87
adam@1847 88 val dontName = foldl (fn (d, dontName) =>
adam@1847 89 if isTricky dontName d then
adam@1847 90 case #1 d of
adam@1847 91 DVal (_, n, _, _, _) => IS.add (dontName, n)
adam@1847 92 | DValRec vis => foldl (fn ((_, n, _, _, _), dontName) => IS.add (dontName, n)) dontName vis
adam@1847 93 | _ => dontName
adam@1847 94 else
adam@1847 95 dontName) IS.empty (#1 file)
adam@1847 96
adam@1845 97 val (ds, _) = ListUtil.foldlMapConcat (fn (d, nextName) =>
adam@1800 98 let
adam@1800 99 val (d, (nextName, newDs)) =
adam@1800 100 U.Decl.foldMapB {typ = fn x => x,
adam@1800 101 decl = fn (_, e, s) => (e, s),
adam@1800 102 exp = fn (env, e, st as (nextName, newDs)) =>
adam@1800 103 case e of
adam@1800 104 EJavaScript (mode, e') =>
adam@1800 105 (case mode of
adam@1800 106 Source _ => (e, st)
adam@1800 107 | _ =>
adam@1800 108 let
adam@1800 109 fun isTrulySimple (e, _) =
adam@1800 110 case e of
adam@1800 111 ERel _ => true
adam@1800 112 | ENamed _ => true
adam@1800 113 | ERecord [] => true
adam@1800 114 | _ => false
adam@1800 115
adam@1800 116 fun isAlreadySimple e =
adam@1800 117 case #1 e of
adam@1800 118 EApp (e, arg) => isTrulySimple arg andalso isAlreadySimple e
adam@1800 119 | _ => isTrulySimple e
adam@1800 120 in
adam@1847 121 if isAlreadySimple e' orelse isTrickyE dontName e' then
adam@1800 122 (e, st)
adam@1800 123 else
adam@1800 124 let
adam@1800 125 val loc = #2 e'
adam@1800 126
adam@1800 127 val vs = freeVars e'
adam@1800 128 val vs = IS.listItems vs
adam@1800 129
adam@1800 130 val x = "script" ^ Int.toString nextName
adam@1800 131
adam@1800 132 val un = (TRecord [], loc)
adam@1800 133 val s = (TFfi ("Basis", "string"), loc)
adam@1800 134 val base = (TFun (un, s), loc)
adam@1800 135 val t = foldl (fn (n, t) => (TFun (#2 (List.nth (env, n)), t), loc)) base vs
adam@1800 136 val e' = squish vs e'
adam@1800 137 val e' = (EAbs ("_", un, s, e'), loc)
adam@1800 138 val (e', _) = foldl (fn (n, (e', t)) =>
adam@1800 139 let
adam@1800 140 val (x, this) = List.nth (env, n)
adam@1800 141 in
adam@1800 142 ((EAbs (x, this, t, e'), loc),
adam@1800 143 (TFun (this, t), loc))
adam@1800 144 end) (e', base) vs
adam@1800 145 val d = (x, nextName, t, e', "<script>")
adam@1800 146
adam@1800 147 val e = (ENamed nextName, loc)
adam@1800 148 val e = foldr (fn (n, e) => (EApp (e, (ERel n, loc)), loc)) e vs
adam@1800 149 val e = (EApp (e, (ERecord [], loc)), loc)
adam@1800 150 val e = EJavaScript (Script, e)
adam@1800 151 in
adam@1800 152 (e, (nextName+1, d :: newDs))
adam@1800 153 end
adam@1800 154 end)
adam@1800 155 | _ => (e, st),
adam@1800 156 bind = fn (env, b) =>
adam@1800 157 case b of
adam@1800 158 U.Decl.RelE x => x :: env
adam@1800 159 | _ => env}
adam@1800 160 [] (nextName, []) d
adam@1800 161 in
adam@1800 162 (case newDs of
adam@1800 163 [] => [d]
adam@1800 164 | _ => case #1 d of
adam@1800 165 DValRec vis => [(DValRec (vis @ newDs), #2 d)]
adam@1800 166 | _ => List.revAppend (map (fn vi => (DVal vi, #2 d)) newDs, [d]),
adam@1800 167 nextName)
adam@1845 168 end) (U.File.maxName file + 1) (#1 file)
adam@1800 169 in
adam@1845 170 (ds, #2 file)
adam@1800 171 end
adam@1800 172
adam@1800 173 end