adamc@567
|
1 (* Copyright (c) 2008, Adam Chlipala
|
adamc@567
|
2 * All rights reserved.
|
adamc@567
|
3 *
|
adamc@567
|
4 * Redistribution and use in source and binary forms, with or without
|
adamc@567
|
5 * modification, are permitted provided that the following conditions are met:
|
adamc@567
|
6 *
|
adamc@567
|
7 * - Redistributions of source code must retain the above copyright notice,
|
adamc@567
|
8 * this list of conditions and the following disclaimer.
|
adamc@567
|
9 * - Redistributions in binary form must reproduce the above copyright notice,
|
adamc@567
|
10 * this list of conditions and the following disclaimer in the documentation
|
adamc@567
|
11 * and/or other materials provided with the distribution.
|
adamc@567
|
12 * - The names of contributors may not be used to endorse or promote products
|
adamc@567
|
13 * derived from this software without specific prior written permission.
|
adamc@567
|
14 *
|
adamc@567
|
15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
|
adamc@567
|
16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
|
adamc@567
|
17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
adamc@567
|
18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
|
adamc@567
|
19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
adamc@567
|
20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
adamc@567
|
21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
adamc@567
|
22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
adamc@567
|
23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
adamc@567
|
24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
adamc@567
|
25 * POSSIBILITY OF SUCH DAMAGE.
|
adamc@567
|
26 *)
|
adamc@567
|
27
|
adamc@567
|
28 structure JsComp :> JSCOMP = struct
|
adamc@567
|
29
|
adamc@567
|
30 open Mono
|
adamc@567
|
31
|
adamc@567
|
32 structure EM = ErrorMsg
|
adamc@567
|
33 structure E = MonoEnv
|
adamc@567
|
34 structure U = MonoUtil
|
adamc@567
|
35
|
adamc@572
|
36 val funcs = [(("Basis", "alert"), "alert"),
|
adamc@583
|
37 (("Basis", "htmlifyFloat"), "ts"),
|
adamc@582
|
38 (("Basis", "htmlifyInt"), "ts"),
|
adamc@574
|
39 (("Basis", "htmlifyString"), "escape"),
|
adamc@579
|
40 (("Basis", "new_client_source"), "sc"),
|
adamc@579
|
41 (("Basis", "set_client_source"), "sv")]
|
adamc@572
|
42
|
adamc@572
|
43 structure FM = BinaryMapFn(struct
|
adamc@572
|
44 type ord_key = string * string
|
adamc@572
|
45 fun compare ((m1, x1), (m2, x2)) =
|
adamc@572
|
46 Order.join (String.compare (m1, m2),
|
adamc@572
|
47 fn () => String.compare (x1, x2))
|
adamc@572
|
48 end)
|
adamc@572
|
49
|
adamc@572
|
50 val funcs = foldl (fn ((k, v), m) => FM.insert (m, k, v)) FM.empty funcs
|
adamc@572
|
51
|
adamc@572
|
52 fun ffi k = FM.find (funcs, k)
|
adamc@572
|
53
|
adamc@567
|
54 type state = {
|
adamc@567
|
55 decls : decl list,
|
adamc@567
|
56 script : string
|
adamc@567
|
57 }
|
adamc@567
|
58
|
adamc@567
|
59 fun varDepth (e, _) =
|
adamc@567
|
60 case e of
|
adamc@567
|
61 EPrim _ => 0
|
adamc@567
|
62 | ERel _ => 0
|
adamc@567
|
63 | ENamed _ => 0
|
adamc@567
|
64 | ECon (_, _, NONE) => 0
|
adamc@567
|
65 | ECon (_, _, SOME e) => varDepth e
|
adamc@567
|
66 | ENone _ => 0
|
adamc@567
|
67 | ESome (_, e) => varDepth e
|
adamc@567
|
68 | EFfi _ => 0
|
adamc@567
|
69 | EFfiApp (_, _, es) => foldl Int.max 0 (map varDepth es)
|
adamc@567
|
70 | EApp (e1, e2) => Int.max (varDepth e1, varDepth e2)
|
adamc@567
|
71 | EAbs _ => 0
|
adamc@567
|
72 | EUnop (_, e) => varDepth e
|
adamc@567
|
73 | EBinop (_, e1, e2) => Int.max (varDepth e1, varDepth e2)
|
adamc@567
|
74 | ERecord xes => foldl Int.max 0 (map (fn (_, e, _) => varDepth e) xes)
|
adamc@567
|
75 | EField (e, _) => varDepth e
|
adamc@567
|
76 | ECase (e, pes, _) =>
|
adamc@567
|
77 foldl Int.max (varDepth e)
|
adamc@567
|
78 (map (fn (p, e) => E.patBindsN p + varDepth e) pes)
|
adamc@567
|
79 | EStrcat (e1, e2) => Int.max (varDepth e1, varDepth e2)
|
adamc@567
|
80 | EError (e, _) => varDepth e
|
adamc@567
|
81 | EWrite e => varDepth e
|
adamc@567
|
82 | ESeq (e1, e2) => Int.max (varDepth e1, varDepth e2)
|
adamc@567
|
83 | ELet (_, _, e1, e2) => Int.max (varDepth e1, 1 + varDepth e2)
|
adamc@567
|
84 | EClosure _ => 0
|
adamc@567
|
85 | EQuery _ => 0
|
adamc@567
|
86 | EDml _ => 0
|
adamc@567
|
87 | ENextval _ => 0
|
adamc@567
|
88 | EUnurlify _ => 0
|
adamc@567
|
89 | EJavaScript _ => 0
|
adamc@568
|
90 | ESignalReturn e => varDepth e
|
adamc@572
|
91 | ESignalBind (e1, e2) => Int.max (varDepth e1, varDepth e2)
|
adamc@574
|
92 | ESignalSource e => varDepth e
|
adamc@567
|
93
|
adamc@568
|
94 fun strcat loc es =
|
adamc@568
|
95 case es of
|
adamc@568
|
96 [] => (EPrim (Prim.String ""), loc)
|
adamc@568
|
97 | [x] => x
|
adamc@568
|
98 | x :: es' => (EStrcat (x, strcat loc es'), loc)
|
adamc@568
|
99
|
adamc@579
|
100 fun jsExp mode skip outer =
|
adamc@567
|
101 let
|
adamc@567
|
102 val len = length outer
|
adamc@567
|
103
|
adamc@567
|
104 fun jsE inner (e as (_, loc), st) =
|
adamc@567
|
105 let
|
adamc@567
|
106 fun str s = (EPrim (Prim.String s), loc)
|
adamc@567
|
107
|
adamc@567
|
108 fun var n = Int.toString (len + inner - n - 1)
|
adamc@567
|
109
|
adamc@567
|
110 fun patCon pc =
|
adamc@567
|
111 case pc of
|
adamc@567
|
112 PConVar n => str (Int.toString n)
|
adamc@567
|
113 | PConFfi {con, ...} => str ("\"_" ^ con ^ "\"")
|
adamc@567
|
114
|
adamc@567
|
115 fun isNullable (t, _) =
|
adamc@567
|
116 case t of
|
adamc@567
|
117 TOption _ => true
|
adamc@583
|
118 | TRecord [] => true
|
adamc@567
|
119 | _ => false
|
adamc@567
|
120
|
adamc@567
|
121 fun unsupported s =
|
adamc@567
|
122 (EM.errorAt loc (s ^ " in code to be compiled to JavaScript");
|
adamc@567
|
123 (str "ERROR", st))
|
adamc@568
|
124
|
adamc@568
|
125 val strcat = strcat loc
|
adamc@577
|
126
|
adamc@577
|
127 fun quoteExp (t : typ) e =
|
adamc@577
|
128 case #1 t of
|
adamc@577
|
129 TSource => strcat [str "s",
|
adamc@577
|
130 (EFfiApp ("Basis", "htmlifyInt", [e]), loc)]
|
adamc@579
|
131 | TRecord [] => str "null"
|
adamc@579
|
132 | TFfi ("Basis", "string") => e
|
adamc@577
|
133 | _ => (EM.errorAt loc "Don't know how to embed type in JavaScript";
|
adamc@579
|
134 Print.prefaces "Can't embed" [("t", MonoPrint.p_typ MonoEnv.empty t)];
|
adamc@577
|
135 str "ERROR")
|
adamc@584
|
136
|
adamc@584
|
137 fun jsPrim p =
|
adamc@584
|
138 case p of
|
adamc@584
|
139 Prim.String s =>
|
adamc@584
|
140 str ("\""
|
adamc@584
|
141 ^ String.translate (fn #"'" =>
|
adamc@584
|
142 if mode = Attribute then
|
adamc@584
|
143 "\\047"
|
adamc@584
|
144 else
|
adamc@584
|
145 "'"
|
adamc@584
|
146 | #"\"" => "\\\""
|
adamc@584
|
147 | #"<" =>
|
adamc@584
|
148 if mode = Script then
|
adamc@584
|
149 "<"
|
adamc@584
|
150 else
|
adamc@584
|
151 "\\074"
|
adamc@584
|
152 | #"\\" => "\\\\"
|
adamc@584
|
153 | ch => String.str ch) s
|
adamc@584
|
154 ^ "\"")
|
adamc@584
|
155 | _ => str (Prim.toString p)
|
adamc@584
|
156
|
adamc@585
|
157 fun jsPat depth inner (p, _) succ fail =
|
adamc@584
|
158 case p of
|
adamc@584
|
159 PWild => succ
|
adamc@585
|
160 | PVar _ => strcat [str ("(_" ^ Int.toString (len + inner) ^ "=d" ^ Int.toString depth ^ ","),
|
adamc@584
|
161 succ,
|
adamc@584
|
162 str ")"]
|
adamc@585
|
163 | PPrim p => strcat [str ("(d" ^ Int.toString depth ^ "=="),
|
adamc@584
|
164 jsPrim p,
|
adamc@584
|
165 str "?",
|
adamc@584
|
166 succ,
|
adamc@584
|
167 str ":",
|
adamc@584
|
168 fail,
|
adamc@584
|
169 str ")"]
|
adamc@584
|
170 | PCon _ => raise Fail "jsPat: PCon"
|
adamc@584
|
171 | PRecord xps =>
|
adamc@584
|
172 let
|
adamc@584
|
173 val (_, succ) = foldl
|
adamc@584
|
174 (fn ((x, p, _), (inner, succ)) =>
|
adamc@584
|
175 (inner + E.patBindsN p,
|
adamc@585
|
176 strcat [str ("(d" ^ Int.toString (depth+1) ^ "=d"
|
adamc@585
|
177 ^ Int.toString depth ^ "._" ^ x ^ ","),
|
adamc@585
|
178 jsPat (depth+1) inner p succ fail,
|
adamc@585
|
179 str ")"]))
|
adamc@584
|
180 (inner, succ) xps
|
adamc@584
|
181 in
|
adamc@584
|
182 succ
|
adamc@584
|
183 end
|
adamc@585
|
184 | PNone _ => strcat [str ("(d" ^ Int.toString depth ^ "?"),
|
adamc@584
|
185 fail,
|
adamc@584
|
186 str ":",
|
adamc@584
|
187 succ,
|
adamc@584
|
188 str ")"]
|
adamc@585
|
189 | PSome (_, p) => strcat [str ("(d" ^ Int.toString depth ^ "?"),
|
adamc@585
|
190 jsPat depth inner p succ fail,
|
adamc@584
|
191 str ":",
|
adamc@584
|
192 fail,
|
adamc@584
|
193 str ")"]
|
adamc@567
|
194 in
|
adamc@567
|
195 case #1 e of
|
adamc@584
|
196 EPrim p => (jsPrim p, st)
|
adamc@567
|
197 | ERel n =>
|
adamc@567
|
198 if n < inner then
|
adamc@583
|
199 (str ("_" ^ var n), st)
|
adamc@567
|
200 else
|
adamc@577
|
201 let
|
adamc@577
|
202 val n = n - inner
|
adamc@577
|
203 in
|
adamc@579
|
204 (quoteExp (List.nth (outer, n)) (ERel (n - skip), loc), st)
|
adamc@577
|
205 end
|
adamc@567
|
206 | ENamed _ => raise Fail "Named"
|
adamc@567
|
207 | ECon (_, pc, NONE) => (patCon pc, st)
|
adamc@567
|
208 | ECon (_, pc, SOME e) =>
|
adamc@567
|
209 let
|
adamc@567
|
210 val (s, st) = jsE inner (e, st)
|
adamc@567
|
211 in
|
adamc@567
|
212 (strcat [str "{n:",
|
adamc@567
|
213 patCon pc,
|
adamc@567
|
214 str ",v:",
|
adamc@567
|
215 s,
|
adamc@567
|
216 str "}"], st)
|
adamc@567
|
217 end
|
adamc@567
|
218 | ENone _ => (str "null", st)
|
adamc@567
|
219 | ESome (t, e) =>
|
adamc@567
|
220 let
|
adamc@567
|
221 val (e, st) = jsE inner (e, st)
|
adamc@567
|
222 in
|
adamc@567
|
223 (if isNullable t then
|
adamc@567
|
224 strcat [str "{v:", e, str "}"]
|
adamc@567
|
225 else
|
adamc@567
|
226 e, st)
|
adamc@567
|
227 end
|
adamc@567
|
228
|
adamc@572
|
229 | EFfi k =>
|
adamc@567
|
230 let
|
adamc@572
|
231 val name = case ffi k of
|
adamc@574
|
232 NONE => (EM.errorAt loc ("Unsupported FFI identifier " ^ #2 k ^ " in JavaScript");
|
adamc@572
|
233 "ERROR")
|
adamc@572
|
234 | SOME s => s
|
adamc@567
|
235 in
|
adamc@572
|
236 (str name, st)
|
adamc@567
|
237 end
|
adamc@572
|
238 | EFfiApp (m, x, args) =>
|
adamc@567
|
239 let
|
adamc@578
|
240 val args =
|
adamc@578
|
241 case (m, x, args) of
|
adamc@578
|
242 ("Basis", "new_client_source", [(EJavaScript (_, e, _), _)]) => [e]
|
adamc@578
|
243 | ("Basis", "set_client_source", [e1, (EJavaScript (_, e2, _), _)]) => [e1, e2]
|
adamc@578
|
244 | _ => args
|
adamc@578
|
245
|
adamc@572
|
246 val name = case ffi (m, x) of
|
adamc@574
|
247 NONE => (EM.errorAt loc ("Unsupported FFI function " ^ x ^ " in JavaScript");
|
adamc@572
|
248 "ERROR")
|
adamc@572
|
249 | SOME s => s
|
adamc@567
|
250 in
|
adamc@572
|
251 case args of
|
adamc@572
|
252 [] => (str (name ^ "()"), st)
|
adamc@572
|
253 | [e] =>
|
adamc@572
|
254 let
|
adamc@572
|
255 val (e, st) = jsE inner (e, st)
|
adamc@572
|
256 in
|
adamc@572
|
257 (strcat [str (name ^ "("),
|
adamc@572
|
258 e,
|
adamc@572
|
259 str ")"], st)
|
adamc@572
|
260 end
|
adamc@572
|
261 | e :: es =>
|
adamc@572
|
262 let
|
adamc@572
|
263 val (e, st) = jsE inner (e, st)
|
adamc@572
|
264 val (es, st) = ListUtil.foldlMapConcat
|
adamc@572
|
265 (fn (e, st) =>
|
adamc@572
|
266 let
|
adamc@572
|
267 val (e, st) = jsE inner (e, st)
|
adamc@572
|
268 in
|
adamc@572
|
269 ([str ",", e], st)
|
adamc@572
|
270 end)
|
adamc@572
|
271 st es
|
adamc@572
|
272 in
|
adamc@572
|
273 (strcat (str (name ^ "(")
|
adamc@572
|
274 :: e
|
adamc@572
|
275 :: es
|
adamc@572
|
276 @ [str ")"]), st)
|
adamc@572
|
277 end
|
adamc@567
|
278 end
|
adamc@567
|
279
|
adamc@567
|
280 | EApp (e1, e2) =>
|
adamc@567
|
281 let
|
adamc@567
|
282 val (e1, st) = jsE inner (e1, st)
|
adamc@567
|
283 val (e2, st) = jsE inner (e2, st)
|
adamc@567
|
284 in
|
adamc@567
|
285 (strcat [e1, str "(", e2, str ")"], st)
|
adamc@567
|
286 end
|
adamc@567
|
287 | EAbs (_, _, _, e) =>
|
adamc@567
|
288 let
|
adamc@567
|
289 val locals = List.tabulate
|
adamc@567
|
290 (varDepth e,
|
adamc@585
|
291 fn i => str ("var _" ^ Int.toString (len + inner + i + 1) ^ ";"))
|
adamc@567
|
292 val (e, st) = jsE (inner + 1) (e, st)
|
adamc@567
|
293 in
|
adamc@583
|
294 (strcat (str ("function(_"
|
adamc@567
|
295 ^ Int.toString (len + inner)
|
adamc@567
|
296 ^ "){")
|
adamc@567
|
297 :: locals
|
adamc@567
|
298 @ [str "return ",
|
adamc@567
|
299 e,
|
adamc@567
|
300 str "}"]),
|
adamc@567
|
301 st)
|
adamc@567
|
302 end
|
adamc@567
|
303
|
adamc@567
|
304 | EUnop (s, e) =>
|
adamc@567
|
305 let
|
adamc@567
|
306 val (e, st) = jsE inner (e, st)
|
adamc@567
|
307 in
|
adamc@567
|
308 (strcat [str ("(" ^ s),
|
adamc@567
|
309 e,
|
adamc@567
|
310 str ")"],
|
adamc@567
|
311 st)
|
adamc@567
|
312 end
|
adamc@567
|
313 | EBinop (s, e1, e2) =>
|
adamc@567
|
314 let
|
adamc@567
|
315 val (e1, st) = jsE inner (e1, st)
|
adamc@567
|
316 val (e2, st) = jsE inner (e2, st)
|
adamc@567
|
317 in
|
adamc@567
|
318 (strcat [str "(",
|
adamc@567
|
319 e1,
|
adamc@567
|
320 str s,
|
adamc@567
|
321 e2,
|
adamc@567
|
322 str ")"],
|
adamc@567
|
323 st)
|
adamc@567
|
324 end
|
adamc@567
|
325
|
adamc@567
|
326 | ERecord [] => (str "null", st)
|
adamc@567
|
327 | ERecord [(x, e, _)] =>
|
adamc@567
|
328 let
|
adamc@567
|
329 val (e, st) = jsE inner (e, st)
|
adamc@567
|
330 in
|
adamc@583
|
331 (strcat [str "{_x:", e, str "}"], st)
|
adamc@567
|
332 end
|
adamc@567
|
333 | ERecord ((x, e, _) :: xes) =>
|
adamc@567
|
334 let
|
adamc@567
|
335 val (e, st) = jsE inner (e, st)
|
adamc@567
|
336
|
adamc@567
|
337 val (es, st) =
|
adamc@567
|
338 foldr (fn ((x, e, _), (es, st)) =>
|
adamc@567
|
339 let
|
adamc@567
|
340 val (e, st) = jsE inner (e, st)
|
adamc@567
|
341 in
|
adamc@583
|
342 (str (",_" ^ x ^ ":")
|
adamc@567
|
343 :: e
|
adamc@567
|
344 :: es,
|
adamc@567
|
345 st)
|
adamc@567
|
346 end)
|
adamc@567
|
347 ([str "}"], st) xes
|
adamc@567
|
348 in
|
adamc@583
|
349 (strcat (str ("{_" ^ x ^ ":")
|
adamc@567
|
350 :: e
|
adamc@567
|
351 :: es),
|
adamc@567
|
352 st)
|
adamc@567
|
353 end
|
adamc@567
|
354 | EField (e, x) =>
|
adamc@567
|
355 let
|
adamc@567
|
356 val (e, st) = jsE inner (e, st)
|
adamc@567
|
357 in
|
adamc@567
|
358 (strcat [e,
|
adamc@583
|
359 str ("._" ^ x)], st)
|
adamc@567
|
360 end
|
adamc@567
|
361
|
adamc@584
|
362 | ECase (e, pes, _) =>
|
adamc@584
|
363 let
|
adamc@584
|
364 val plen = length pes
|
adamc@584
|
365
|
adamc@584
|
366 val (cases, st) = ListUtil.foldliMap
|
adamc@584
|
367 (fn (i, (p, e), st) =>
|
adamc@584
|
368 let
|
adamc@584
|
369 val (e, st) = jsE (inner + E.patBindsN p) (e, st)
|
adamc@584
|
370 val fail =
|
adamc@584
|
371 if i = plen - 1 then
|
adamc@584
|
372 str "pf()"
|
adamc@584
|
373 else
|
adamc@584
|
374 str ("c" ^ Int.toString (i+1) ^ "()")
|
adamc@585
|
375 val c = jsPat 0 inner p e fail
|
adamc@584
|
376 in
|
adamc@584
|
377 (strcat [str ("c" ^ Int.toString i ^ "=function(){return "),
|
adamc@584
|
378 c,
|
adamc@584
|
379 str "},"],
|
adamc@584
|
380 st)
|
adamc@584
|
381 end)
|
adamc@584
|
382 st pes
|
adamc@584
|
383
|
adamc@584
|
384 val (e, st) = jsE inner (e, st)
|
adamc@584
|
385 in
|
adamc@584
|
386 (strcat (str "("
|
adamc@584
|
387 :: List.revAppend (cases,
|
adamc@585
|
388 [str "d0=",
|
adamc@584
|
389 e,
|
adamc@584
|
390 str ",c0())"])), st)
|
adamc@584
|
391 end
|
adamc@567
|
392
|
adamc@567
|
393 | EStrcat (e1, e2) =>
|
adamc@567
|
394 let
|
adamc@567
|
395 val (e1, st) = jsE inner (e1, st)
|
adamc@567
|
396 val (e2, st) = jsE inner (e2, st)
|
adamc@567
|
397 in
|
adamc@567
|
398 (strcat [str "(", e1, str "+", e2, str ")"], st)
|
adamc@567
|
399 end
|
adamc@567
|
400
|
adamc@567
|
401 | EError (e, _) =>
|
adamc@567
|
402 let
|
adamc@567
|
403 val (e, st) = jsE inner (e, st)
|
adamc@567
|
404 in
|
adamc@567
|
405 (strcat [str "alert(\"ERROR: \"+", e, str ")"],
|
adamc@567
|
406 st)
|
adamc@567
|
407 end
|
adamc@567
|
408
|
adamc@568
|
409 | EWrite e =>
|
adamc@568
|
410 let
|
adamc@568
|
411 val (e, st) = jsE inner (e, st)
|
adamc@568
|
412 in
|
adamc@568
|
413 (strcat [str "document.write(",
|
adamc@568
|
414 e,
|
adamc@569
|
415 str ".v)"], st)
|
adamc@568
|
416 end
|
adamc@567
|
417
|
adamc@567
|
418 | ESeq (e1, e2) =>
|
adamc@567
|
419 let
|
adamc@567
|
420 val (e1, st) = jsE inner (e1, st)
|
adamc@567
|
421 val (e2, st) = jsE inner (e2, st)
|
adamc@567
|
422 in
|
adamc@567
|
423 (strcat [str "(", e1, str ",", e2, str ")"], st)
|
adamc@567
|
424 end
|
adamc@567
|
425 | ELet (_, _, e1, e2) =>
|
adamc@567
|
426 let
|
adamc@567
|
427 val (e1, st) = jsE inner (e1, st)
|
adamc@567
|
428 val (e2, st) = jsE (inner + 1) (e2, st)
|
adamc@567
|
429 in
|
adamc@583
|
430 (strcat [str ("(_" ^ Int.toString (len + inner) ^ "="),
|
adamc@567
|
431 e1,
|
adamc@567
|
432 str ",",
|
adamc@567
|
433 e2,
|
adamc@567
|
434 str ")"], st)
|
adamc@567
|
435 end
|
adamc@567
|
436
|
adamc@567
|
437 | EClosure _ => unsupported "EClosure"
|
adamc@567
|
438 | EQuery _ => unsupported "Query"
|
adamc@567
|
439 | EDml _ => unsupported "DML"
|
adamc@567
|
440 | ENextval _ => unsupported "Nextval"
|
adamc@567
|
441 | EUnurlify _ => unsupported "EUnurlify"
|
adamc@567
|
442 | EJavaScript _ => unsupported "Nested JavaScript"
|
adamc@568
|
443 | ESignalReturn e =>
|
adamc@568
|
444 let
|
adamc@568
|
445 val (e, st) = jsE inner (e, st)
|
adamc@568
|
446 in
|
adamc@572
|
447 (strcat [str "sr(",
|
adamc@569
|
448 e,
|
adamc@569
|
449 str ")"],
|
adamc@568
|
450 st)
|
adamc@568
|
451 end
|
adamc@572
|
452 | ESignalBind (e1, e2) =>
|
adamc@572
|
453 let
|
adamc@572
|
454 val (e1, st) = jsE inner (e1, st)
|
adamc@572
|
455 val (e2, st) = jsE inner (e2, st)
|
adamc@572
|
456 in
|
adamc@572
|
457 (strcat [str "sb(",
|
adamc@572
|
458 e1,
|
adamc@572
|
459 str ",",
|
adamc@572
|
460 e2,
|
adamc@572
|
461 str ")"],
|
adamc@572
|
462 st)
|
adamc@572
|
463 end
|
adamc@574
|
464 | ESignalSource e =>
|
adamc@574
|
465 let
|
adamc@574
|
466 val (e, st) = jsE inner (e, st)
|
adamc@574
|
467 in
|
adamc@574
|
468 (strcat [str "ss(",
|
adamc@574
|
469 e,
|
adamc@574
|
470 str ")"],
|
adamc@574
|
471 st)
|
adamc@574
|
472 end
|
adamc@567
|
473 end
|
adamc@567
|
474 in
|
adamc@567
|
475 jsE
|
adamc@567
|
476 end
|
adamc@567
|
477
|
adamc@567
|
478 val decl : state -> decl -> decl * state =
|
adamc@567
|
479 U.Decl.foldMapB {typ = fn x => x,
|
adamc@567
|
480 exp = fn (env, e, st) =>
|
adamc@568
|
481 let
|
adamc@579
|
482 fun doCode m skip env orig e =
|
adamc@568
|
483 let
|
adamc@568
|
484 val len = length env
|
adamc@568
|
485 fun str s = (EPrim (Prim.String s), #2 e)
|
adamc@568
|
486
|
adamc@568
|
487 val locals = List.tabulate
|
adamc@568
|
488 (varDepth e,
|
adamc@583
|
489 fn i => str ("var _" ^ Int.toString (len + i) ^ ";"))
|
adamc@579
|
490 val (e, st) = jsExp m skip env 0 (e, st)
|
adamc@568
|
491 in
|
adamc@578
|
492 (EJavaScript (m, orig, SOME (strcat (#2 e) (locals @ [e]))), st)
|
adamc@568
|
493 end
|
adamc@568
|
494 in
|
adamc@568
|
495 case e of
|
adamc@579
|
496 EJavaScript (m, orig as (EAbs (_, t, _, e), _), _) => doCode m 1 (t :: env) orig e
|
adamc@579
|
497 | EJavaScript (m, e, _) => doCode m 0 env e e
|
adamc@568
|
498 | _ => (e, st)
|
adamc@568
|
499 end,
|
adamc@567
|
500 decl = fn (_, e, st) => (e, st),
|
adamc@567
|
501 bind = fn (env, U.Decl.RelE (_, t)) => t :: env
|
adamc@567
|
502 | (env, _) => env}
|
adamc@567
|
503 []
|
adamc@567
|
504
|
adamc@567
|
505 fun process file =
|
adamc@567
|
506 let
|
adamc@567
|
507 fun doDecl (d, st) =
|
adamc@567
|
508 let
|
adamc@567
|
509 val (d, st) = decl st d
|
adamc@567
|
510 in
|
adamc@567
|
511 (List.revAppend (#decls st, [d]),
|
adamc@567
|
512 {decls = [],
|
adamc@567
|
513 script = #script st})
|
adamc@567
|
514 end
|
adamc@567
|
515
|
adamc@567
|
516 val (ds, st) = ListUtil.foldlMapConcat doDecl
|
adamc@567
|
517 {decls = [],
|
adamc@567
|
518 script = ""}
|
adamc@567
|
519 file
|
adamc@569
|
520
|
adamc@569
|
521 val inf = TextIO.openIn (OS.Path.joinDirFile {dir = Config.libJs, file = "urweb.js"})
|
adamc@569
|
522 fun lines acc =
|
adamc@569
|
523 case TextIO.inputLine inf of
|
adamc@569
|
524 NONE => String.concat (rev acc)
|
adamc@569
|
525 | SOME line => lines (line :: acc)
|
adamc@569
|
526 val lines = lines []
|
adamc@567
|
527 in
|
adamc@569
|
528 TextIO.closeIn inf;
|
adamc@569
|
529 (DJavaScript lines, ErrorMsg.dummySpan) :: ds
|
adamc@567
|
530 end
|
adamc@567
|
531
|
adamc@567
|
532 end
|