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