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