Mercurial > urweb

comparison src/name_js.sml @ 1800:38297294cf98

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