Mercurial > urweb

annotate src/name_js.sml @ 1839:d8c260bcc1f9

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Fix determination of MySQL timestamp hour fields (may still be wrong once DST bit flips)
author Adam Chlipala <adam@chlipala.net>
date Thu, 13 Dec 2012 17:51:34 -0500
parents 38297294cf98
children c1e3805e604e
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@1800 75 val (file, _) = 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@1800 146 end) (U.File.maxName file + 1) file
adam@1800 147 in
adam@1800 148 file
adam@1800 149 end
adam@1800 150
adam@1800 151 end