Mercurial > urweb

comparison src/jscomp.sml @ 567:1901db85acb4

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Start of JsComp
author Adam Chlipala <adamc@hcoop.net>
date Sat, 20 Dec 2008 14:19:21 -0500
parents
children 55fc747a67dc
comparison
equal deleted inserted replaced
566:a152905c3c3b 567:1901db85acb4
1 (* Copyright (c) 2008, 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 structure JsComp :> JSCOMP = struct
29
30 open Mono
31
32 structure EM = ErrorMsg
33 structure E = MonoEnv
34 structure U = MonoUtil
35
36 type state = {
37 decls : decl list,
38 script : string
39 }
40
41 fun varDepth (e, _) =
42 case e of
43 EPrim _ => 0
44 | ERel _ => 0
45 | ENamed _ => 0
46 | ECon (_, _, NONE) => 0
47 | ECon (_, _, SOME e) => varDepth e
48 | ENone _ => 0
49 | ESome (_, e) => varDepth e
50 | EFfi _ => 0
51 | EFfiApp (_, _, es) => foldl Int.max 0 (map varDepth es)
52 | EApp (e1, e2) => Int.max (varDepth e1, varDepth e2)
53 | EAbs _ => 0
54 | EUnop (_, e) => varDepth e
55 | EBinop (_, e1, e2) => Int.max (varDepth e1, varDepth e2)
56 | ERecord xes => foldl Int.max 0 (map (fn (_, e, _) => varDepth e) xes)
57 | EField (e, _) => varDepth e
58 | ECase (e, pes, _) =>
59 foldl Int.max (varDepth e)
60 (map (fn (p, e) => E.patBindsN p + varDepth e) pes)
61 | EStrcat (e1, e2) => Int.max (varDepth e1, varDepth e2)
62 | EError (e, _) => varDepth e
63 | EWrite e => varDepth e
64 | ESeq (e1, e2) => Int.max (varDepth e1, varDepth e2)
65 | ELet (_, _, e1, e2) => Int.max (varDepth e1, 1 + varDepth e2)
66 | EClosure _ => 0
67 | EQuery _ => 0
68 | EDml _ => 0
69 | ENextval _ => 0
70 | EUnurlify _ => 0
71 | EJavaScript _ => 0
72
73 fun jsExp inAttr outer =
74 let
75 val len = length outer
76
77 fun jsE inner (e as (_, loc), st) =
78 let
79 fun str s = (EPrim (Prim.String s), loc)
80
81 fun var n = Int.toString (len + inner - n - 1)
82
83 fun patCon pc =
84 case pc of
85 PConVar n => str (Int.toString n)
86 | PConFfi {con, ...} => str ("\"_" ^ con ^ "\"")
87
88 fun strcat es =
89 case es of
90 [] => (EPrim (Prim.String ""), loc)
91 | [x] => x
92 | x :: es' => (EStrcat (x, strcat es'), loc)
93
94 fun isNullable (t, _) =
95 case t of
96 TOption _ => true
97 | _ => false
98
99 fun unsupported s =
100 (EM.errorAt loc (s ^ " in code to be compiled to JavaScript");
101 (str "ERROR", st))
102 in
103 case #1 e of
104 EPrim (Prim.String s) =>
105 (str ("\""
106 ^ String.translate (fn #"'" =>
107 if inAttr then
108 "\\047"
109 else
110 "'"
111 | #"<" =>
112 if inAttr then
113 "<"
114 else
115 "\\074"
116 | #"\\" => "\\\\"
117 | ch => String.str ch) s
118 ^ "\""), st)
119 | EPrim p => (str (Prim.toString p), st)
120 | ERel n =>
121 if n < inner then
122 (str ("uwr" ^ var n), st)
123 else
124 (str ("uwo" ^ var n), st)
125 | ENamed _ => raise Fail "Named"
126 | ECon (_, pc, NONE) => (patCon pc, st)
127 | ECon (_, pc, SOME e) =>
128 let
129 val (s, st) = jsE inner (e, st)
130 in
131 (strcat [str "{n:",
132 patCon pc,
133 str ",v:",
134 s,
135 str "}"], st)
136 end
137 | ENone _ => (str "null", st)
138 | ESome (t, e) =>
139 let
140 val (e, st) = jsE inner (e, st)
141 in
142 (if isNullable t then
143 strcat [str "{v:", e, str "}"]
144 else
145 e, st)
146 end
147
148 | EFfi (_, s) => (str s, st)
149 | EFfiApp (_, s, []) => (str (s ^ "()"), st)
150 | EFfiApp (_, s, [e]) =>
151 let
152 val (e, st) = jsE inner (e, st)
153
154 in
155 (strcat [str (s ^ "("),
156 e,
157 str ")"], st)
158 end
159 | EFfiApp (_, s, e :: es) =>
160 let
161 val (e, st) = jsE inner (e, st)
162 val (es, st) = ListUtil.foldlMapConcat
163 (fn (e, st) =>
164 let
165 val (e, st) = jsE inner (e, st)
166 in
167 ([str ",", e], st)
168 end)
169 st es
170 in
171 (strcat (str (s ^ "(")
172 :: e
173 :: es
174 @ [str ")"]), st)
175 end
176
177 | EApp (e1, e2) =>
178 let
179 val (e1, st) = jsE inner (e1, st)
180 val (e2, st) = jsE inner (e2, st)
181 in
182 (strcat [e1, str "(", e2, str ")"], st)
183 end
184 | EAbs (_, _, _, e) =>
185 let
186 val locals = List.tabulate
187 (varDepth e,
188 fn i => str ("var uwr" ^ Int.toString (len + inner + i) ^ ";"))
189 val (e, st) = jsE (inner + 1) (e, st)
190 in
191 (strcat (str ("function(uwr"
192 ^ Int.toString (len + inner)
193 ^ "){")
194 :: locals
195 @ [str "return ",
196 e,
197 str "}"]),
198 st)
199 end
200
201 | EUnop (s, e) =>
202 let
203 val (e, st) = jsE inner (e, st)
204 in
205 (strcat [str ("(" ^ s),
206 e,
207 str ")"],
208 st)
209 end
210 | EBinop (s, e1, e2) =>
211 let
212 val (e1, st) = jsE inner (e1, st)
213 val (e2, st) = jsE inner (e2, st)
214 in
215 (strcat [str "(",
216 e1,
217 str s,
218 e2,
219 str ")"],
220 st)
221 end
222
223 | ERecord [] => (str "null", st)
224 | ERecord [(x, e, _)] =>
225 let
226 val (e, st) = jsE inner (e, st)
227 in
228 (strcat [str "{uw_x:", e, str "}"], st)
229 end
230 | ERecord ((x, e, _) :: xes) =>
231 let
232 val (e, st) = jsE inner (e, st)
233
234 val (es, st) =
235 foldr (fn ((x, e, _), (es, st)) =>
236 let
237 val (e, st) = jsE inner (e, st)
238 in
239 (str (",uw_" ^ x ^ ":")
240 :: e
241 :: es,
242 st)
243 end)
244 ([str "}"], st) xes
245 in
246 (strcat (str ("{uw_" ^ x ^ ":")
247 :: e
248 :: es),
249 st)
250 end
251 | EField (e, x) =>
252 let
253 val (e, st) = jsE inner (e, st)
254 in
255 (strcat [e,
256 str ("." ^ x)], st)
257 end
258
259 | ECase _ => raise Fail "Jscomp: ECase"
260
261 | EStrcat (e1, e2) =>
262 let
263 val (e1, st) = jsE inner (e1, st)
264 val (e2, st) = jsE inner (e2, st)
265 in
266 (strcat [str "(", e1, str "+", e2, str ")"], st)
267 end
268
269 | EError (e, _) =>
270 let
271 val (e, st) = jsE inner (e, st)
272 in
273 (strcat [str "alert(\"ERROR: \"+", e, str ")"],
274 st)
275 end
276
277 | EWrite _ => unsupported "EWrite"
278
279 | ESeq (e1, e2) =>
280 let
281 val (e1, st) = jsE inner (e1, st)
282 val (e2, st) = jsE inner (e2, st)
283 in
284 (strcat [str "(", e1, str ",", e2, str ")"], st)
285 end
286 | ELet (_, _, e1, e2) =>
287 let
288 val (e1, st) = jsE inner (e1, st)
289 val (e2, st) = jsE (inner + 1) (e2, st)
290 in
291 (strcat [str ("(uwr" ^ Int.toString (len + inner) ^ "="),
292 e1,
293 str ",",
294 e2,
295 str ")"], st)
296 end
297
298 | EClosure _ => unsupported "EClosure"
299 | EQuery _ => unsupported "Query"
300 | EDml _ => unsupported "DML"
301 | ENextval _ => unsupported "Nextval"
302 | EUnurlify _ => unsupported "EUnurlify"
303 | EJavaScript _ => unsupported "Nested JavaScript"
304 end
305 in
306 jsE
307 end
308
309 val decl : state -> decl -> decl * state =
310 U.Decl.foldMapB {typ = fn x => x,
311 exp = fn (env, e, st) =>
312 case e of
313 EJavaScript (EAbs (_, t, _, e), _) =>
314 let
315 val (e, st) = jsExp true (t :: env) 0 (e, st)
316 in
317 (#1 e, st)
318 end
319 | _ => (e, st),
320 decl = fn (_, e, st) => (e, st),
321 bind = fn (env, U.Decl.RelE (_, t)) => t :: env
322 | (env, _) => env}
323 []
324
325 fun process file =
326 let
327 fun doDecl (d, st) =
328 let
329 val (d, st) = decl st d
330 in
331 (List.revAppend (#decls st, [d]),
332 {decls = [],
333 script = #script st})
334 end
335
336 val (ds, st) = ListUtil.foldlMapConcat doDecl
337 {decls = [],
338 script = ""}
339 file
340 in
341 ds
342 end
343
344 end