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@800
|
39 structure TM = BinaryMapFn(struct
|
adamc@800
|
40 type ord_key = typ
|
adamc@800
|
41 val compare = U.Typ.compare
|
adamc@800
|
42 end)
|
adamc@800
|
43
|
adamc@567
|
44 type state = {
|
adamc@567
|
45 decls : decl list,
|
adamc@589
|
46 script : string list,
|
adamc@595
|
47 included : IS.set,
|
adamc@595
|
48 injectors : int IM.map,
|
adamc@800
|
49 listInjectors : int TM.map,
|
adamc@638
|
50 decoders : int IM.map,
|
adamc@595
|
51 maxName : int
|
adamc@567
|
52 }
|
adamc@567
|
53
|
adamc@567
|
54 fun varDepth (e, _) =
|
adamc@567
|
55 case e of
|
adamc@567
|
56 EPrim _ => 0
|
adamc@567
|
57 | ERel _ => 0
|
adamc@567
|
58 | ENamed _ => 0
|
adamc@567
|
59 | ECon (_, _, NONE) => 0
|
adamc@567
|
60 | ECon (_, _, SOME e) => varDepth e
|
adamc@567
|
61 | ENone _ => 0
|
adamc@567
|
62 | ESome (_, e) => varDepth e
|
adamc@567
|
63 | EFfi _ => 0
|
adamc@567
|
64 | EFfiApp (_, _, es) => foldl Int.max 0 (map varDepth es)
|
adamc@567
|
65 | EApp (e1, e2) => Int.max (varDepth e1, varDepth e2)
|
adamc@567
|
66 | EAbs _ => 0
|
adamc@567
|
67 | EUnop (_, e) => varDepth e
|
adamc@567
|
68 | EBinop (_, e1, e2) => Int.max (varDepth e1, varDepth e2)
|
adamc@567
|
69 | ERecord xes => foldl Int.max 0 (map (fn (_, e, _) => varDepth e) xes)
|
adamc@567
|
70 | EField (e, _) => varDepth e
|
adamc@567
|
71 | ECase (e, pes, _) =>
|
adamc@567
|
72 foldl Int.max (varDepth e)
|
adamc@567
|
73 (map (fn (p, e) => E.patBindsN p + varDepth e) pes)
|
adamc@567
|
74 | EStrcat (e1, e2) => Int.max (varDepth e1, varDepth e2)
|
adamc@567
|
75 | EError (e, _) => varDepth e
|
adamc@741
|
76 | EReturnBlob {blob = e1, mimeType = e2, ...} => Int.max (varDepth e1, varDepth e2)
|
adamc@567
|
77 | EWrite e => varDepth e
|
adamc@567
|
78 | ESeq (e1, e2) => Int.max (varDepth e1, varDepth e2)
|
adamc@567
|
79 | ELet (_, _, e1, e2) => Int.max (varDepth e1, 1 + varDepth e2)
|
adamc@567
|
80 | EClosure _ => 0
|
adamc@567
|
81 | EQuery _ => 0
|
adamc@567
|
82 | EDml _ => 0
|
adamc@567
|
83 | ENextval _ => 0
|
adamc@567
|
84 | EUnurlify _ => 0
|
adamc@567
|
85 | EJavaScript _ => 0
|
adamc@568
|
86 | ESignalReturn e => varDepth e
|
adamc@572
|
87 | ESignalBind (e1, e2) => Int.max (varDepth e1, varDepth e2)
|
adamc@574
|
88 | ESignalSource e => varDepth e
|
adamc@736
|
89 | EServerCall (e, ek, _, _) => Int.max (varDepth e, varDepth ek)
|
adamc@670
|
90 | ERecv (e, ek, _) => Int.max (varDepth e, varDepth ek)
|
adamc@695
|
91 | ESleep (e, ek) => Int.max (varDepth e, varDepth ek)
|
adamc@567
|
92
|
adamc@591
|
93 fun closedUpto d =
|
adamc@591
|
94 let
|
adamc@591
|
95 fun cu inner (e, _) =
|
adamc@591
|
96 case e of
|
adamc@591
|
97 EPrim _ => true
|
adamc@591
|
98 | ERel n => n < inner orelse n - inner >= d
|
adamc@591
|
99 | ENamed _ => true
|
adamc@591
|
100 | ECon (_, _, NONE) => true
|
adamc@591
|
101 | ECon (_, _, SOME e) => cu inner e
|
adamc@591
|
102 | ENone _ => true
|
adamc@591
|
103 | ESome (_, e) => cu inner e
|
adamc@591
|
104 | EFfi _ => true
|
adamc@591
|
105 | EFfiApp (_, _, es) => List.all (cu inner) es
|
adamc@591
|
106 | EApp (e1, e2) => cu inner e1 andalso cu inner e2
|
adamc@591
|
107 | EAbs (_, _, _, e) => cu (inner + 1) e
|
adamc@591
|
108 | EUnop (_, e) => cu inner e
|
adamc@591
|
109 | EBinop (_, e1, e2) => cu inner e1 andalso cu inner e2
|
adamc@591
|
110 | ERecord xes => List.all (fn (_, e, _) => cu inner e) xes
|
adamc@591
|
111 | EField (e, _) => cu inner e
|
adamc@591
|
112 | ECase (e, pes, _) =>
|
adamc@591
|
113 cu inner e
|
adamc@591
|
114 andalso List.all (fn (p, e) => cu (inner + E.patBindsN p) e) pes
|
adamc@591
|
115 | EStrcat (e1, e2) => cu inner e1 andalso cu inner e2
|
adamc@591
|
116 | EError (e, _) => cu inner e
|
adamc@741
|
117 | EReturnBlob {blob = e1, mimeType = e2, ...} => cu inner e1 andalso cu inner e2
|
adamc@591
|
118 | EWrite e => cu inner e
|
adamc@591
|
119 | ESeq (e1, e2) => cu inner e1 andalso cu inner e2
|
adamc@591
|
120 | ELet (_, _, e1, e2) => cu inner e1 andalso cu (inner + 1) e2
|
adamc@591
|
121 | EClosure (_, es) => List.all (cu inner) es
|
adamc@591
|
122 | EQuery {query, body, initial, ...} =>
|
adamc@591
|
123 cu inner query
|
adamc@591
|
124 andalso cu (inner + 2) body
|
adamc@591
|
125 andalso cu inner initial
|
adamc@591
|
126 | EDml e => cu inner e
|
adamc@591
|
127 | ENextval e => cu inner e
|
adamc@591
|
128 | EUnurlify (e, _) => cu inner e
|
adamc@591
|
129 | EJavaScript (_, e, _) => cu inner e
|
adamc@591
|
130 | ESignalReturn e => cu inner e
|
adamc@591
|
131 | ESignalBind (e1, e2) => cu inner e1 andalso cu inner e2
|
adamc@591
|
132 | ESignalSource e => cu inner e
|
adamc@736
|
133 | EServerCall (e, ek, _, _) => cu inner e andalso cu inner ek
|
adamc@670
|
134 | ERecv (e, ek, _) => cu inner e andalso cu inner ek
|
adamc@695
|
135 | ESleep (e, ek) => cu inner e andalso cu inner ek
|
adamc@591
|
136 in
|
adamc@591
|
137 cu 0
|
adamc@591
|
138 end
|
adamc@591
|
139
|
adamc@568
|
140 fun strcat loc es =
|
adamc@568
|
141 case es of
|
adamc@568
|
142 [] => (EPrim (Prim.String ""), loc)
|
adamc@568
|
143 | [x] => x
|
adamc@568
|
144 | x :: es' => (EStrcat (x, strcat loc es'), loc)
|
adamc@568
|
145
|
adamc@589
|
146 fun process file =
|
adamc@567
|
147 let
|
adamc@596
|
148 val (someTs, nameds) =
|
adamc@596
|
149 foldl (fn ((DVal (_, n, t, e, _), _), (someTs, nameds)) => (someTs, IM.insert (nameds, n, e))
|
adamc@596
|
150 | ((DValRec vis, _), (someTs, nameds)) =>
|
adamc@596
|
151 (someTs, foldl (fn ((_, n, _, e, _), nameds) => IM.insert (nameds, n, e))
|
adamc@596
|
152 nameds vis)
|
adamc@596
|
153 | ((DDatatype (_, _, cs), _), state as (someTs, nameds)) =>
|
adamc@596
|
154 if ElabUtil.classifyDatatype cs = Option then
|
adamc@596
|
155 (foldl (fn ((_, n, SOME t), someTs) => IM.insert (someTs, n, t)
|
adamc@596
|
156 | (_, someTs) => someTs) someTs cs,
|
adamc@596
|
157 nameds)
|
adamc@596
|
158 else
|
adamc@596
|
159 state
|
adamc@595
|
160 | (_, state) => state)
|
adamc@596
|
161 (IM.empty, IM.empty) file
|
adamc@567
|
162
|
adamc@590
|
163 fun str loc s = (EPrim (Prim.String s), loc)
|
adamc@590
|
164
|
adamc@594
|
165 fun isNullable (t, _) =
|
adamc@594
|
166 case t of
|
adamc@594
|
167 TOption _ => true
|
adamc@594
|
168 | TRecord [] => true
|
adamc@594
|
169 | _ => false
|
adamc@594
|
170
|
adamc@593
|
171 fun quoteExp loc (t : typ) (e, st) =
|
adamc@590
|
172 case #1 t of
|
adamc@593
|
173 TSource => (strcat loc [str loc "s",
|
adamc@593
|
174 (EFfiApp ("Basis", "htmlifyInt", [e]), loc)], st)
|
adamc@590
|
175
|
adamc@593
|
176 | TRecord [] => (str loc "null", st)
|
adamc@593
|
177 | TRecord [(x, t)] =>
|
adamc@593
|
178 let
|
adamc@593
|
179 val (e, st) = quoteExp loc t ((EField (e, x), loc), st)
|
adamc@593
|
180 in
|
adamc@593
|
181 (strcat loc [str loc ("{_" ^ x ^ ":"),
|
adamc@593
|
182 e,
|
adamc@593
|
183 str loc "}"], st)
|
adamc@593
|
184 end
|
adamc@593
|
185 | TRecord ((x, t) :: xts) =>
|
adamc@593
|
186 let
|
adamc@593
|
187 val (e', st) = quoteExp loc t ((EField (e, x), loc), st)
|
adamc@593
|
188 val (es, st) = ListUtil.foldlMap
|
adamc@593
|
189 (fn ((x, t), st) =>
|
adamc@593
|
190 let
|
adamc@593
|
191 val (e, st) = quoteExp loc t ((EField (e, x), loc), st)
|
adamc@593
|
192 in
|
adamc@593
|
193 (strcat loc [str loc (",_" ^ x ^ ":"), e], st)
|
adamc@593
|
194 end)
|
adamc@593
|
195 st xts
|
adamc@593
|
196 in
|
adamc@593
|
197 (strcat loc (str loc ("{_" ^ x ^ ":")
|
adamc@593
|
198 :: e'
|
adamc@593
|
199 :: es
|
adamc@593
|
200 @ [str loc "}"]), st)
|
adamc@593
|
201 end
|
adamc@590
|
202
|
adamc@593
|
203 | TFfi ("Basis", "string") => ((EFfiApp ("Basis", "jsifyString", [e]), loc), st)
|
adamc@593
|
204 | TFfi ("Basis", "int") => ((EFfiApp ("Basis", "htmlifyInt", [e]), loc), st)
|
adamc@593
|
205 | TFfi ("Basis", "float") => ((EFfiApp ("Basis", "htmlifyFloat", [e]), loc), st)
|
adamc@682
|
206 | TFfi ("Basis", "channel") => ((EFfiApp ("Basis", "jsifyChannel", [e]), loc), st)
|
adamc@593
|
207
|
adamc@593
|
208 | TFfi ("Basis", "bool") => ((ECase (e,
|
adamc@593
|
209 [((PCon (Enum, PConFfi {mod = "Basis",
|
adamc@593
|
210 datatyp = "bool",
|
adamc@593
|
211 con = "True",
|
adamc@593
|
212 arg = NONE}, NONE), loc),
|
adamc@593
|
213 str loc "true"),
|
adamc@593
|
214 ((PCon (Enum, PConFfi {mod = "Basis",
|
adamc@593
|
215 datatyp = "bool",
|
adamc@593
|
216 con = "False",
|
adamc@593
|
217 arg = NONE}, NONE), loc),
|
adamc@593
|
218 str loc "false")],
|
adamc@593
|
219 {disc = (TFfi ("Basis", "bool"), loc),
|
adamc@593
|
220 result = (TFfi ("Basis", "string"), loc)}), loc),
|
adamc@593
|
221 st)
|
adamc@592
|
222
|
adamc@594
|
223 | TOption t =>
|
adamc@594
|
224 let
|
adamc@594
|
225 val (e', st) = quoteExp loc t ((ERel 0, loc), st)
|
adamc@594
|
226 in
|
adamc@594
|
227 ((ECase (e,
|
adamc@594
|
228 [((PNone t, loc),
|
adamc@594
|
229 str loc "null"),
|
adamc@594
|
230 ((PSome (t, (PVar ("x", t), loc)), loc),
|
adamc@594
|
231 if isNullable t then
|
adamc@594
|
232 strcat loc [str loc "{v:", e', str loc "}"]
|
adamc@594
|
233 else
|
adamc@594
|
234 e')],
|
adamc@594
|
235 {disc = (TOption t, loc),
|
adamc@594
|
236 result = (TFfi ("Basis", "string"), loc)}), loc),
|
adamc@594
|
237 st)
|
adamc@594
|
238 end
|
adamc@594
|
239
|
adamc@800
|
240 | TList t' =>
|
adamc@800
|
241 (case TM.find (#listInjectors st, t') of
|
adamc@800
|
242 SOME n' => ((EApp ((ENamed n', loc), e), loc), st)
|
adamc@800
|
243 | NONE =>
|
adamc@800
|
244 let
|
adamc@800
|
245 val rt = (TRecord [("1", t'), ("2", t)], loc)
|
adamc@800
|
246
|
adamc@800
|
247 val n' = #maxName st
|
adamc@800
|
248 val st = {decls = #decls st,
|
adamc@800
|
249 script = #script st,
|
adamc@800
|
250 included = #included st,
|
adamc@800
|
251 injectors = #injectors st,
|
adamc@800
|
252 listInjectors = TM.insert (#listInjectors st, t', n'),
|
adamc@800
|
253 decoders = #decoders st,
|
adamc@800
|
254 maxName = n' + 1}
|
adamc@800
|
255
|
adamc@800
|
256 val s = (TFfi ("Basis", "string"), loc)
|
adamc@800
|
257 val (e', st) = quoteExp loc t ((EField ((ERel 0, loc), "1"), loc), st)
|
adamc@800
|
258
|
adamc@800
|
259 val body = (ECase ((ERel 0, loc),
|
adamc@800
|
260 [((PNone rt, loc),
|
adamc@800
|
261 str loc "null"),
|
adamc@800
|
262 ((PSome (rt, (PVar ("x", rt), loc)), loc),
|
adamc@800
|
263 strcat loc [str loc "{v:{_1:",
|
adamc@800
|
264 e',
|
adamc@800
|
265 str loc ",_2:",
|
adamc@800
|
266 (EApp ((ENamed n', loc),
|
adamc@800
|
267 (EField ((ERel 0, loc), "2"), loc)), loc),
|
adamc@800
|
268 str loc "}}"])],
|
adamc@800
|
269 {disc = t, result = s}), loc)
|
adamc@800
|
270 val body = (EAbs ("x", t, s, body), loc)
|
adamc@800
|
271
|
adamc@800
|
272 val st = {decls = (DValRec [("jsify", n', (TFun (t, s), loc),
|
adamc@800
|
273 body, "jsify")], loc) :: #decls st,
|
adamc@800
|
274 script = #script st,
|
adamc@800
|
275 included = #included st,
|
adamc@800
|
276 injectors = #injectors st,
|
adamc@800
|
277 listInjectors = #listInjectors st,
|
adamc@800
|
278 decoders= #decoders st,
|
adamc@800
|
279 maxName = #maxName st}
|
adamc@800
|
280
|
adamc@800
|
281
|
adamc@800
|
282 in
|
adamc@800
|
283 ((EApp ((ENamed n', loc), e), loc), st)
|
adamc@800
|
284 end)
|
adamc@800
|
285
|
adamc@595
|
286 | TDatatype (n, ref (dk, cs)) =>
|
adamc@595
|
287 (case IM.find (#injectors st, n) of
|
adamc@595
|
288 SOME n' => ((EApp ((ENamed n', loc), e), loc), st)
|
adamc@595
|
289 | NONE =>
|
adamc@595
|
290 let
|
adamc@595
|
291 val n' = #maxName st
|
adamc@595
|
292 val st = {decls = #decls st,
|
adamc@595
|
293 script = #script st,
|
adamc@595
|
294 included = #included st,
|
adamc@595
|
295 injectors = IM.insert (#injectors st, n, n'),
|
adamc@800
|
296 listInjectors = #listInjectors st,
|
adamc@638
|
297 decoders = #decoders st,
|
adamc@595
|
298 maxName = n' + 1}
|
adamc@595
|
299
|
adamc@595
|
300 val (pes, st) = ListUtil.foldlMap
|
adamc@595
|
301 (fn ((_, cn, NONE), st) =>
|
adamc@595
|
302 (((PCon (dk, PConVar cn, NONE), loc),
|
adamc@596
|
303 case dk of
|
adamc@596
|
304 Option => str loc "null"
|
adamc@596
|
305 | _ => str loc (Int.toString cn)),
|
adamc@595
|
306 st)
|
adamc@595
|
307 | ((_, cn, SOME t), st) =>
|
adamc@595
|
308 let
|
adamc@595
|
309 val (e, st) = quoteExp loc t ((ERel 0, loc), st)
|
adamc@595
|
310 in
|
adamc@595
|
311 (((PCon (dk, PConVar cn, SOME (PVar ("x", t), loc)), loc),
|
adamc@596
|
312 case dk of
|
adamc@596
|
313 Option =>
|
adamc@596
|
314 if isNullable t then
|
adamc@638
|
315 strcat loc [str loc "{v:",
|
adamc@596
|
316 e,
|
adamc@596
|
317 str loc "}"]
|
adamc@596
|
318 else
|
adamc@596
|
319 e
|
adamc@597
|
320 | _ => strcat loc [str loc ("{n:" ^ Int.toString cn
|
adamc@597
|
321 ^ ",v:"),
|
adamc@597
|
322 e,
|
adamc@597
|
323 str loc "}"]),
|
adamc@595
|
324 st)
|
adamc@595
|
325 end)
|
adamc@595
|
326 st cs
|
adamc@595
|
327
|
adamc@595
|
328 val s = (TFfi ("Basis", "string"), loc)
|
adamc@595
|
329 val body = (ECase ((ERel 0, loc), pes,
|
adamc@595
|
330 {disc = t, result = s}), loc)
|
adamc@595
|
331 val body = (EAbs ("x", t, s, body), loc)
|
adamc@595
|
332
|
adamc@595
|
333 val st = {decls = (DValRec [("jsify", n', (TFun (t, s), loc),
|
adamc@595
|
334 body, "jsify")], loc) :: #decls st,
|
adamc@595
|
335 script = #script st,
|
adamc@595
|
336 included = #included st,
|
adamc@595
|
337 injectors = #injectors st,
|
adamc@800
|
338 listInjectors = #listInjectors st,
|
adamc@638
|
339 decoders= #decoders st,
|
adamc@595
|
340 maxName = #maxName st}
|
adamc@595
|
341 in
|
adamc@595
|
342 ((EApp ((ENamed n', loc), e), loc), st)
|
adamc@595
|
343 end)
|
adamc@595
|
344
|
adamc@590
|
345 | _ => (EM.errorAt loc "Don't know how to embed type in JavaScript";
|
adamc@590
|
346 Print.prefaces "Can't embed" [("t", MonoPrint.p_typ MonoEnv.empty t)];
|
adamc@593
|
347 (str loc "ERROR", st))
|
adamc@590
|
348
|
adamc@613
|
349 fun unurlifyExp loc (t : typ, st) =
|
adamc@613
|
350 case #1 t of
|
adamc@613
|
351 TRecord [] => ("null", st)
|
adamc@613
|
352 | TRecord [(x, t)] =>
|
adamc@613
|
353 let
|
adamc@613
|
354 val (e, st) = unurlifyExp loc (t, st)
|
adamc@613
|
355 in
|
adamc@613
|
356 ("{_" ^ x ^ ":" ^ e ^ "}",
|
adamc@613
|
357 st)
|
adamc@613
|
358 end
|
adamc@613
|
359 | TRecord ((x, t) :: xts) =>
|
adamc@613
|
360 let
|
adamc@613
|
361 val (e', st) = unurlifyExp loc (t, st)
|
adamc@613
|
362 val (es, st) = ListUtil.foldlMap
|
adamc@638
|
363 (fn ((x, t), st) =>
|
adamc@638
|
364 let
|
adamc@638
|
365 val (e, st) = unurlifyExp loc (t, st)
|
adamc@638
|
366 in
|
adamc@638
|
367 (",_" ^ x ^ ":" ^ e, st)
|
adamc@638
|
368 end)
|
adamc@638
|
369 st xts
|
adamc@613
|
370 in
|
adamc@613
|
371 (String.concat ("{_"
|
adamc@613
|
372 :: x
|
adamc@613
|
373 :: ":"
|
adamc@613
|
374 :: e'
|
adamc@613
|
375 :: es
|
adamc@613
|
376 @ ["}"]), st)
|
adamc@613
|
377 end
|
adamc@613
|
378
|
adamc@679
|
379 | TFfi ("Basis", "string") => ("uu(t[i++])", st)
|
adamc@613
|
380 | TFfi ("Basis", "int") => ("parseInt(t[i++])", st)
|
adamc@613
|
381 | TFfi ("Basis", "float") => ("parseFloat(t[i++])", st)
|
adamc@682
|
382 | TFfi ("Basis", "channel") => ("(t[i++].length > 0 ? parseInt(t[i]) : null)", st)
|
adamc@613
|
383
|
adamc@613
|
384 | TFfi ("Basis", "bool") => ("t[i++] == \"True\"", st)
|
adamc@613
|
385
|
adamc@638
|
386 | TOption t =>
|
adamc@613
|
387 let
|
adamc@638
|
388 val (e, st) = unurlifyExp loc (t, st)
|
adamc@638
|
389 val e = if isNullable t then
|
adamc@638
|
390 "{v:" ^ e ^ "}"
|
adamc@638
|
391 else
|
adamc@638
|
392 e
|
adamc@613
|
393 in
|
adamc@703
|
394 ("(t[i++]==\"Some\"?" ^ e ^ ":null)", st)
|
adamc@638
|
395 end
|
adamc@613
|
396
|
adamc@638
|
397 | TDatatype (n, ref (dk, cs)) =>
|
adamc@638
|
398 (case IM.find (#decoders st, n) of
|
adamc@638
|
399 SOME n' => ("(tmp=_n" ^ Int.toString n' ^ "(t,i),i=tmp._1,tmp._2)", st)
|
adamc@613
|
400 | NONE =>
|
adamc@613
|
401 let
|
adamc@613
|
402 val n' = #maxName st
|
adamc@613
|
403 val st = {decls = #decls st,
|
adamc@613
|
404 script = #script st,
|
adamc@613
|
405 included = #included st,
|
adamc@638
|
406 injectors = #injectors st,
|
adamc@800
|
407 listInjectors = #listInjectors st,
|
adamc@638
|
408 decoders = IM.insert (#decoders st, n, n'),
|
adamc@613
|
409 maxName = n' + 1}
|
adamc@613
|
410
|
adamc@638
|
411 val (e, st) = foldl (fn ((x, cn, NONE), (e, st)) =>
|
adamc@638
|
412 ("x==\"" ^ x ^ "\"?"
|
adamc@638
|
413 ^ (case dk of
|
adamc@638
|
414 Option => "null"
|
adamc@638
|
415 | _ => Int.toString cn)
|
adamc@638
|
416 ^ ":" ^ e,
|
adamc@613
|
417 st)
|
adamc@638
|
418 | ((x, cn, SOME t), (e, st)) =>
|
adamc@613
|
419 let
|
adamc@638
|
420 val (e', st) = unurlifyExp loc (t, st)
|
adamc@613
|
421 in
|
adamc@638
|
422 ("x==\"" ^ x ^ "\"?"
|
adamc@638
|
423 ^ (case dk of
|
adamc@638
|
424 Option =>
|
adamc@638
|
425 if isNullable t then
|
adamc@638
|
426 "{v:" ^ e' ^ "}"
|
adamc@638
|
427 else
|
adamc@638
|
428 e'
|
adamc@638
|
429 | _ => "{n:" ^ Int.toString cn ^ ",v:" ^ e' ^ "}")
|
adamc@638
|
430 ^ ":" ^ e,
|
adamc@613
|
431 st)
|
adamc@613
|
432 end)
|
adamc@638
|
433 ("pf()", st) cs
|
adamc@613
|
434
|
adamc@638
|
435 val body = "function _n" ^ Int.toString n' ^ "(t,i){var x=t[i++];var r="
|
adamc@638
|
436 ^ e ^ ";return {_1:i,_2:r}}\n\n"
|
adamc@613
|
437
|
adamc@638
|
438 val st = {decls = #decls st,
|
adamc@638
|
439 script = body :: #script st,
|
adamc@613
|
440 included = #included st,
|
adamc@613
|
441 injectors = #injectors st,
|
adamc@800
|
442 listInjectors = #listInjectors st,
|
adamc@638
|
443 decoders = #decoders st,
|
adamc@613
|
444 maxName = #maxName st}
|
adamc@613
|
445 in
|
adamc@638
|
446 ("(tmp=_n" ^ Int.toString n' ^ "(t,i),i=tmp._1,tmp._2)", st)
|
adamc@638
|
447 end)
|
adamc@613
|
448
|
adamc@613
|
449 | _ => (EM.errorAt loc "Don't know how to unurlify type in JavaScript";
|
adamc@613
|
450 Print.prefaces "Can't unurlify" [("t", MonoPrint.p_typ MonoEnv.empty t)];
|
adamc@613
|
451 ("ERROR", st))
|
adamc@613
|
452
|
adamc@646
|
453 fun padWith (ch, s, len) =
|
adamc@646
|
454 if size s < len then
|
adamc@646
|
455 padWith (ch, String.str ch ^ s, len - 1)
|
adamc@646
|
456 else
|
adamc@646
|
457 s
|
adamc@646
|
458
|
adamc@794
|
459 val foundJavaScript = ref false
|
adamc@794
|
460
|
adamc@800
|
461 fun jsExp mode outer =
|
adamc@567
|
462 let
|
adamc@589
|
463 val len = length outer
|
adamc@567
|
464
|
adamc@589
|
465 fun jsE inner (e as (_, loc), st) =
|
adamc@589
|
466 let
|
adamc@590
|
467 val str = str loc
|
adamc@567
|
468
|
adamc@589
|
469 fun var n = Int.toString (len + inner - n - 1)
|
adamc@567
|
470
|
adamc@589
|
471 fun patCon pc =
|
adamc@589
|
472 case pc of
|
adamc@589
|
473 PConVar n => str (Int.toString n)
|
adamc@589
|
474 | PConFfi {mod = "Basis", con = "True", ...} => str "true"
|
adamc@589
|
475 | PConFfi {mod = "Basis", con = "False", ...} => str "false"
|
adamc@589
|
476 | PConFfi {con, ...} => str ("\"_" ^ con ^ "\"")
|
adamc@567
|
477
|
adamc@591
|
478 fun unsupported s =
|
adamc@591
|
479 (EM.errorAt loc (s ^ " in code to be compiled to JavaScript[2]");
|
adamc@591
|
480 (str "ERROR", st))
|
adamc@577
|
481
|
adamc@589
|
482 val strcat = strcat loc
|
adamc@584
|
483
|
adamc@589
|
484 fun jsPrim p =
|
adamc@589
|
485 case p of
|
adamc@589
|
486 Prim.String s =>
|
adamc@589
|
487 str ("\""
|
adamc@589
|
488 ^ String.translate (fn #"'" =>
|
adamc@589
|
489 if mode = Attribute then
|
adamc@589
|
490 "\\047"
|
adamc@589
|
491 else
|
adamc@589
|
492 "'"
|
adamc@589
|
493 | #"\"" => "\\\""
|
adamc@589
|
494 | #"<" =>
|
adamc@589
|
495 if mode = Script then
|
adamc@589
|
496 "<"
|
adamc@589
|
497 else
|
adamc@589
|
498 "\\074"
|
adamc@589
|
499 | #"\\" => "\\\\"
|
adamc@646
|
500 | #"\n" => "\\n"
|
adamc@646
|
501 | #"\r" => "\\r"
|
adamc@646
|
502 | #"\t" => "\\t"
|
adamc@646
|
503 | ch =>
|
adamc@646
|
504 if Char.isPrint ch then
|
adamc@646
|
505 String.str ch
|
adamc@646
|
506 else
|
adamc@646
|
507 "\\" ^ padWith (#"0",
|
adamc@646
|
508 Int.fmt StringCvt.OCT (ord ch),
|
adamc@646
|
509 3)) s
|
adamc@589
|
510 ^ "\"")
|
adamc@589
|
511 | _ => str (Prim.toString p)
|
adamc@589
|
512
|
adamc@589
|
513 fun jsPat depth inner (p, _) succ fail =
|
adamc@589
|
514 case p of
|
adamc@589
|
515 PWild => succ
|
adamc@589
|
516 | PVar _ => strcat [str ("(_" ^ Int.toString (len + inner) ^ "=d"
|
adamc@589
|
517 ^ Int.toString depth ^ ","),
|
adamc@589
|
518 succ,
|
adamc@589
|
519 str ")"]
|
adamc@589
|
520 | PPrim p => strcat [str ("(d" ^ Int.toString depth ^ "=="),
|
adamc@589
|
521 jsPrim p,
|
adamc@589
|
522 str "?",
|
adamc@589
|
523 succ,
|
adamc@589
|
524 str ":",
|
adamc@589
|
525 fail,
|
adamc@589
|
526 str ")"]
|
adamc@589
|
527 | PCon (_, PConFfi {mod = "Basis", con = "True", ...}, NONE) =>
|
adamc@589
|
528 strcat [str ("(d" ^ Int.toString depth ^ "?"),
|
adamc@589
|
529 succ,
|
adamc@589
|
530 str ":",
|
adamc@589
|
531 fail,
|
adamc@589
|
532 str ")"]
|
adamc@589
|
533 | PCon (_, PConFfi {mod = "Basis", con = "False", ...}, NONE) =>
|
adamc@589
|
534 strcat [str ("(d" ^ Int.toString depth ^ "?"),
|
adamc@589
|
535 fail,
|
adamc@589
|
536 str ":",
|
adamc@589
|
537 succ,
|
adamc@589
|
538 str ")"]
|
adamc@596
|
539 | PCon (Option, _, NONE) =>
|
adamc@596
|
540 strcat [str ("(d" ^ Int.toString depth ^ "?"),
|
adamc@596
|
541 fail,
|
adamc@596
|
542 str ":",
|
adamc@596
|
543 succ,
|
adamc@596
|
544 str ")"]
|
adamc@596
|
545 | PCon (Option, PConVar n, SOME p) =>
|
adamc@596
|
546 (case IM.find (someTs, n) of
|
adamc@596
|
547 NONE => raise Fail "Jscomp: Not in someTs"
|
adamc@596
|
548 | SOME t =>
|
adamc@596
|
549 strcat [str ("(d" ^ Int.toString depth ^ "?("
|
adamc@596
|
550 ^ (if isNullable t then
|
adamc@596
|
551 "d" ^ Int.toString depth ^ "=d"
|
adamc@596
|
552 ^ Int.toString depth ^ ".v,"
|
adamc@596
|
553 else
|
adamc@596
|
554 "")),
|
adamc@596
|
555 jsPat depth inner p succ fail,
|
adamc@596
|
556 str "):",
|
adamc@596
|
557 fail,
|
adamc@596
|
558 str ")"])
|
adamc@589
|
559 | PCon (_, pc, NONE) =>
|
adamc@589
|
560 strcat [str ("(d" ^ Int.toString depth ^ "=="),
|
adamc@589
|
561 patCon pc,
|
adamc@589
|
562 str "?",
|
adamc@589
|
563 succ,
|
adamc@589
|
564 str ":",
|
adamc@589
|
565 fail,
|
adamc@589
|
566 str ")"]
|
adamc@589
|
567 | PCon (_, pc, SOME p) =>
|
adamc@589
|
568 strcat [str ("(d" ^ Int.toString depth ^ ".n=="),
|
adamc@589
|
569 patCon pc,
|
adamc@589
|
570 str ("?(d" ^ Int.toString depth ^ "=d" ^ Int.toString depth ^ ".v,"),
|
adamc@589
|
571 jsPat depth inner p succ fail,
|
adamc@589
|
572 str "):",
|
adamc@589
|
573 fail,
|
adamc@589
|
574 str ")"]
|
adamc@589
|
575 | PRecord xps =>
|
adamc@589
|
576 let
|
adamc@589
|
577 val (_, succ) = foldl
|
adamc@589
|
578 (fn ((x, p, _), (inner, succ)) =>
|
adamc@589
|
579 (inner + E.patBindsN p,
|
adamc@589
|
580 strcat [str ("(d" ^ Int.toString (depth+1) ^ "=d"
|
adamc@589
|
581 ^ Int.toString depth ^ "._" ^ x ^ ","),
|
adamc@589
|
582 jsPat (depth+1) inner p succ fail,
|
adamc@589
|
583 str ")"]))
|
adamc@589
|
584 (inner, succ) xps
|
adamc@589
|
585 in
|
adamc@589
|
586 succ
|
adamc@589
|
587 end
|
adamc@589
|
588 | PNone _ => strcat [str ("(d" ^ Int.toString depth ^ "?"),
|
adamc@589
|
589 fail,
|
adamc@589
|
590 str ":",
|
adamc@589
|
591 succ,
|
adamc@589
|
592 str ")"]
|
adamc@594
|
593 | PSome (t, p) => strcat (str ("(d" ^ Int.toString depth ^ "?")
|
adamc@594
|
594 :: (if isNullable t then
|
adamc@594
|
595 [str ("d" ^ Int.toString depth
|
adamc@594
|
596 ^ "=d" ^ Int.toString depth ^ ".v")]
|
adamc@594
|
597 else
|
adamc@594
|
598 [])
|
adamc@594
|
599 @ [jsPat depth inner p succ fail,
|
adamc@594
|
600 str ":",
|
adamc@594
|
601 fail,
|
adamc@594
|
602 str ")"])
|
adamc@589
|
603
|
adamc@601
|
604 val jsifyString = String.translate (fn #"\"" => "\\\""
|
adamc@601
|
605 | #"\\" => "\\\\"
|
adamc@601
|
606 | ch => String.str ch)
|
adamc@601
|
607
|
adamc@601
|
608 fun jsifyStringMulti (n, s) =
|
adamc@601
|
609 case n of
|
adamc@601
|
610 0 => s
|
adamc@601
|
611 | _ => jsifyStringMulti (n - 1, jsifyString s)
|
adamc@601
|
612
|
adamc@601
|
613 fun deStrcat level (all as (e, _)) =
|
adamc@589
|
614 case e of
|
adamc@601
|
615 EPrim (Prim.String s) => jsifyStringMulti (level, s)
|
adamc@601
|
616 | EStrcat (e1, e2) => deStrcat level e1 ^ deStrcat level e2
|
adamc@601
|
617 | EFfiApp ("Basis", "jsifyString", [e]) => "\"" ^ deStrcat (level + 1) e ^ "\""
|
adamc@601
|
618 | _ => (Print.prefaces "deStrcat" [("e", MonoPrint.p_exp MonoEnv.empty all)];
|
adamc@601
|
619 raise Fail "Jscomp: deStrcat")
|
adamc@590
|
620
|
adamc@590
|
621 val quoteExp = quoteExp loc
|
adamc@567
|
622 in
|
adamc@590
|
623 (*Print.prefaces "jsE" [("e", MonoPrint.p_exp MonoEnv.empty e)];*)
|
adamc@590
|
624
|
adamc@589
|
625 case #1 e of
|
adamc@589
|
626 EPrim p => (jsPrim p, st)
|
adamc@589
|
627 | ERel n =>
|
adamc@589
|
628 if n < inner then
|
adamc@589
|
629 (str ("_" ^ var n), st)
|
adamc@589
|
630 else
|
adamc@589
|
631 let
|
adamc@589
|
632 val n = n - inner
|
adamc@589
|
633 in
|
adamc@800
|
634 quoteExp (List.nth (outer, n)) ((ERel n, loc), st)
|
adamc@589
|
635 end
|
adamc@567
|
636
|
adamc@589
|
637 | ENamed n =>
|
adamc@589
|
638 let
|
adamc@589
|
639 val st =
|
adamc@589
|
640 if IS.member (#included st, n) then
|
adamc@589
|
641 st
|
adamc@589
|
642 else
|
adamc@589
|
643 case IM.find (nameds, n) of
|
adamc@589
|
644 NONE => raise Fail "Jscomp: Unbound ENamed"
|
adamc@589
|
645 | SOME e =>
|
adamc@589
|
646 let
|
adamc@589
|
647 val st = {decls = #decls st,
|
adamc@589
|
648 script = #script st,
|
adamc@595
|
649 included = IS.add (#included st, n),
|
adamc@595
|
650 injectors = #injectors st,
|
adamc@800
|
651 listInjectors = #listInjectors st,
|
adamc@638
|
652 decoders = #decoders st,
|
adamc@595
|
653 maxName = #maxName st}
|
adamc@578
|
654
|
adamc@800
|
655 val (e, st) = jsExp mode [] 0 (e, st)
|
adamc@601
|
656 val e = deStrcat 0 e
|
adamc@589
|
657
|
adamc@589
|
658 val sc = "_n" ^ Int.toString n ^ "=" ^ e ^ ";\n"
|
adamc@589
|
659 in
|
adamc@589
|
660 {decls = #decls st,
|
adamc@589
|
661 script = sc :: #script st,
|
adamc@595
|
662 included = #included st,
|
adamc@595
|
663 injectors = #injectors st,
|
adamc@800
|
664 listInjectors = #listInjectors st,
|
adamc@638
|
665 decoders= #decoders st,
|
adamc@595
|
666 maxName = #maxName st}
|
adamc@589
|
667 end
|
adamc@589
|
668 in
|
adamc@589
|
669 (str ("_n" ^ Int.toString n), st)
|
adamc@589
|
670 end
|
adamc@589
|
671
|
adamc@596
|
672 | ECon (Option, _, NONE) => (str "null", st)
|
adamc@596
|
673 | ECon (Option, PConVar n, SOME e) =>
|
adamc@596
|
674 let
|
adamc@596
|
675 val (e, st) = jsE inner (e, st)
|
adamc@596
|
676 in
|
adamc@596
|
677 case IM.find (someTs, n) of
|
adamc@596
|
678 NONE => raise Fail "Jscomp: Not in someTs [2]"
|
adamc@596
|
679 | SOME t =>
|
adamc@596
|
680 (if isNullable t then
|
adamc@596
|
681 strcat [str "{v:",
|
adamc@596
|
682 e,
|
adamc@596
|
683 str "}"]
|
adamc@596
|
684 else
|
adamc@596
|
685 e, st)
|
adamc@596
|
686 end
|
adamc@596
|
687
|
adamc@589
|
688 | ECon (_, pc, NONE) => (patCon pc, st)
|
adamc@589
|
689 | ECon (_, pc, SOME e) =>
|
adamc@589
|
690 let
|
adamc@589
|
691 val (s, st) = jsE inner (e, st)
|
adamc@589
|
692 in
|
adamc@589
|
693 (strcat [str "{n:",
|
adamc@589
|
694 patCon pc,
|
adamc@589
|
695 str ",v:",
|
adamc@589
|
696 s,
|
adamc@589
|
697 str "}"], st)
|
adamc@589
|
698 end
|
adamc@596
|
699
|
adamc@589
|
700 | ENone _ => (str "null", st)
|
adamc@589
|
701 | ESome (t, e) =>
|
adamc@572
|
702 let
|
adamc@572
|
703 val (e, st) = jsE inner (e, st)
|
adamc@572
|
704 in
|
adamc@589
|
705 (if isNullable t then
|
adamc@589
|
706 strcat [str "{v:", e, str "}"]
|
adamc@589
|
707 else
|
adamc@589
|
708 e, st)
|
adamc@589
|
709 end
|
adamc@589
|
710
|
adamc@589
|
711 | EFfi k =>
|
adamc@589
|
712 let
|
adamc@765
|
713 val name = case Settings.jsFunc k of
|
adamc@589
|
714 NONE => (EM.errorAt loc ("Unsupported FFI identifier " ^ #2 k
|
adamc@589
|
715 ^ " in JavaScript");
|
adamc@589
|
716 "ERROR")
|
adamc@589
|
717 | SOME s => s
|
adamc@589
|
718 in
|
adamc@589
|
719 (str name, st)
|
adamc@589
|
720 end
|
adamc@589
|
721 | EFfiApp (m, x, args) =>
|
adamc@589
|
722 let
|
adamc@589
|
723 val args =
|
adamc@589
|
724 case (m, x, args) of
|
adamc@794
|
725 ("Basis", "new_client_source", [(EJavaScript (_, e, _), _)]) =>
|
adamc@794
|
726 (foundJavaScript := true; [e])
|
adamc@794
|
727 | ("Basis", "set_client_source", [e1, (EJavaScript (_, e2, _), _)]) =>
|
adamc@794
|
728 (foundJavaScript := true; [e1, e2])
|
adamc@589
|
729 | _ => args
|
adamc@589
|
730
|
adamc@765
|
731 val name = case Settings.jsFunc (m, x) of
|
adamc@589
|
732 NONE => (EM.errorAt loc ("Unsupported FFI function "
|
adamc@589
|
733 ^ x ^ " in JavaScript");
|
adamc@589
|
734 "ERROR")
|
adamc@589
|
735 | SOME s => s
|
adamc@589
|
736 in
|
adamc@589
|
737 case args of
|
adamc@589
|
738 [] => (str (name ^ "()"), st)
|
adamc@589
|
739 | [e] =>
|
adamc@589
|
740 let
|
adamc@589
|
741 val (e, st) = jsE inner (e, st)
|
adamc@589
|
742 in
|
adamc@589
|
743 (strcat [str (name ^ "("),
|
adamc@589
|
744 e,
|
adamc@589
|
745 str ")"], st)
|
adamc@589
|
746 end
|
adamc@589
|
747 | e :: es =>
|
adamc@589
|
748 let
|
adamc@589
|
749 val (e, st) = jsE inner (e, st)
|
adamc@589
|
750 val (es, st) = ListUtil.foldlMapConcat
|
adamc@589
|
751 (fn (e, st) =>
|
adamc@589
|
752 let
|
adamc@589
|
753 val (e, st) = jsE inner (e, st)
|
adamc@589
|
754 in
|
adamc@589
|
755 ([str ",", e], st)
|
adamc@589
|
756 end)
|
adamc@589
|
757 st es
|
adamc@589
|
758 in
|
adamc@589
|
759 (strcat (str (name ^ "(")
|
adamc@589
|
760 :: e
|
adamc@589
|
761 :: es
|
adamc@589
|
762 @ [str ")"]), st)
|
adamc@589
|
763 end
|
adamc@589
|
764 end
|
adamc@589
|
765
|
adamc@589
|
766 | EApp (e1, e2) =>
|
adamc@589
|
767 let
|
adamc@589
|
768 val (e1, st) = jsE inner (e1, st)
|
adamc@589
|
769 val (e2, st) = jsE inner (e2, st)
|
adamc@589
|
770 in
|
adamc@589
|
771 (strcat [e1, str "(", e2, str ")"], st)
|
adamc@589
|
772 end
|
adamc@589
|
773 | EAbs (_, _, _, e) =>
|
adamc@589
|
774 let
|
adamc@589
|
775 val locals = List.tabulate
|
adamc@589
|
776 (varDepth e,
|
adamc@589
|
777 fn i => str ("var _" ^ Int.toString (len + inner + i + 1) ^ ";"))
|
adamc@589
|
778 val (e, st) = jsE (inner + 1) (e, st)
|
adamc@589
|
779 in
|
adamc@589
|
780 (strcat (str ("function(_"
|
adamc@589
|
781 ^ Int.toString (len + inner)
|
adamc@589
|
782 ^ "){")
|
adamc@589
|
783 :: locals
|
adamc@589
|
784 @ [str "return ",
|
adamc@589
|
785 e,
|
adamc@589
|
786 str "}"]),
|
adamc@589
|
787 st)
|
adamc@589
|
788 end
|
adamc@589
|
789
|
adamc@589
|
790 | EUnop (s, e) =>
|
adamc@589
|
791 let
|
adamc@589
|
792 val (e, st) = jsE inner (e, st)
|
adamc@589
|
793 in
|
adamc@589
|
794 (strcat [str ("(" ^ s),
|
adamc@572
|
795 e,
|
adamc@589
|
796 str ")"],
|
adamc@589
|
797 st)
|
adamc@589
|
798 end
|
adamc@589
|
799 | EBinop (s, e1, e2) =>
|
adamc@589
|
800 let
|
adamc@729
|
801 val s =
|
adamc@729
|
802 case s of
|
adamc@729
|
803 "!strcmp" => "=="
|
adamc@729
|
804 | _ => s
|
adamc@729
|
805
|
adamc@589
|
806 val (e1, st) = jsE inner (e1, st)
|
adamc@589
|
807 val (e2, st) = jsE inner (e2, st)
|
adamc@589
|
808 in
|
adamc@589
|
809 (strcat [str "(",
|
adamc@589
|
810 e1,
|
adamc@589
|
811 str s,
|
adamc@589
|
812 e2,
|
adamc@589
|
813 str ")"],
|
adamc@589
|
814 st)
|
adamc@589
|
815 end
|
adamc@589
|
816
|
adamc@589
|
817 | ERecord [] => (str "null", st)
|
adamc@589
|
818 | ERecord [(x, e, _)] =>
|
adamc@589
|
819 let
|
adamc@589
|
820 val (e, st) = jsE inner (e, st)
|
adamc@589
|
821 in
|
adamc@589
|
822 (strcat [str "{_x:", e, str "}"], st)
|
adamc@589
|
823 end
|
adamc@589
|
824 | ERecord ((x, e, _) :: xes) =>
|
adamc@589
|
825 let
|
adamc@589
|
826 val (e, st) = jsE inner (e, st)
|
adamc@589
|
827
|
adamc@589
|
828 val (es, st) =
|
adamc@589
|
829 foldr (fn ((x, e, _), (es, st)) =>
|
adamc@589
|
830 let
|
adamc@589
|
831 val (e, st) = jsE inner (e, st)
|
adamc@589
|
832 in
|
adamc@589
|
833 (str (",_" ^ x ^ ":")
|
adamc@589
|
834 :: e
|
adamc@589
|
835 :: es,
|
adamc@589
|
836 st)
|
adamc@589
|
837 end)
|
adamc@589
|
838 ([str "}"], st) xes
|
adamc@589
|
839 in
|
adamc@589
|
840 (strcat (str ("{_" ^ x ^ ":")
|
adamc@589
|
841 :: e
|
adamc@589
|
842 :: es),
|
adamc@589
|
843 st)
|
adamc@589
|
844 end
|
adamc@589
|
845 | EField (e, x) =>
|
adamc@589
|
846 let
|
adamc@589
|
847 val (e, st) = jsE inner (e, st)
|
adamc@589
|
848 in
|
adamc@589
|
849 (strcat [e,
|
adamc@589
|
850 str ("._" ^ x)], st)
|
adamc@589
|
851 end
|
adamc@589
|
852
|
adamc@591
|
853 | ECase (e', pes, {result, ...}) =>
|
adamc@679
|
854 (*if closedUpto inner e andalso List.all (fn (_, e) => closedUpto inner e) pes then
|
adamc@593
|
855 let
|
adamc@593
|
856 val (e', st) = quoteExp result ((ERel 0, loc), st)
|
adamc@593
|
857 in
|
adamc@593
|
858 ((ELet ("js", result, e, e'), loc),
|
adamc@593
|
859 st)
|
adamc@593
|
860 end
|
adamc@679
|
861 else*)
|
adamc@591
|
862 let
|
adamc@591
|
863 val plen = length pes
|
adamc@589
|
864
|
adamc@591
|
865 val (cases, st) = ListUtil.foldliMap
|
adamc@591
|
866 (fn (i, (p, e), st) =>
|
adamc@591
|
867 let
|
adamc@591
|
868 val (e, st) = jsE (inner + E.patBindsN p) (e, st)
|
adamc@591
|
869 val fail =
|
adamc@591
|
870 if i = plen - 1 then
|
adamc@591
|
871 str "pf()"
|
adamc@591
|
872 else
|
adamc@591
|
873 str ("c" ^ Int.toString (i+1) ^ "()")
|
adamc@591
|
874 val c = jsPat 0 inner p e fail
|
adamc@591
|
875 in
|
adamc@591
|
876 (strcat [str ("c" ^ Int.toString i ^ "=function(){return "),
|
adamc@591
|
877 c,
|
adamc@591
|
878 str "},"],
|
adamc@591
|
879 st)
|
adamc@591
|
880 end)
|
adamc@591
|
881 st pes
|
adamc@589
|
882
|
adamc@591
|
883 val (e, st) = jsE inner (e', st)
|
adamc@591
|
884 in
|
adamc@798
|
885 (strcat (str "(d0="
|
adamc@798
|
886 :: e
|
adamc@798
|
887 :: str ","
|
adamc@591
|
888 :: List.revAppend (cases,
|
adamc@798
|
889 [str "c0())"])), st)
|
adamc@591
|
890 end
|
adamc@589
|
891
|
adamc@589
|
892 | EStrcat (e1, e2) =>
|
adamc@589
|
893 let
|
adamc@589
|
894 val (e1, st) = jsE inner (e1, st)
|
adamc@589
|
895 val (e2, st) = jsE inner (e2, st)
|
adamc@589
|
896 in
|
adamc@693
|
897 (strcat [str "cat(", e1, str ",", e2, str ")"], st)
|
adamc@589
|
898 end
|
adamc@589
|
899
|
adamc@589
|
900 | EError (e, _) =>
|
adamc@589
|
901 let
|
adamc@589
|
902 val (e, st) = jsE inner (e, st)
|
adamc@589
|
903 in
|
adamc@726
|
904 (strcat [str "er(", e, str ")"],
|
adamc@589
|
905 st)
|
adamc@589
|
906 end
|
adamc@589
|
907
|
adamc@589
|
908 | EWrite e =>
|
adamc@589
|
909 let
|
adamc@589
|
910 val (e, st) = jsE inner (e, st)
|
adamc@589
|
911 in
|
adamc@589
|
912 (strcat [str "document.write(",
|
adamc@589
|
913 e,
|
adamc@589
|
914 str ".v)"], st)
|
adamc@589
|
915 end
|
adamc@589
|
916
|
adamc@589
|
917 | ESeq (e1, e2) =>
|
adamc@589
|
918 let
|
adamc@589
|
919 val (e1, st) = jsE inner (e1, st)
|
adamc@589
|
920 val (e2, st) = jsE inner (e2, st)
|
adamc@589
|
921 in
|
adamc@589
|
922 (strcat [str "(", e1, str ",", e2, str ")"], st)
|
adamc@589
|
923 end
|
adamc@589
|
924 | ELet (_, _, e1, e2) =>
|
adamc@589
|
925 let
|
adamc@589
|
926 val (e1, st) = jsE inner (e1, st)
|
adamc@589
|
927 val (e2, st) = jsE (inner + 1) (e2, st)
|
adamc@589
|
928 in
|
adamc@589
|
929 (strcat [str ("(_" ^ Int.toString (len + inner) ^ "="),
|
adamc@589
|
930 e1,
|
adamc@589
|
931 str ",",
|
adamc@589
|
932 e2,
|
adamc@572
|
933 str ")"], st)
|
adamc@572
|
934 end
|
adamc@589
|
935
|
adamc@794
|
936 | EJavaScript (Source _, _, SOME _) =>
|
adamc@794
|
937 (foundJavaScript := true;
|
adamc@794
|
938 (e, st))
|
adamc@603
|
939 | EJavaScript (_, _, SOME e) =>
|
adamc@794
|
940 (foundJavaScript := true;
|
adamc@794
|
941 (strcat [str "cs(function(){return ",
|
adamc@794
|
942 e,
|
adamc@794
|
943 str "})"],
|
adamc@794
|
944 st))
|
adamc@590
|
945
|
adamc@589
|
946 | EClosure _ => unsupported "EClosure"
|
adamc@589
|
947 | EQuery _ => unsupported "Query"
|
adamc@589
|
948 | EDml _ => unsupported "DML"
|
adamc@589
|
949 | ENextval _ => unsupported "Nextval"
|
adamc@589
|
950 | EUnurlify _ => unsupported "EUnurlify"
|
adamc@741
|
951 | EReturnBlob _ => unsupported "EUnurlify"
|
adamc@601
|
952 | EJavaScript (_, e, _) =>
|
adamc@601
|
953 let
|
adamc@601
|
954 val (e, st) = jsE inner (e, st)
|
adamc@601
|
955 in
|
adamc@794
|
956 foundJavaScript := true;
|
adamc@693
|
957 (strcat [str "cs(function(){return ",
|
adamc@603
|
958 e,
|
adamc@693
|
959 str "})"],
|
adamc@603
|
960 st)
|
adamc@601
|
961 end
|
adamc@590
|
962
|
adamc@589
|
963 | ESignalReturn e =>
|
adamc@572
|
964 let
|
adamc@572
|
965 val (e, st) = jsE inner (e, st)
|
adamc@572
|
966 in
|
adamc@589
|
967 (strcat [str "sr(",
|
adamc@589
|
968 e,
|
adamc@589
|
969 str ")"],
|
adamc@589
|
970 st)
|
adamc@589
|
971 end
|
adamc@589
|
972 | ESignalBind (e1, e2) =>
|
adamc@589
|
973 let
|
adamc@589
|
974 val (e1, st) = jsE inner (e1, st)
|
adamc@589
|
975 val (e2, st) = jsE inner (e2, st)
|
adamc@589
|
976 in
|
adamc@589
|
977 (strcat [str "sb(",
|
adamc@589
|
978 e1,
|
adamc@589
|
979 str ",",
|
adamc@589
|
980 e2,
|
adamc@589
|
981 str ")"],
|
adamc@589
|
982 st)
|
adamc@589
|
983 end
|
adamc@589
|
984 | ESignalSource e =>
|
adamc@589
|
985 let
|
adamc@589
|
986 val (e, st) = jsE inner (e, st)
|
adamc@589
|
987 in
|
adamc@589
|
988 (strcat [str "ss(",
|
adamc@589
|
989 e,
|
adamc@589
|
990 str ")"],
|
adamc@589
|
991 st)
|
adamc@572
|
992 end
|
adamc@608
|
993
|
adamc@736
|
994 | EServerCall (e, ek, t, eff) =>
|
adamc@609
|
995 let
|
adamc@614
|
996 val (e, st) = jsE inner (e, st)
|
adamc@609
|
997 val (ek, st) = jsE inner (ek, st)
|
adamc@613
|
998 val (unurl, st) = unurlifyExp loc (t, st)
|
adamc@609
|
999 in
|
adamc@764
|
1000 (strcat [str ("rc(cat(\"" ^ Settings.getUrlPrefix () ^ "\","),
|
adamc@614
|
1001 e,
|
adamc@703
|
1002 str ("), function(s){var t=s.split(\"/\");var i=0;return "
|
adamc@613
|
1003 ^ unurl ^ "},"),
|
adamc@609
|
1004 ek,
|
adamc@736
|
1005 str (","
|
adamc@736
|
1006 ^ (case eff of
|
adamc@736
|
1007 ReadCookieWrite => "true"
|
adamc@736
|
1008 | _ => "false")
|
adamc@736
|
1009 ^ ")")],
|
adamc@609
|
1010 st)
|
adamc@609
|
1011 end
|
adamc@670
|
1012
|
adamc@670
|
1013 | ERecv (e, ek, t) =>
|
adamc@670
|
1014 let
|
adamc@670
|
1015 val (e, st) = jsE inner (e, st)
|
adamc@670
|
1016 val (ek, st) = jsE inner (ek, st)
|
adamc@670
|
1017 val (unurl, st) = unurlifyExp loc (t, st)
|
adamc@670
|
1018 in
|
adamc@670
|
1019 (strcat [str "rv(",
|
adamc@670
|
1020 e,
|
adamc@670
|
1021 str (", function(s){var t=s.split(\"/\");var i=0;return "
|
adamc@670
|
1022 ^ unurl ^ "},"),
|
adamc@670
|
1023 ek,
|
adamc@670
|
1024 str ")"],
|
adamc@670
|
1025 st)
|
adamc@670
|
1026 end
|
adamc@695
|
1027
|
adamc@695
|
1028 | ESleep (e, ek) =>
|
adamc@695
|
1029 let
|
adamc@695
|
1030 val (e, st) = jsE inner (e, st)
|
adamc@695
|
1031 val (ek, st) = jsE inner (ek, st)
|
adamc@695
|
1032 in
|
adamc@695
|
1033 (strcat [str "window.setTimeout(",
|
adamc@695
|
1034 ek,
|
adamc@695
|
1035 str ", ",
|
adamc@695
|
1036 e,
|
adamc@695
|
1037 str ")"],
|
adamc@695
|
1038 st)
|
adamc@695
|
1039 end
|
adamc@567
|
1040 end
|
adamc@589
|
1041 in
|
adamc@589
|
1042 jsE
|
adamc@589
|
1043 end
|
adamc@567
|
1044
|
adamc@589
|
1045 val decl : state -> decl -> decl * state =
|
adamc@589
|
1046 U.Decl.foldMapB {typ = fn x => x,
|
adamc@589
|
1047 exp = fn (env, e, st) =>
|
adamc@589
|
1048 let
|
adamc@800
|
1049 fun doCode m env orig e =
|
adamc@589
|
1050 let
|
adamc@589
|
1051 val len = length env
|
adamc@589
|
1052 fun str s = (EPrim (Prim.String s), #2 e)
|
adamc@567
|
1053
|
adamc@589
|
1054 val locals = List.tabulate
|
adamc@589
|
1055 (varDepth e,
|
adamc@589
|
1056 fn i => str ("var _" ^ Int.toString (len + i) ^ ";"))
|
adamc@800
|
1057 val (e, st) = jsExp m env 0 (e, st)
|
adamc@589
|
1058 in
|
adamc@589
|
1059 (EJavaScript (m, orig, SOME (strcat (#2 e) (locals @ [e]))), st)
|
adamc@589
|
1060 end
|
adamc@589
|
1061 in
|
adamc@589
|
1062 case e of
|
adamc@651
|
1063 EJavaScript (m, orig, NONE) =>
|
adamc@794
|
1064 (foundJavaScript := true;
|
adamc@800
|
1065 doCode m env orig orig)
|
adamc@589
|
1066 | _ => (e, st)
|
adamc@589
|
1067 end,
|
adamc@589
|
1068 decl = fn (_, e, st) => (e, st),
|
adamc@589
|
1069 bind = fn (env, U.Decl.RelE (_, t)) => t :: env
|
adamc@589
|
1070 | (env, _) => env}
|
adamc@589
|
1071 []
|
adamc@567
|
1072
|
adamc@567
|
1073 fun doDecl (d, st) =
|
adamc@567
|
1074 let
|
adamc@567
|
1075 val (d, st) = decl st d
|
adamc@567
|
1076 in
|
adamc@567
|
1077 (List.revAppend (#decls st, [d]),
|
adamc@567
|
1078 {decls = [],
|
adamc@589
|
1079 script = #script st,
|
adamc@595
|
1080 included = #included st,
|
adamc@595
|
1081 injectors = #injectors st,
|
adamc@800
|
1082 listInjectors = #listInjectors st,
|
adamc@638
|
1083 decoders = #decoders st,
|
adamc@595
|
1084 maxName = #maxName st})
|
adamc@567
|
1085 end
|
adamc@567
|
1086
|
adamc@567
|
1087 val (ds, st) = ListUtil.foldlMapConcat doDecl
|
adamc@567
|
1088 {decls = [],
|
adamc@589
|
1089 script = [],
|
adamc@595
|
1090 included = IS.empty,
|
adamc@595
|
1091 injectors = IM.empty,
|
adamc@800
|
1092 listInjectors = TM.empty,
|
adamc@638
|
1093 decoders = IM.empty,
|
adamc@595
|
1094 maxName = U.File.maxName file + 1}
|
adamc@567
|
1095 file
|
adamc@569
|
1096
|
adamc@569
|
1097 val inf = TextIO.openIn (OS.Path.joinDirFile {dir = Config.libJs, file = "urweb.js"})
|
adamc@569
|
1098 fun lines acc =
|
adamc@569
|
1099 case TextIO.inputLine inf of
|
adamc@569
|
1100 NONE => String.concat (rev acc)
|
adamc@569
|
1101 | SOME line => lines (line :: acc)
|
adamc@569
|
1102 val lines = lines []
|
adamc@794
|
1103
|
adamc@794
|
1104 val script =
|
adamc@794
|
1105 if !foundJavaScript then
|
adamc@794
|
1106 lines ^ String.concat (rev (#script st))
|
adamc@794
|
1107 else
|
adamc@794
|
1108 ""
|
adamc@567
|
1109 in
|
adamc@569
|
1110 TextIO.closeIn inf;
|
adamc@794
|
1111 (DJavaScript script, ErrorMsg.dummySpan) :: ds
|
adamc@567
|
1112 end
|
adamc@567
|
1113
|
adamc@567
|
1114 end
|