Mercurial > urweb

annotate src/name_js.sml @ 1845:c1e3805e604e

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Make Scriptcheck catch more script/message-passing uses, and move the phase earlier in compilation
author Adam Chlipala <adam@chlipala.net>
date Fri, 15 Mar 2013 16:09:55 -0400
parents 38297294cf98
children 8958b580d026
rev   line source
adam@1800 1 (* Copyright (c) 2012, 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@1845 75 val (ds, _) = ListUtil.foldlMapConcat (fn (d, nextName) =>
adam@1800 76 let
adam@1800 77 val (d, (nextName, newDs)) =
adam@1800 78 U.Decl.foldMapB {typ = fn x => x,
adam@1800 79 decl = fn (_, e, s) => (e, s),
adam@1800 80 exp = fn (env, e, st as (nextName, newDs)) =>
adam@1800 81 case e of
adam@1800 82 EJavaScript (mode, e') =>
adam@1800 83 (case mode of
adam@1800 84 Source _ => (e, st)
adam@1800 85 | _ =>
adam@1800 86 let
adam@1800 87 fun isTrulySimple (e, _) =
adam@1800 88 case e of
adam@1800 89 ERel _ => true
adam@1800 90 | ENamed _ => true
adam@1800 91 | ERecord [] => true
adam@1800 92 | _ => false
adam@1800 93
adam@1800 94 fun isAlreadySimple e =
adam@1800 95 case #1 e of
adam@1800 96 EApp (e, arg) => isTrulySimple arg andalso isAlreadySimple e
adam@1800 97 | _ => isTrulySimple e
adam@1800 98 in
adam@1800 99 if isAlreadySimple e' then
adam@1800 100 (e, st)
adam@1800 101 else
adam@1800 102 let
adam@1800 103 val loc = #2 e'
adam@1800 104
adam@1800 105 val vs = freeVars e'
adam@1800 106 val vs = IS.listItems vs
adam@1800 107
adam@1800 108 val x = "script" ^ Int.toString nextName
adam@1800 109
adam@1800 110 val un = (TRecord [], loc)
adam@1800 111 val s = (TFfi ("Basis", "string"), loc)
adam@1800 112 val base = (TFun (un, s), loc)
adam@1800 113 val t = foldl (fn (n, t) => (TFun (#2 (List.nth (env, n)), t), loc)) base vs
adam@1800 114 val e' = squish vs e'
adam@1800 115 val e' = (EAbs ("_", un, s, e'), loc)
adam@1800 116 val (e', _) = foldl (fn (n, (e', t)) =>
adam@1800 117 let
adam@1800 118 val (x, this) = List.nth (env, n)
adam@1800 119 in
adam@1800 120 ((EAbs (x, this, t, e'), loc),
adam@1800 121 (TFun (this, t), loc))
adam@1800 122 end) (e', base) vs
adam@1800 123 val d = (x, nextName, t, e', "<script>")
adam@1800 124
adam@1800 125 val e = (ENamed nextName, loc)
adam@1800 126 val e = foldr (fn (n, e) => (EApp (e, (ERel n, loc)), loc)) e vs
adam@1800 127 val e = (EApp (e, (ERecord [], loc)), loc)
adam@1800 128 val e = EJavaScript (Script, e)
adam@1800 129 in
adam@1800 130 (e, (nextName+1, d :: newDs))
adam@1800 131 end
adam@1800 132 end)
adam@1800 133 | _ => (e, st),
adam@1800 134 bind = fn (env, b) =>
adam@1800 135 case b of
adam@1800 136 U.Decl.RelE x => x :: env
adam@1800 137 | _ => env}
adam@1800 138 [] (nextName, []) d
adam@1800 139 in
adam@1800 140 (case newDs of
adam@1800 141 [] => [d]
adam@1800 142 | _ => case #1 d of
adam@1800 143 DValRec vis => [(DValRec (vis @ newDs), #2 d)]
adam@1800 144 | _ => List.revAppend (map (fn vi => (DVal vi, #2 d)) newDs, [d]),
adam@1800 145 nextName)
adam@1845 146 end) (U.File.maxName file + 1) (#1 file)
adam@1800 147 in
adam@1845 148 (ds, #2 file)
adam@1800 149 end
adam@1800 150
adam@1800 151 end