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