adam@1487
|
1 (* Copyright (c) 2008-2011, 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@840
|
45 decls : (string * int * (string * int * typ option) list) 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@568
|
54 fun strcat loc es =
|
adamc@568
|
55 case es of
|
adamc@568
|
56 [] => (EPrim (Prim.String ""), loc)
|
adamc@568
|
57 | [x] => x
|
adamc@568
|
58 | x :: es' => (EStrcat (x, strcat loc es'), loc)
|
adamc@568
|
59
|
adamc@815
|
60 exception CantEmbed of typ
|
adamc@815
|
61
|
adamc@970
|
62 fun inString {needle, haystack} = String.isSubstring needle haystack
|
adamc@847
|
63
|
adamc@589
|
64 fun process file =
|
adamc@567
|
65 let
|
adamc@596
|
66 val (someTs, nameds) =
|
adamc@596
|
67 foldl (fn ((DVal (_, n, t, e, _), _), (someTs, nameds)) => (someTs, IM.insert (nameds, n, e))
|
adamc@596
|
68 | ((DValRec vis, _), (someTs, nameds)) =>
|
adamc@596
|
69 (someTs, foldl (fn ((_, n, _, e, _), nameds) => IM.insert (nameds, n, e))
|
adamc@596
|
70 nameds vis)
|
adamc@808
|
71 | ((DDatatype dts, _), state as (someTs, nameds)) =>
|
adamc@808
|
72 (foldl (fn ((_, _, cs), someTs) =>
|
adamc@808
|
73 if ElabUtil.classifyDatatype cs = Option then
|
adamc@808
|
74 foldl (fn ((_, n, SOME t), someTs) => IM.insert (someTs, n, t)
|
adamc@808
|
75 | (_, someTs) => someTs) someTs cs
|
adamc@808
|
76 else
|
adamc@808
|
77 someTs) someTs dts,
|
adamc@808
|
78 nameds)
|
adamc@595
|
79 | (_, state) => state)
|
adamc@596
|
80 (IM.empty, IM.empty) file
|
adamc@567
|
81
|
adamc@590
|
82 fun str loc s = (EPrim (Prim.String s), loc)
|
adamc@590
|
83
|
adamc@594
|
84 fun isNullable (t, _) =
|
adamc@594
|
85 case t of
|
adamc@594
|
86 TOption _ => true
|
adamc@841
|
87 | TList _ => true
|
adamc@841
|
88 | TDatatype (_, ref (Option, _)) => true
|
adamc@594
|
89 | TRecord [] => true
|
adamc@594
|
90 | _ => false
|
adamc@594
|
91
|
adamc@593
|
92 fun quoteExp loc (t : typ) (e, st) =
|
adamc@590
|
93 case #1 t of
|
adam@1663
|
94 TSource => ((EFfiApp ("Basis", "htmlifySource", [(e, t)]), loc), st)
|
adamc@590
|
95
|
adamc@593
|
96 | TRecord [] => (str loc "null", st)
|
adamc@593
|
97 | TRecord [(x, t)] =>
|
adamc@593
|
98 let
|
adamc@593
|
99 val (e, st) = quoteExp loc t ((EField (e, x), loc), st)
|
adamc@593
|
100 in
|
adamc@593
|
101 (strcat loc [str loc ("{_" ^ x ^ ":"),
|
adamc@593
|
102 e,
|
adamc@593
|
103 str loc "}"], st)
|
adamc@593
|
104 end
|
adamc@593
|
105 | TRecord ((x, t) :: xts) =>
|
adamc@593
|
106 let
|
adamc@593
|
107 val (e', st) = quoteExp loc t ((EField (e, x), loc), st)
|
adamc@593
|
108 val (es, st) = ListUtil.foldlMap
|
adamc@593
|
109 (fn ((x, t), st) =>
|
adamc@593
|
110 let
|
adamc@593
|
111 val (e, st) = quoteExp loc t ((EField (e, x), loc), st)
|
adamc@593
|
112 in
|
adamc@593
|
113 (strcat loc [str loc (",_" ^ x ^ ":"), e], st)
|
adamc@593
|
114 end)
|
adamc@593
|
115 st xts
|
adamc@593
|
116 in
|
adamc@593
|
117 (strcat loc (str loc ("{_" ^ x ^ ":")
|
adamc@593
|
118 :: e'
|
adamc@593
|
119 :: es
|
adamc@593
|
120 @ [str loc "}"]), st)
|
adamc@593
|
121 end
|
adamc@590
|
122
|
adam@1663
|
123 | TFfi ("Basis", "string") => ((EFfiApp ("Basis", "jsifyString", [(e, t)]), loc), st)
|
adam@1663
|
124 | TFfi ("Basis", "char") => ((EFfiApp ("Basis", "jsifyChar", [(e, t)]), loc), st)
|
adam@1663
|
125 | TFfi ("Basis", "int") => ((EFfiApp ("Basis", "htmlifyInt", [(e, t)]), loc), st)
|
adam@1663
|
126 | TFfi ("Basis", "float") => ((EFfiApp ("Basis", "htmlifyFloat", [(e, t)]), loc), st)
|
adam@1663
|
127 | TFfi ("Basis", "channel") => ((EFfiApp ("Basis", "jsifyChannel", [(e, t)]), loc), st)
|
adam@1663
|
128 | TFfi ("Basis", "time") => ((EFfiApp ("Basis", "jsifyTime", [(e, t)]), loc), st)
|
adamc@593
|
129
|
adamc@593
|
130 | TFfi ("Basis", "bool") => ((ECase (e,
|
adamc@593
|
131 [((PCon (Enum, PConFfi {mod = "Basis",
|
adamc@593
|
132 datatyp = "bool",
|
adamc@593
|
133 con = "True",
|
adamc@593
|
134 arg = NONE}, NONE), loc),
|
adamc@593
|
135 str loc "true"),
|
adamc@593
|
136 ((PCon (Enum, PConFfi {mod = "Basis",
|
adamc@593
|
137 datatyp = "bool",
|
adamc@593
|
138 con = "False",
|
adamc@593
|
139 arg = NONE}, NONE), loc),
|
adamc@593
|
140 str loc "false")],
|
adamc@593
|
141 {disc = (TFfi ("Basis", "bool"), loc),
|
adamc@593
|
142 result = (TFfi ("Basis", "string"), loc)}), loc),
|
adamc@593
|
143 st)
|
adamc@592
|
144
|
adamc@594
|
145 | TOption t =>
|
adamc@594
|
146 let
|
adamc@594
|
147 val (e', st) = quoteExp loc t ((ERel 0, loc), st)
|
adamc@594
|
148 in
|
adamc@813
|
149 (case #1 e' of
|
adamc@813
|
150 EPrim (Prim.String "ERROR") => raise Fail "UHOH"
|
adamc@813
|
151 | _ =>
|
adamc@813
|
152 (ECase (e,
|
adamc@813
|
153 [((PNone t, loc),
|
adamc@813
|
154 str loc "null"),
|
adamc@813
|
155 ((PSome (t, (PVar ("x", t), loc)), loc),
|
adamc@813
|
156 if isNullable t then
|
adamc@813
|
157 strcat loc [str loc "{v:", e', str loc "}"]
|
adamc@813
|
158 else
|
adamc@813
|
159 e')],
|
adamc@813
|
160 {disc = (TOption t, loc),
|
adamc@813
|
161 result = (TFfi ("Basis", "string"), loc)}), loc),
|
adamc@594
|
162 st)
|
adamc@594
|
163 end
|
adamc@594
|
164
|
adamc@800
|
165 | TList t' =>
|
adamc@800
|
166 (case TM.find (#listInjectors st, t') of
|
adamc@800
|
167 SOME n' => ((EApp ((ENamed n', loc), e), loc), st)
|
adamc@800
|
168 | NONE =>
|
adamc@800
|
169 let
|
adamc@800
|
170 val rt = (TRecord [("1", t'), ("2", t)], loc)
|
adamc@800
|
171
|
adamc@800
|
172 val n' = #maxName st
|
adamc@800
|
173 val st = {decls = #decls st,
|
adamc@800
|
174 script = #script st,
|
adamc@800
|
175 included = #included st,
|
adamc@800
|
176 injectors = #injectors st,
|
adamc@800
|
177 listInjectors = TM.insert (#listInjectors st, t', n'),
|
adamc@800
|
178 decoders = #decoders st,
|
adamc@800
|
179 maxName = n' + 1}
|
adamc@800
|
180
|
adamc@800
|
181 val s = (TFfi ("Basis", "string"), loc)
|
adamc@801
|
182 val (e', st) = quoteExp loc t' ((EField ((ERel 0, loc), "1"), loc), st)
|
adamc@800
|
183
|
adamc@800
|
184 val body = (ECase ((ERel 0, loc),
|
adamc@800
|
185 [((PNone rt, loc),
|
adamc@800
|
186 str loc "null"),
|
adamc@800
|
187 ((PSome (rt, (PVar ("x", rt), loc)), loc),
|
adam@1541
|
188 strcat loc [str loc "{_1:",
|
adamc@800
|
189 e',
|
adamc@800
|
190 str loc ",_2:",
|
adamc@800
|
191 (EApp ((ENamed n', loc),
|
adamc@800
|
192 (EField ((ERel 0, loc), "2"), loc)), loc),
|
adam@1541
|
193 str loc "}"])],
|
adamc@800
|
194 {disc = t, result = s}), loc)
|
adamc@800
|
195 val body = (EAbs ("x", t, s, body), loc)
|
adamc@800
|
196
|
adamc@840
|
197 val st = {decls = ("jsify", n', (TFun (t, s), loc),
|
adamc@840
|
198 body, "jsify") :: #decls st,
|
adamc@800
|
199 script = #script st,
|
adamc@800
|
200 included = #included st,
|
adamc@800
|
201 injectors = #injectors st,
|
adamc@800
|
202 listInjectors = #listInjectors st,
|
adamc@800
|
203 decoders= #decoders st,
|
adamc@800
|
204 maxName = #maxName st}
|
adamc@800
|
205
|
adamc@800
|
206
|
adamc@800
|
207 in
|
adamc@800
|
208 ((EApp ((ENamed n', loc), e), loc), st)
|
adamc@800
|
209 end)
|
adamc@800
|
210
|
adamc@595
|
211 | TDatatype (n, ref (dk, cs)) =>
|
adamc@595
|
212 (case IM.find (#injectors st, n) of
|
adamc@595
|
213 SOME n' => ((EApp ((ENamed n', loc), e), loc), st)
|
adamc@595
|
214 | NONE =>
|
adamc@595
|
215 let
|
adamc@595
|
216 val n' = #maxName st
|
adamc@595
|
217 val st = {decls = #decls st,
|
adamc@595
|
218 script = #script st,
|
adamc@595
|
219 included = #included st,
|
adamc@595
|
220 injectors = IM.insert (#injectors st, n, n'),
|
adamc@800
|
221 listInjectors = #listInjectors st,
|
adamc@638
|
222 decoders = #decoders st,
|
adamc@595
|
223 maxName = n' + 1}
|
adamc@595
|
224
|
adamc@595
|
225 val (pes, st) = ListUtil.foldlMap
|
adamc@595
|
226 (fn ((_, cn, NONE), st) =>
|
adamc@595
|
227 (((PCon (dk, PConVar cn, NONE), loc),
|
adamc@596
|
228 case dk of
|
adamc@596
|
229 Option => str loc "null"
|
adamc@596
|
230 | _ => str loc (Int.toString cn)),
|
adamc@595
|
231 st)
|
adamc@595
|
232 | ((_, cn, SOME t), st) =>
|
adamc@595
|
233 let
|
adamc@595
|
234 val (e, st) = quoteExp loc t ((ERel 0, loc), st)
|
adamc@595
|
235 in
|
adamc@595
|
236 (((PCon (dk, PConVar cn, SOME (PVar ("x", t), loc)), loc),
|
adamc@596
|
237 case dk of
|
adamc@596
|
238 Option =>
|
adamc@596
|
239 if isNullable t then
|
adamc@638
|
240 strcat loc [str loc "{v:",
|
adamc@596
|
241 e,
|
adamc@596
|
242 str loc "}"]
|
adamc@596
|
243 else
|
adamc@596
|
244 e
|
adamc@597
|
245 | _ => strcat loc [str loc ("{n:" ^ Int.toString cn
|
adamc@597
|
246 ^ ",v:"),
|
adamc@597
|
247 e,
|
adamc@597
|
248 str loc "}"]),
|
adamc@595
|
249 st)
|
adamc@595
|
250 end)
|
adamc@595
|
251 st cs
|
adamc@595
|
252
|
adamc@595
|
253 val s = (TFfi ("Basis", "string"), loc)
|
adamc@595
|
254 val body = (ECase ((ERel 0, loc), pes,
|
adamc@595
|
255 {disc = t, result = s}), loc)
|
adamc@595
|
256 val body = (EAbs ("x", t, s, body), loc)
|
adamc@595
|
257
|
adamc@840
|
258 val st = {decls = ("jsify", n', (TFun (t, s), loc),
|
adamc@840
|
259 body, "jsify") :: #decls st,
|
adamc@595
|
260 script = #script st,
|
adamc@595
|
261 included = #included st,
|
adamc@595
|
262 injectors = #injectors st,
|
adamc@800
|
263 listInjectors = #listInjectors st,
|
adamc@638
|
264 decoders= #decoders st,
|
adamc@595
|
265 maxName = #maxName st}
|
adamc@595
|
266 in
|
adamc@595
|
267 ((EApp ((ENamed n', loc), e), loc), st)
|
adamc@595
|
268 end)
|
adamc@595
|
269
|
adamc@834
|
270 | _ => ((*Print.prefaces "Can't embed" [("t", MonoPrint.p_typ MonoEnv.empty t)];*)
|
adamc@834
|
271 raise CantEmbed t)
|
adamc@590
|
272
|
adamc@613
|
273 fun unurlifyExp loc (t : typ, st) =
|
adamc@613
|
274 case #1 t of
|
adamc@1323
|
275 TRecord [] => ("(i++,null)", st)
|
adamc@1323
|
276 | TFfi ("Basis", "unit") => ("(i++,null)", st)
|
adamc@613
|
277 | TRecord [(x, t)] =>
|
adamc@613
|
278 let
|
adamc@613
|
279 val (e, st) = unurlifyExp loc (t, st)
|
adamc@613
|
280 in
|
adamc@613
|
281 ("{_" ^ x ^ ":" ^ e ^ "}",
|
adamc@613
|
282 st)
|
adamc@613
|
283 end
|
adamc@613
|
284 | TRecord ((x, t) :: xts) =>
|
adamc@613
|
285 let
|
adamc@613
|
286 val (e', st) = unurlifyExp loc (t, st)
|
adamc@613
|
287 val (es, st) = ListUtil.foldlMap
|
adamc@638
|
288 (fn ((x, t), st) =>
|
adamc@638
|
289 let
|
adamc@638
|
290 val (e, st) = unurlifyExp loc (t, st)
|
adamc@638
|
291 in
|
adamc@638
|
292 (",_" ^ x ^ ":" ^ e, st)
|
adamc@638
|
293 end)
|
adamc@638
|
294 st xts
|
adamc@613
|
295 in
|
adamc@613
|
296 (String.concat ("{_"
|
adamc@613
|
297 :: x
|
adamc@613
|
298 :: ":"
|
adamc@613
|
299 :: e'
|
adamc@613
|
300 :: es
|
adamc@613
|
301 @ ["}"]), st)
|
adamc@613
|
302 end
|
adamc@613
|
303
|
adamc@679
|
304 | TFfi ("Basis", "string") => ("uu(t[i++])", st)
|
adamc@1025
|
305 | TFfi ("Basis", "char") => ("uu(t[i++])", st)
|
adamc@613
|
306 | TFfi ("Basis", "int") => ("parseInt(t[i++])", st)
|
adam@1404
|
307 | TFfi ("Basis", "time") => ("parseInt(t[i++])", st)
|
adamc@613
|
308 | TFfi ("Basis", "float") => ("parseFloat(t[i++])", st)
|
adam@1319
|
309 | TFfi ("Basis", "channel") => ("(t[i++].length > 0 ? parseInt(t[i-1]) : null)", st)
|
adamc@613
|
310
|
adamc@912
|
311 | TFfi ("Basis", "bool") => ("t[i++] == \"1\"", st)
|
adamc@613
|
312
|
adam@1620
|
313 | TSource => ("parseSource(t[i++], t[i++])", st)
|
adam@1620
|
314
|
adamc@638
|
315 | TOption t =>
|
adamc@613
|
316 let
|
adamc@638
|
317 val (e, st) = unurlifyExp loc (t, st)
|
adamc@638
|
318 val e = if isNullable t then
|
adamc@638
|
319 "{v:" ^ e ^ "}"
|
adamc@638
|
320 else
|
adamc@638
|
321 e
|
adamc@613
|
322 in
|
adamc@703
|
323 ("(t[i++]==\"Some\"?" ^ e ^ ":null)", st)
|
adamc@638
|
324 end
|
adamc@613
|
325
|
adamc@905
|
326 | TList t =>
|
adamc@905
|
327 let
|
adamc@905
|
328 val (e, st) = unurlifyExp loc (t, st)
|
adamc@905
|
329 in
|
adamc@905
|
330 ("uul(function(){return t[i++];},function(){return " ^ e ^ "})", st)
|
adamc@905
|
331 end
|
adamc@905
|
332
|
adamc@638
|
333 | TDatatype (n, ref (dk, cs)) =>
|
adamc@638
|
334 (case IM.find (#decoders st, n) of
|
adamc@638
|
335 SOME n' => ("(tmp=_n" ^ Int.toString n' ^ "(t,i),i=tmp._1,tmp._2)", st)
|
adamc@613
|
336 | NONE =>
|
adamc@613
|
337 let
|
adamc@613
|
338 val n' = #maxName st
|
adamc@613
|
339 val st = {decls = #decls st,
|
adamc@613
|
340 script = #script st,
|
adamc@613
|
341 included = #included st,
|
adamc@638
|
342 injectors = #injectors st,
|
adamc@800
|
343 listInjectors = #listInjectors st,
|
adamc@638
|
344 decoders = IM.insert (#decoders st, n, n'),
|
adamc@613
|
345 maxName = n' + 1}
|
adamc@613
|
346
|
adamc@638
|
347 val (e, st) = foldl (fn ((x, cn, NONE), (e, st)) =>
|
adamc@638
|
348 ("x==\"" ^ x ^ "\"?"
|
adamc@638
|
349 ^ (case dk of
|
adamc@638
|
350 Option => "null"
|
adamc@638
|
351 | _ => Int.toString cn)
|
adamc@638
|
352 ^ ":" ^ e,
|
adamc@613
|
353 st)
|
adamc@638
|
354 | ((x, cn, SOME t), (e, st)) =>
|
adamc@613
|
355 let
|
adamc@638
|
356 val (e', st) = unurlifyExp loc (t, st)
|
adamc@613
|
357 in
|
adamc@638
|
358 ("x==\"" ^ x ^ "\"?"
|
adamc@638
|
359 ^ (case dk of
|
adamc@638
|
360 Option =>
|
adamc@638
|
361 if isNullable t then
|
adamc@638
|
362 "{v:" ^ e' ^ "}"
|
adamc@638
|
363 else
|
adamc@638
|
364 e'
|
adamc@638
|
365 | _ => "{n:" ^ Int.toString cn ^ ",v:" ^ e' ^ "}")
|
adamc@638
|
366 ^ ":" ^ e,
|
adamc@613
|
367 st)
|
adamc@613
|
368 end)
|
adamc@810
|
369 ("pf(\"" ^ ErrorMsg.spanToString loc ^ "\")", st) cs
|
adamc@613
|
370
|
adamc@638
|
371 val body = "function _n" ^ Int.toString n' ^ "(t,i){var x=t[i++];var r="
|
adamc@638
|
372 ^ e ^ ";return {_1:i,_2:r}}\n\n"
|
adamc@613
|
373
|
adamc@638
|
374 val st = {decls = #decls st,
|
adamc@638
|
375 script = body :: #script st,
|
adamc@613
|
376 included = #included st,
|
adamc@613
|
377 injectors = #injectors st,
|
adamc@800
|
378 listInjectors = #listInjectors st,
|
adamc@638
|
379 decoders = #decoders st,
|
adamc@613
|
380 maxName = #maxName st}
|
adamc@613
|
381 in
|
adamc@638
|
382 ("(tmp=_n" ^ Int.toString n' ^ "(t,i),i=tmp._1,tmp._2)", st)
|
adamc@638
|
383 end)
|
adamc@613
|
384
|
adamc@613
|
385 | _ => (EM.errorAt loc "Don't know how to unurlify type in JavaScript";
|
adamc@613
|
386 Print.prefaces "Can't unurlify" [("t", MonoPrint.p_typ MonoEnv.empty t)];
|
adamc@613
|
387 ("ERROR", st))
|
adamc@613
|
388
|
adamc@646
|
389 fun padWith (ch, s, len) =
|
adamc@646
|
390 if size s < len then
|
adamc@646
|
391 padWith (ch, String.str ch ^ s, len - 1)
|
adamc@646
|
392 else
|
adamc@646
|
393 s
|
adamc@646
|
394
|
adamc@794
|
395 val foundJavaScript = ref false
|
adamc@794
|
396
|
adamc@800
|
397 fun jsExp mode outer =
|
adamc@567
|
398 let
|
adamc@589
|
399 val len = length outer
|
adamc@567
|
400
|
adamc@589
|
401 fun jsE inner (e as (_, loc), st) =
|
adamc@589
|
402 let
|
adamc@590
|
403 val str = str loc
|
adamc@567
|
404
|
adamc@589
|
405 fun patCon pc =
|
adamc@589
|
406 case pc of
|
adamc@589
|
407 PConVar n => str (Int.toString n)
|
adamc@589
|
408 | PConFfi {mod = "Basis", con = "True", ...} => str "true"
|
adamc@589
|
409 | PConFfi {mod = "Basis", con = "False", ...} => str "false"
|
adamc@970
|
410 | PConFfi {con, ...} => str ("\"" ^ con ^ "\"")
|
adamc@567
|
411
|
adamc@591
|
412 fun unsupported s =
|
adamc@591
|
413 (EM.errorAt loc (s ^ " in code to be compiled to JavaScript[2]");
|
adamc@910
|
414 Print.preface ("Code", MonoPrint.p_exp MonoEnv.empty e);
|
adamc@591
|
415 (str "ERROR", st))
|
adamc@577
|
416
|
adamc@589
|
417 val strcat = strcat loc
|
adamc@584
|
418
|
adamc@589
|
419 fun jsPrim p =
|
adamc@943
|
420 let
|
adamc@943
|
421 fun jsChar ch =
|
adamc@943
|
422 case ch of
|
adamc@943
|
423 #"'" =>
|
adamc@943
|
424 if mode = Attribute then
|
adamc@943
|
425 "\\047"
|
adamc@943
|
426 else
|
adamc@943
|
427 "'"
|
adamc@943
|
428 | #"\"" => "\\\""
|
adamc@943
|
429 | #"<" => "\\074"
|
adamc@943
|
430 | #"\\" => "\\\\"
|
adamc@943
|
431 | #"\n" => "\\n"
|
adamc@943
|
432 | #"\r" => "\\r"
|
adamc@943
|
433 | #"\t" => "\\t"
|
adamc@943
|
434 | ch =>
|
adam@1285
|
435 if Char.isPrint ch orelse ord ch >= 128 then
|
adamc@943
|
436 String.str ch
|
adamc@943
|
437 else
|
adamc@943
|
438 "\\" ^ padWith (#"0",
|
adamc@943
|
439 Int.fmt StringCvt.OCT (ord ch),
|
adamc@943
|
440 3)
|
adamc@943
|
441 in
|
adamc@943
|
442 case p of
|
adamc@943
|
443 Prim.String s =>
|
adamc@943
|
444 str ("\"" ^ String.translate jsChar s ^ "\"")
|
adamc@1176
|
445 | Prim.Char ch => str ("\"" ^ jsChar ch ^ "\"")
|
adamc@943
|
446 | _ => str (Prim.toString p)
|
adamc@943
|
447 end
|
adamc@589
|
448
|
adamc@970
|
449 fun jsPat (p, _) =
|
adamc@589
|
450 case p of
|
adamc@970
|
451 PWild => str "{c:\"w\"}"
|
adamc@970
|
452 | PVar _ => str "{c:\"v\"}"
|
adamc@970
|
453 | PPrim p => strcat [str "{c:\"c\",v:",
|
adamc@589
|
454 jsPrim p,
|
adamc@970
|
455 str "}"]
|
adamc@589
|
456 | PCon (_, PConFfi {mod = "Basis", con = "True", ...}, NONE) =>
|
adamc@970
|
457 str "{c:\"c\",v:true}"
|
adamc@589
|
458 | PCon (_, PConFfi {mod = "Basis", con = "False", ...}, NONE) =>
|
adamc@970
|
459 str "{c:\"c\",v:false}"
|
adamc@596
|
460 | PCon (Option, _, NONE) =>
|
adamc@970
|
461 str "{c:\"c\",v:null}"
|
adamc@596
|
462 | PCon (Option, PConVar n, SOME p) =>
|
adamc@596
|
463 (case IM.find (someTs, n) of
|
adamc@596
|
464 NONE => raise Fail "Jscomp: Not in someTs"
|
adamc@974
|
465 | SOME t =>
|
adamc@974
|
466 strcat [str ("{c:\"s\",n:"
|
adamc@974
|
467 ^ (if isNullable t then
|
adamc@974
|
468 "true"
|
adamc@974
|
469 else
|
adamc@974
|
470 "false")
|
adamc@974
|
471 ^ ",p:"),
|
adamc@974
|
472 jsPat p,
|
adamc@974
|
473 str "}"])
|
adamc@974
|
474 | PCon (_, pc, NONE) => strcat [str "{c:\"c\",v:",
|
adamc@970
|
475 patCon pc,
|
adamc@970
|
476 str "}"]
|
adamc@970
|
477 | PCon (_, pc, SOME p) => strcat [str "{c:\"1\",n:",
|
adamc@970
|
478 patCon pc,
|
adamc@970
|
479 str ",p:",
|
adamc@970
|
480 jsPat p,
|
adamc@970
|
481 str "}"]
|
adamc@970
|
482 | PRecord xps => strcat [str "{c:\"r\",l:",
|
adamc@970
|
483 foldr (fn ((x, p, _), e) =>
|
adamc@970
|
484 strcat [str ("cons({n:\"" ^ x ^ "\",p:"),
|
adamc@970
|
485 jsPat p,
|
adamc@970
|
486 str "},",
|
adamc@970
|
487 e,
|
adamc@970
|
488 str ")"])
|
adamc@970
|
489 (str "null") xps,
|
adamc@970
|
490 str "}"]
|
adamc@970
|
491 | PNone _ => str "{c:\"c\",v:null}"
|
adamc@970
|
492 | PSome (t, p) => strcat [str ("{c:\"s\",n:"
|
adamc@829
|
493 ^ (if isNullable t then
|
adamc@970
|
494 "true"
|
adamc@829
|
495 else
|
adamc@970
|
496 "false")
|
adamc@970
|
497 ^ ",p:"),
|
adamc@970
|
498 jsPat p,
|
adamc@970
|
499 str "}"]
|
adamc@589
|
500
|
adamc@601
|
501 val jsifyString = String.translate (fn #"\"" => "\\\""
|
adamc@601
|
502 | #"\\" => "\\\\"
|
adamc@601
|
503 | ch => String.str ch)
|
adamc@601
|
504
|
adamc@601
|
505 fun jsifyStringMulti (n, s) =
|
adamc@601
|
506 case n of
|
adamc@601
|
507 0 => s
|
adamc@601
|
508 | _ => jsifyStringMulti (n - 1, jsifyString s)
|
adamc@601
|
509
|
adamc@601
|
510 fun deStrcat level (all as (e, _)) =
|
adamc@589
|
511 case e of
|
adamc@601
|
512 EPrim (Prim.String s) => jsifyStringMulti (level, s)
|
adamc@601
|
513 | EStrcat (e1, e2) => deStrcat level e1 ^ deStrcat level e2
|
adam@1663
|
514 | EFfiApp ("Basis", "jsifyString", [(e, _)]) => "\"" ^ deStrcat (level + 1) e ^ "\""
|
adamc@601
|
515 | _ => (Print.prefaces "deStrcat" [("e", MonoPrint.p_exp MonoEnv.empty all)];
|
adamc@601
|
516 raise Fail "Jscomp: deStrcat")
|
adamc@590
|
517
|
adamc@590
|
518 val quoteExp = quoteExp loc
|
adamc@567
|
519 in
|
adamc@801
|
520 (*Print.prefaces "jsE" [("e", MonoPrint.p_exp MonoEnv.empty e),
|
adamc@801
|
521 ("inner", Print.PD.string (Int.toString inner))];*)
|
adamc@590
|
522
|
adamc@589
|
523 case #1 e of
|
adamc@970
|
524 EPrim p => (strcat [str "{c:\"c\",v:",
|
adamc@970
|
525 jsPrim p,
|
adamc@970
|
526 str "}"],
|
adamc@970
|
527 st)
|
adamc@589
|
528 | ERel n =>
|
adamc@589
|
529 if n < inner then
|
adamc@970
|
530 (str ("{c:\"v\",n:" ^ Int.toString n ^ "}"), st)
|
adamc@589
|
531 else
|
adamc@589
|
532 let
|
adamc@589
|
533 val n = n - inner
|
adamc@813
|
534 (*val () = Print.prefaces "quote" [("t", MonoPrint.p_typ MonoEnv.empty
|
adamc@813
|
535 (List.nth (outer, n)))]*)
|
adamc@970
|
536 val (e, st) = quoteExp (List.nth (outer, n)) ((ERel n, loc), st)
|
adamc@589
|
537 in
|
adamc@970
|
538 (strcat [str "{c:\"c\",v:",
|
adamc@970
|
539 e,
|
adamc@970
|
540 str "}"], st)
|
adamc@589
|
541 end
|
adamc@567
|
542
|
adamc@589
|
543 | ENamed n =>
|
adamc@589
|
544 let
|
adamc@589
|
545 val st =
|
adamc@589
|
546 if IS.member (#included st, n) then
|
adamc@589
|
547 st
|
adamc@589
|
548 else
|
adamc@589
|
549 case IM.find (nameds, n) of
|
adamc@589
|
550 NONE => raise Fail "Jscomp: Unbound ENamed"
|
adamc@589
|
551 | SOME e =>
|
adamc@589
|
552 let
|
adamc@589
|
553 val st = {decls = #decls st,
|
adamc@589
|
554 script = #script st,
|
adamc@595
|
555 included = IS.add (#included st, n),
|
adamc@595
|
556 injectors = #injectors st,
|
adamc@800
|
557 listInjectors = #listInjectors st,
|
adamc@638
|
558 decoders = #decoders st,
|
adamc@595
|
559 maxName = #maxName st}
|
adamc@578
|
560
|
adamc@801
|
561 val old = e
|
adamc@970
|
562 val (e, st) = jsExp mode [] (e, st)
|
adamc@601
|
563 val e = deStrcat 0 e
|
adamc@1262
|
564 val e = String.translate (fn #"'" => "\\'"
|
adamc@1262
|
565 | #"\\" => "\\\\"
|
adamc@1262
|
566 | ch => String.str ch) e
|
adamc@589
|
567
|
adamc@1262
|
568 val sc = "urfuncs[" ^ Int.toString n ^ "] = {c:\"t\",f:'"
|
adamc@1262
|
569 ^ e ^ "'};\n"
|
adamc@589
|
570 in
|
adamc@801
|
571 (*Print.prefaces "jsify'" [("old", MonoPrint.p_exp MonoEnv.empty old),
|
adamc@801
|
572 ("new", MonoPrint.p_exp MonoEnv.empty new)];*)
|
adamc@589
|
573 {decls = #decls st,
|
adamc@589
|
574 script = sc :: #script st,
|
adamc@595
|
575 included = #included st,
|
adamc@595
|
576 injectors = #injectors st,
|
adamc@800
|
577 listInjectors = #listInjectors st,
|
adamc@638
|
578 decoders= #decoders st,
|
adamc@595
|
579 maxName = #maxName st}
|
adamc@589
|
580 end
|
adamc@589
|
581 in
|
adamc@970
|
582 (str ("{c:\"n\",n:" ^ Int.toString n ^ "}"), st)
|
adamc@589
|
583 end
|
adamc@589
|
584
|
adamc@970
|
585 | ECon (Option, _, NONE) => (str "{c:\"c\",v:null}", st)
|
adamc@596
|
586 | ECon (Option, PConVar n, SOME e) =>
|
adamc@596
|
587 let
|
adamc@596
|
588 val (e, st) = jsE inner (e, st)
|
adamc@596
|
589 in
|
adamc@596
|
590 case IM.find (someTs, n) of
|
adamc@596
|
591 NONE => raise Fail "Jscomp: Not in someTs [2]"
|
adamc@596
|
592 | SOME t =>
|
adamc@596
|
593 (if isNullable t then
|
adamc@970
|
594 strcat [str "{c:\"s\",v:",
|
adamc@596
|
595 e,
|
adamc@596
|
596 str "}"]
|
adamc@596
|
597 else
|
adamc@596
|
598 e, st)
|
adamc@596
|
599 end
|
adamc@596
|
600
|
adamc@970
|
601 | ECon (_, pc, NONE) => (strcat [str "{c:\"c\",v:",
|
adamc@970
|
602 patCon pc,
|
adamc@970
|
603 str "}"],
|
adamc@970
|
604 st)
|
adamc@589
|
605 | ECon (_, pc, SOME e) =>
|
adamc@589
|
606 let
|
adamc@589
|
607 val (s, st) = jsE inner (e, st)
|
adamc@589
|
608 in
|
adamc@970
|
609 (strcat [str "{c:\"1\",n:",
|
adamc@589
|
610 patCon pc,
|
adamc@589
|
611 str ",v:",
|
adamc@589
|
612 s,
|
adamc@589
|
613 str "}"], st)
|
adamc@589
|
614 end
|
adamc@596
|
615
|
adamc@970
|
616 | ENone _ => (str "{c:\"c\",v:null}", st)
|
adamc@589
|
617 | ESome (t, e) =>
|
adamc@572
|
618 let
|
adamc@572
|
619 val (e, st) = jsE inner (e, st)
|
adamc@572
|
620 in
|
adamc@589
|
621 (if isNullable t then
|
adamc@970
|
622 strcat [str "{c:\"s\",v:", e, str "}"]
|
adamc@589
|
623 else
|
adamc@589
|
624 e, st)
|
adamc@589
|
625 end
|
adamc@589
|
626
|
adamc@589
|
627 | EFfi k =>
|
adamc@589
|
628 let
|
adamc@765
|
629 val name = case Settings.jsFunc k of
|
adamc@589
|
630 NONE => (EM.errorAt loc ("Unsupported FFI identifier " ^ #2 k
|
adamc@589
|
631 ^ " in JavaScript");
|
adamc@589
|
632 "ERROR")
|
adamc@589
|
633 | SOME s => s
|
adamc@589
|
634 in
|
adamc@970
|
635 (str ("{c:\"c\",v:" ^ name ^ "}"), st)
|
adamc@589
|
636 end
|
adamc@970
|
637 | EFfiApp ("Basis", "sigString", [_]) => (strcat [str "{c:\"c\",v:\"",
|
adamc@970
|
638 e,
|
adamc@970
|
639 str "\"}"], st)
|
adamc@589
|
640 | EFfiApp (m, x, args) =>
|
adamc@589
|
641 let
|
adamc@765
|
642 val name = case Settings.jsFunc (m, x) of
|
adamc@589
|
643 NONE => (EM.errorAt loc ("Unsupported FFI function "
|
adam@1433
|
644 ^ m ^ "." ^ x ^ " in JavaScript");
|
adamc@589
|
645 "ERROR")
|
adamc@589
|
646 | SOME s => s
|
adamc@970
|
647
|
adam@1663
|
648 val (e, st) = foldr (fn ((e, _), (acc, st)) =>
|
adamc@970
|
649 let
|
adamc@970
|
650 val (e, st) = jsE inner (e, st)
|
adamc@970
|
651 in
|
adamc@970
|
652 (strcat [str "cons(",
|
adamc@970
|
653 e,
|
adamc@970
|
654 str ",",
|
adamc@970
|
655 acc,
|
adamc@970
|
656 str ")"],
|
adamc@970
|
657 st)
|
adamc@970
|
658 end)
|
adamc@970
|
659 (str "null", st) args
|
adamc@589
|
660 in
|
adamc@1057
|
661 (strcat [str ("{c:\"f\",f:\"" ^ name ^ "\",a:"),
|
adamc@970
|
662 e,
|
adamc@970
|
663 str "}"],
|
adamc@970
|
664 st)
|
adamc@589
|
665 end
|
adamc@589
|
666
|
adamc@589
|
667 | EApp (e1, e2) =>
|
adamc@589
|
668 let
|
adamc@589
|
669 val (e1, st) = jsE inner (e1, st)
|
adamc@589
|
670 val (e2, st) = jsE inner (e2, st)
|
adamc@589
|
671 in
|
adamc@970
|
672 (strcat [str "{c:\"a\",f:",
|
adamc@970
|
673 e1,
|
adamc@970
|
674 str ",x:",
|
adamc@970
|
675 e2,
|
adamc@970
|
676 str "}"], st)
|
adamc@589
|
677 end
|
adamc@589
|
678 | EAbs (_, _, _, e) =>
|
adamc@589
|
679 let
|
adamc@589
|
680 val (e, st) = jsE (inner + 1) (e, st)
|
adamc@589
|
681 in
|
adamc@970
|
682 (strcat [str "{c:\"l\",b:",
|
adamc@970
|
683 e,
|
adamc@970
|
684 str "}"], st)
|
adamc@589
|
685 end
|
adamc@589
|
686
|
adamc@589
|
687 | EUnop (s, e) =>
|
adamc@589
|
688 let
|
adamc@970
|
689 val name = case s of
|
adamc@970
|
690 "!" => "not"
|
adamc@970
|
691 | "-" => "neg"
|
adamc@980
|
692 | _ => raise Fail ("Jscomp: Unknown unary operator " ^ s)
|
adamc@970
|
693
|
adamc@589
|
694 val (e, st) = jsE inner (e, st)
|
adamc@589
|
695 in
|
adamc@1057
|
696 (strcat [str ("{c:\"f\",f:\"" ^ name ^ "\",a:cons("),
|
adamc@572
|
697 e,
|
adamc@970
|
698 str ",null)}"],
|
adamc@589
|
699 st)
|
adamc@589
|
700 end
|
adam@1360
|
701 | EBinop (bi, s, e1, e2) =>
|
adamc@589
|
702 let
|
adamc@970
|
703 val name = case s of
|
adamc@970
|
704 "==" => "eq"
|
adamc@970
|
705 | "!strcmp" => "eq"
|
adamc@970
|
706 | "+" => "plus"
|
adamc@970
|
707 | "-" => "minus"
|
adamc@970
|
708 | "*" => "times"
|
adam@1360
|
709 | "/" => (case bi of Int => "divInt" | NotInt => "div")
|
adam@1360
|
710 | "%" => (case bi of Int => "modInt" | NotInt => "mod")
|
adam@1619
|
711 | "fdiv" => "div"
|
adam@1619
|
712 | "fmod" => "mod"
|
adamc@970
|
713 | "<" => "lt"
|
adamc@970
|
714 | "<=" => "le"
|
adamc@980
|
715 | "strcmp" => "strcmp"
|
adamc@980
|
716 | _ => raise Fail ("Jscomp: Unknown binary operator " ^ s)
|
adamc@729
|
717
|
adamc@589
|
718 val (e1, st) = jsE inner (e1, st)
|
adamc@589
|
719 val (e2, st) = jsE inner (e2, st)
|
adamc@589
|
720 in
|
adamc@1057
|
721 (strcat [str ("{c:\"f\",f:\"" ^ name ^ "\",a:cons("),
|
adamc@589
|
722 e1,
|
adamc@970
|
723 str ",cons(",
|
adamc@589
|
724 e2,
|
adamc@970
|
725 str ",null))}"],
|
adamc@589
|
726 st)
|
adamc@589
|
727 end
|
adamc@589
|
728
|
adamc@970
|
729 | ERecord [] => (str "{c:\"c\",v:null}", st)
|
adamc@970
|
730 | ERecord xes =>
|
adamc@589
|
731 let
|
adamc@589
|
732 val (es, st) =
|
adamc@589
|
733 foldr (fn ((x, e, _), (es, st)) =>
|
adamc@589
|
734 let
|
adamc@589
|
735 val (e, st) = jsE inner (e, st)
|
adamc@589
|
736 in
|
adamc@973
|
737 (strcat [str ("cons({n:\"" ^ x ^ "\",v:"),
|
adamc@970
|
738 e,
|
adamc@970
|
739 str "},",
|
adamc@970
|
740 es,
|
adamc@970
|
741 str ")"],
|
adamc@589
|
742 st)
|
adamc@589
|
743 end)
|
adamc@970
|
744 (str "null", st) xes
|
adamc@589
|
745 in
|
adamc@970
|
746 (strcat [str "{c:\"r\",l:",
|
adamc@970
|
747 es,
|
adamc@970
|
748 str "}"],
|
adamc@589
|
749 st)
|
adamc@589
|
750 end
|
adamc@934
|
751 | EField (e', x) =>
|
adamc@589
|
752 let
|
adamc@934
|
753 fun default () =
|
adamc@934
|
754 let
|
adamc@934
|
755 val (e', st) = jsE inner (e', st)
|
adamc@934
|
756 in
|
adamc@970
|
757 (strcat [str "{c:\".\",r:",
|
adamc@970
|
758 e',
|
adamc@970
|
759 str (",f:\"" ^ x ^ "\"}")], st)
|
adamc@934
|
760 end
|
adamc@934
|
761
|
adamc@934
|
762 fun seek (e, xs) =
|
adamc@934
|
763 case #1 e of
|
adamc@934
|
764 ERel n =>
|
adamc@934
|
765 if n < inner then
|
adamc@934
|
766 default ()
|
adamc@934
|
767 else
|
adamc@934
|
768 let
|
adamc@934
|
769 val n = n - inner
|
adamc@934
|
770 val t = List.nth (outer, n)
|
adamc@934
|
771 val t = foldl (fn (x, (TRecord xts, _)) =>
|
adamc@934
|
772 (case List.find (fn (x', _) => x' = x) xts of
|
adamc@934
|
773 NONE => raise Fail "Jscomp: Bad seek [1]"
|
adamc@934
|
774 | SOME (_, t) => t)
|
adamc@934
|
775 | _ => raise Fail "Jscomp: Bad seek [2]")
|
adamc@934
|
776 t xs
|
adamc@934
|
777
|
adamc@934
|
778 val e = (ERel n, loc)
|
adamc@934
|
779 val e = foldl (fn (x, e) => (EField (e, x), loc)) e xs
|
adamc@970
|
780 val (e, st) = quoteExp t (e, st)
|
adamc@934
|
781 in
|
adamc@970
|
782 (strcat [str "{c:\"c\",v:",
|
adamc@970
|
783 e,
|
adamc@970
|
784 str "}"],
|
adamc@970
|
785 st)
|
adamc@934
|
786 end
|
adamc@934
|
787 | EField (e', x) => seek (e', x :: xs)
|
adamc@934
|
788 | _ => default ()
|
adamc@589
|
789 in
|
adamc@934
|
790 seek (e', [x])
|
adamc@934
|
791 end
|
adamc@589
|
792
|
adamc@970
|
793 | ECase (e', pes, _) =>
|
adamc@801
|
794 let
|
adamc@970
|
795 val (e', st) = jsE inner (e', st)
|
adamc@589
|
796
|
adamc@970
|
797 val (ps, st) =
|
adamc@970
|
798 foldr (fn ((p, e), (ps, st)) =>
|
adamc@970
|
799 let
|
adamc@974
|
800 val (e, st) = jsE (inner + E.patBindsN p) (e, st)
|
adamc@970
|
801 in
|
adamc@970
|
802 (strcat [str "cons({p:",
|
adamc@970
|
803 jsPat p,
|
adamc@970
|
804 str ",b:",
|
adamc@970
|
805 e,
|
adamc@970
|
806 str "},",
|
adamc@970
|
807 ps,
|
adamc@970
|
808 str ")"],
|
adamc@970
|
809 st)
|
adamc@970
|
810 end)
|
adamc@970
|
811 (str "null", st) pes
|
adamc@801
|
812 in
|
adamc@970
|
813 (strcat [str "{c:\"m\",e:",
|
adamc@974
|
814 e',
|
adamc@970
|
815 str ",p:",
|
adamc@970
|
816 ps,
|
adamc@970
|
817 str "}"], st)
|
adamc@801
|
818 end
|
adamc@589
|
819
|
adamc@589
|
820 | EStrcat (e1, e2) =>
|
adamc@589
|
821 let
|
adamc@589
|
822 val (e1, st) = jsE inner (e1, st)
|
adamc@589
|
823 val (e2, st) = jsE inner (e2, st)
|
adamc@589
|
824 in
|
adamc@1057
|
825 (strcat [str "{c:\"f\",f:\"cat\",a:cons(", e1, str ",cons(", e2, str ",null))}"], st)
|
adamc@589
|
826 end
|
adamc@589
|
827
|
adamc@589
|
828 | EError (e, _) =>
|
adamc@589
|
829 let
|
adamc@589
|
830 val (e, st) = jsE inner (e, st)
|
adamc@589
|
831 in
|
adamc@1057
|
832 (strcat [str "{c:\"f\",f:\"er\",a:cons(", e, str ",null)}"],
|
adamc@589
|
833 st)
|
adamc@589
|
834 end
|
adamc@589
|
835
|
adamc@589
|
836 | ESeq (e1, e2) =>
|
adamc@589
|
837 let
|
adamc@589
|
838 val (e1, st) = jsE inner (e1, st)
|
adamc@589
|
839 val (e2, st) = jsE inner (e2, st)
|
adamc@589
|
840 in
|
adamc@970
|
841 (strcat [str "{c:\";\",e1:", e1, str ",e2:", e2, str "}"], st)
|
adamc@589
|
842 end
|
adamc@589
|
843 | ELet (_, _, e1, e2) =>
|
adamc@589
|
844 let
|
adamc@589
|
845 val (e1, st) = jsE inner (e1, st)
|
adamc@589
|
846 val (e2, st) = jsE (inner + 1) (e2, st)
|
adamc@589
|
847 in
|
adamc@970
|
848 (strcat [str "{c:\"=\",e1:",
|
adamc@589
|
849 e1,
|
adamc@970
|
850 str ",e2:",
|
adamc@589
|
851 e2,
|
adamc@970
|
852 str "}"], st)
|
adamc@572
|
853 end
|
adamc@589
|
854
|
adamc@815
|
855 | EJavaScript (Source _, e) =>
|
adamc@794
|
856 (foundJavaScript := true;
|
adamc@815
|
857 jsE inner (e, st))
|
adamc@815
|
858 | EJavaScript (_, e) =>
|
adamc@815
|
859 let
|
adamc@815
|
860 val (e, st) = jsE inner (e, st)
|
adamc@815
|
861 in
|
adamc@815
|
862 foundJavaScript := true;
|
adamc@970
|
863 (strcat [str "{c:\"e\",e:",
|
adamc@970
|
864 e,
|
adamc@970
|
865 str "}"],
|
adamc@815
|
866 st)
|
adamc@815
|
867 end
|
adamc@590
|
868
|
adamc@970
|
869 | EWrite _ => unsupported "EWrite"
|
adamc@589
|
870 | EClosure _ => unsupported "EClosure"
|
adamc@589
|
871 | EQuery _ => unsupported "Query"
|
adamc@589
|
872 | EDml _ => unsupported "DML"
|
adamc@589
|
873 | ENextval _ => unsupported "Nextval"
|
adamc@1073
|
874 | ESetval _ => unsupported "Nextval"
|
adamc@1112
|
875 | EReturnBlob _ => unsupported "EReturnBlob"
|
adam@1385
|
876
|
adam@1385
|
877 | ERedirect (e, _) =>
|
adam@1385
|
878 let
|
adam@1385
|
879 val (e, st) = jsE inner (e, st)
|
adam@1385
|
880 in
|
adam@1385
|
881 (strcat [str "{c:\"f\",f:\"redirect\",a:cons(",
|
adam@1385
|
882 e,
|
adam@1385
|
883 str ",null)}"],
|
adam@1385
|
884 st)
|
adam@1385
|
885 end
|
adam@1385
|
886
|
adamc@1112
|
887 | EUnurlify (_, _, true) => unsupported "EUnurlify"
|
adamc@590
|
888
|
adamc@1112
|
889 | EUnurlify (e, t, false) =>
|
adamc@1111
|
890 let
|
adamc@1111
|
891 val (e, st) = jsE inner (e, st)
|
adamc@1111
|
892 val (e', st) = unurlifyExp loc (t, st)
|
adamc@1111
|
893 in
|
adamc@1111
|
894 (strcat [str ("{c:\"f\",f:\"unurlify\",a:cons({c:\"c\",v:function(s){var t=s.split(\"/\");var i=0;return "
|
adamc@1111
|
895 ^ e' ^ "}},cons("),
|
adamc@1111
|
896 e,
|
adamc@1111
|
897 str ",null))}"],
|
adamc@1111
|
898 st)
|
adamc@1111
|
899 end
|
adamc@1111
|
900
|
adamc@589
|
901 | ESignalReturn e =>
|
adamc@572
|
902 let
|
adamc@572
|
903 val (e, st) = jsE inner (e, st)
|
adamc@572
|
904 in
|
adamc@1057
|
905 (strcat [str "{c:\"f\",f:\"sr\",a:cons(",
|
adamc@589
|
906 e,
|
adamc@970
|
907 str ",null)}"],
|
adamc@589
|
908 st)
|
adamc@589
|
909 end
|
adamc@589
|
910 | ESignalBind (e1, e2) =>
|
adamc@589
|
911 let
|
adamc@589
|
912 val (e1, st) = jsE inner (e1, st)
|
adamc@589
|
913 val (e2, st) = jsE inner (e2, st)
|
adamc@589
|
914 in
|
adamc@1057
|
915 (strcat [str "{c:\"f\",f:\"sb\",a:cons(",
|
adamc@589
|
916 e1,
|
adamc@976
|
917 str ",cons(",
|
adamc@589
|
918 e2,
|
adamc@976
|
919 str ",null))}"],
|
adamc@589
|
920 st)
|
adamc@589
|
921 end
|
adamc@589
|
922 | ESignalSource e =>
|
adamc@589
|
923 let
|
adamc@589
|
924 val (e, st) = jsE inner (e, st)
|
adamc@589
|
925 in
|
adamc@1057
|
926 (strcat [str "{c:\"f\",f:\"ss\",a:cons(",
|
adamc@589
|
927 e,
|
adamc@970
|
928 str ",null)}"],
|
adamc@589
|
929 st)
|
adamc@572
|
930 end
|
adamc@608
|
931
|
adamc@1020
|
932 | EServerCall (e, t, eff) =>
|
adamc@609
|
933 let
|
adamc@614
|
934 val (e, st) = jsE inner (e, st)
|
adamc@613
|
935 val (unurl, st) = unurlifyExp loc (t, st)
|
adamc@609
|
936 in
|
adamc@1057
|
937 (strcat [str ("{c:\"f\",f:\"rc\",a:cons({c:\"c\",v:\""
|
adamc@970
|
938 ^ Settings.getUrlPrefix ()
|
adamc@970
|
939 ^ "\"},cons("),
|
adamc@614
|
940 e,
|
adamc@970
|
941 str (",cons({c:\"c\",v:function(s){var t=s.split(\"/\");var i=0;return "
|
adamc@1020
|
942 ^ unurl ^ "}},cons({c:\"K\"},cons({c:\"c\",v:"
|
adamc@736
|
943 ^ (case eff of
|
adamc@736
|
944 ReadCookieWrite => "true"
|
adamc@736
|
945 | _ => "false")
|
adamc@978
|
946 ^ "},null)))))}")],
|
adamc@609
|
947 st)
|
adamc@609
|
948 end
|
adamc@670
|
949
|
adamc@1021
|
950 | ERecv (e, t) =>
|
adamc@670
|
951 let
|
adamc@670
|
952 val (e, st) = jsE inner (e, st)
|
adamc@670
|
953 val (unurl, st) = unurlifyExp loc (t, st)
|
adamc@670
|
954 in
|
adamc@1057
|
955 (strcat [str ("{c:\"f\",f:\"rv\",a:cons("),
|
adamc@670
|
956 e,
|
adamc@970
|
957 str (",cons({c:\"c\",v:function(s){var t=s.split(\"/\");var i=0;return "
|
adamc@1021
|
958 ^ unurl ^ "}},cons({c:\"K\"},null)))}")],
|
adamc@670
|
959 st)
|
adamc@670
|
960 end
|
adamc@695
|
961
|
adamc@1021
|
962 | ESleep e =>
|
adamc@695
|
963 let
|
adamc@695
|
964 val (e, st) = jsE inner (e, st)
|
adamc@695
|
965 in
|
adamc@1057
|
966 (strcat [str "{c:\"f\",f:\"sl\",a:cons(",
|
adamc@978
|
967 e,
|
adamc@1021
|
968 str ",cons({c:\"K\"},null))}"],
|
adamc@1021
|
969 st)
|
adamc@1021
|
970 end
|
adamc@1021
|
971
|
adamc@1021
|
972 | ESpawn e =>
|
adamc@1021
|
973 let
|
adamc@1021
|
974 val (e, st) = jsE inner (e, st)
|
adamc@1021
|
975 in
|
adamc@1057
|
976 (strcat [str "{c:\"f\",f:\"sp\",a:cons(",
|
adamc@1021
|
977 e,
|
adamc@1021
|
978 str ",null)}"],
|
adamc@695
|
979 st)
|
adamc@695
|
980 end
|
adamc@567
|
981 end
|
adamc@589
|
982 in
|
adamc@970
|
983 jsE 0
|
adamc@589
|
984 end
|
adamc@567
|
985
|
adamc@815
|
986 fun patBinds ((p, _), env) =
|
adamc@815
|
987 case p of
|
adamc@815
|
988 PWild => env
|
adamc@815
|
989 | PVar (_, t) => t :: env
|
adamc@815
|
990 | PPrim _ => env
|
adamc@815
|
991 | PCon (_, _, NONE) => env
|
adamc@815
|
992 | PCon (_, _, SOME p) => patBinds (p, env)
|
adamc@815
|
993 | PRecord xpts => foldl (fn ((_, p, _), env) => patBinds (p, env)) env xpts
|
adamc@815
|
994 | PNone _ => env
|
adamc@815
|
995 | PSome (_, p) => patBinds (p, env)
|
adamc@815
|
996
|
adamc@815
|
997 fun exp outer (e as (_, loc), st) =
|
adamc@815
|
998 ((*Print.preface ("exp", MonoPrint.p_exp MonoEnv.empty e);*)
|
adamc@815
|
999 case #1 e of
|
adamc@847
|
1000 EPrim p =>
|
adamc@847
|
1001 (case p of
|
adamc@847
|
1002 Prim.String s => if inString {needle = "<script", haystack = s} then
|
adamc@847
|
1003 foundJavaScript := true
|
adamc@847
|
1004 else
|
adamc@847
|
1005 ()
|
adamc@847
|
1006 | _ => ();
|
adamc@847
|
1007 (e, st))
|
adamc@815
|
1008 | ERel _ => (e, st)
|
adamc@815
|
1009 | ENamed _ => (e, st)
|
adamc@815
|
1010 | ECon (_, _, NONE) => (e, st)
|
adamc@815
|
1011 | ECon (dk, pc, SOME e) =>
|
adamc@815
|
1012 let
|
adamc@815
|
1013 val (e, st) = exp outer (e, st)
|
adamc@815
|
1014 in
|
adamc@815
|
1015 ((ECon (dk, pc, SOME e), loc), st)
|
adamc@815
|
1016 end
|
adamc@815
|
1017 | ENone _ => (e, st)
|
adamc@815
|
1018 | ESome (t, e) =>
|
adamc@815
|
1019 let
|
adamc@815
|
1020 val (e, st) = exp outer (e, st)
|
adamc@815
|
1021 in
|
adamc@815
|
1022 ((ESome (t, e), loc), st)
|
adamc@815
|
1023 end
|
adamc@815
|
1024 | EFfi _ => (e, st)
|
adamc@815
|
1025 | EFfiApp (m, x, es) =>
|
adamc@815
|
1026 let
|
adam@1663
|
1027 val (es, st) = ListUtil.foldlMap (fn ((e, t), st) =>
|
adam@1663
|
1028 let
|
adam@1663
|
1029 val (e, st) = exp outer (e, st)
|
adam@1663
|
1030 in
|
adam@1663
|
1031 ((e, t), st)
|
adam@1663
|
1032 end) st es
|
adamc@815
|
1033 in
|
adamc@815
|
1034 ((EFfiApp (m, x, es), loc), st)
|
adamc@815
|
1035 end
|
adamc@815
|
1036 | EApp (e1, e2) =>
|
adamc@815
|
1037 let
|
adamc@815
|
1038 val (e1, st) = exp outer (e1, st)
|
adamc@815
|
1039 val (e2, st) = exp outer (e2, st)
|
adamc@815
|
1040 in
|
adamc@815
|
1041 ((EApp (e1, e2), loc), st)
|
adamc@815
|
1042 end
|
adamc@815
|
1043 | EAbs (x, dom, ran, e) =>
|
adamc@815
|
1044 let
|
adamc@815
|
1045 val (e, st) = exp (dom :: outer) (e, st)
|
adamc@815
|
1046 in
|
adamc@815
|
1047 ((EAbs (x, dom, ran, e), loc), st)
|
adamc@815
|
1048 end
|
adamc@815
|
1049
|
adamc@815
|
1050 | EUnop (s, e) =>
|
adamc@815
|
1051 let
|
adamc@815
|
1052 val (e, st) = exp outer (e, st)
|
adamc@815
|
1053 in
|
adamc@815
|
1054 ((EUnop (s, e), loc), st)
|
adamc@815
|
1055 end
|
adam@1360
|
1056 | EBinop (bi, s, e1, e2) =>
|
adamc@815
|
1057 let
|
adamc@815
|
1058 val (e1, st) = exp outer (e1, st)
|
adamc@815
|
1059 val (e2, st) = exp outer (e2, st)
|
adamc@815
|
1060 in
|
adam@1360
|
1061 ((EBinop (bi, s, e1, e2), loc), st)
|
adamc@815
|
1062 end
|
adamc@815
|
1063
|
adamc@815
|
1064 | ERecord xets =>
|
adamc@815
|
1065 let
|
adamc@815
|
1066 val (xets, st) = ListUtil.foldlMap (fn ((x, e, t), st) =>
|
adamc@815
|
1067 let
|
adamc@815
|
1068 val (e, st) = exp outer (e, st)
|
adamc@815
|
1069 in
|
adamc@815
|
1070 ((x, e, t), st)
|
adamc@815
|
1071 end) st xets
|
adamc@815
|
1072 in
|
adamc@815
|
1073 ((ERecord xets, loc), st)
|
adamc@815
|
1074 end
|
adamc@815
|
1075 | EField (e, s) =>
|
adamc@815
|
1076 let
|
adamc@815
|
1077 val (e, st) = exp outer (e, st)
|
adamc@815
|
1078 in
|
adamc@815
|
1079 ((EField (e, s), loc), st)
|
adamc@815
|
1080 end
|
adamc@815
|
1081
|
adamc@815
|
1082 | ECase (e, pes, ts) =>
|
adamc@815
|
1083 let
|
adamc@815
|
1084 val (e, st) = exp outer (e, st)
|
adamc@815
|
1085 val (pes, st) = ListUtil.foldlMap (fn ((p, e), st) =>
|
adamc@815
|
1086 let
|
adamc@815
|
1087 val (e, st) = exp (patBinds (p, outer)) (e, st)
|
adamc@815
|
1088 in
|
adamc@815
|
1089 ((p, e), st)
|
adamc@815
|
1090 end) st pes
|
adamc@815
|
1091 in
|
adamc@815
|
1092 ((ECase (e, pes, ts), loc), st)
|
adamc@815
|
1093 end
|
adamc@815
|
1094
|
adamc@815
|
1095 | EStrcat (e1, e2) =>
|
adamc@815
|
1096 let
|
adamc@815
|
1097 val (e1, st) = exp outer (e1, st)
|
adamc@815
|
1098 val (e2, st) = exp outer (e2, st)
|
adamc@815
|
1099 in
|
adamc@815
|
1100 ((EStrcat (e1, e2), loc), st)
|
adamc@815
|
1101 end
|
adamc@815
|
1102
|
adamc@815
|
1103 | EError (e, t) =>
|
adamc@815
|
1104 let
|
adamc@815
|
1105 val (e, st) = exp outer (e, st)
|
adamc@815
|
1106 in
|
adamc@815
|
1107 ((EError (e, t), loc), st)
|
adamc@815
|
1108 end
|
adamc@815
|
1109 | EReturnBlob {blob, mimeType, t} =>
|
adamc@815
|
1110 let
|
adamc@815
|
1111 val (blob, st) = exp outer (blob, st)
|
adamc@815
|
1112 val (mimeType, st) = exp outer (mimeType, st)
|
adamc@815
|
1113 in
|
adamc@815
|
1114 ((EReturnBlob {blob = blob, mimeType = mimeType, t = t}, loc), st)
|
adamc@815
|
1115 end
|
adamc@1065
|
1116 | ERedirect (e, t) =>
|
adamc@1065
|
1117 let
|
adamc@1065
|
1118 val (e, st) = exp outer (e, st)
|
adamc@1065
|
1119 in
|
adamc@1065
|
1120 ((ERedirect (e, t), loc), st)
|
adamc@1065
|
1121 end
|
adamc@815
|
1122
|
adamc@815
|
1123 | EWrite e =>
|
adamc@815
|
1124 let
|
adamc@815
|
1125 val (e, st) = exp outer (e, st)
|
adamc@815
|
1126 in
|
adamc@815
|
1127 ((EWrite e, loc), st)
|
adamc@815
|
1128 end
|
adamc@815
|
1129 | ESeq (e1, e2) =>
|
adamc@815
|
1130 let
|
adamc@815
|
1131 val (e1, st) = exp outer (e1, st)
|
adamc@815
|
1132 val (e2, st) = exp outer (e2, st)
|
adamc@815
|
1133 in
|
adamc@815
|
1134 ((ESeq (e1, e2), loc), st)
|
adamc@815
|
1135 end
|
adamc@815
|
1136 | ELet (x, t, e1, e2) =>
|
adamc@815
|
1137 let
|
adamc@815
|
1138 val (e1, st) = exp outer (e1, st)
|
adamc@815
|
1139 val (e2, st) = exp (t :: outer) (e2, st)
|
adamc@815
|
1140 in
|
adamc@815
|
1141 ((ELet (x, t, e1, e2), loc), st)
|
adamc@815
|
1142 end
|
adamc@815
|
1143
|
adamc@815
|
1144 | EClosure (n, es) =>
|
adamc@815
|
1145 let
|
adamc@815
|
1146 val (es, st) = ListUtil.foldlMap (exp outer) st es
|
adamc@815
|
1147 in
|
adamc@815
|
1148 ((EClosure (n, es), loc), st)
|
adamc@815
|
1149 end
|
adamc@815
|
1150
|
adamc@815
|
1151 | EQuery {exps, tables, state, query, body, initial} =>
|
adamc@815
|
1152 let
|
adamc@934
|
1153 val row = exps @ map (fn (x, xts) => (x, (TRecord xts, loc))) tables
|
adamc@934
|
1154 val row = ListMergeSort.sort (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) row
|
adamc@934
|
1155 val row = (TRecord row, loc)
|
adamc@934
|
1156
|
adamc@815
|
1157 val (query, st) = exp outer (query, st)
|
adamc@934
|
1158 val (body, st) = exp (state :: row :: outer) (body, st)
|
adamc@815
|
1159 val (initial, st) = exp outer (initial, st)
|
adamc@815
|
1160 in
|
adamc@815
|
1161 ((EQuery {exps = exps, tables = tables, state = state,
|
adamc@815
|
1162 query = query, body = body, initial = initial}, loc), st)
|
adamc@815
|
1163 end
|
adam@1293
|
1164 | EDml (e, mode) =>
|
adamc@815
|
1165 let
|
adamc@815
|
1166 val (e, st) = exp outer (e, st)
|
adamc@815
|
1167 in
|
adam@1293
|
1168 ((EDml (e, mode), loc), st)
|
adamc@815
|
1169 end
|
adamc@815
|
1170 | ENextval e =>
|
adamc@815
|
1171 let
|
adamc@815
|
1172 val (e, st) = exp outer (e, st)
|
adamc@815
|
1173 in
|
adamc@815
|
1174 ((ENextval e, loc), st)
|
adamc@815
|
1175 end
|
adamc@1073
|
1176 | ESetval (e1, e2) =>
|
adamc@1073
|
1177 let
|
adamc@1073
|
1178 val (e1, st) = exp outer (e1, st)
|
adamc@1073
|
1179 val (e2, st) = exp outer (e2, st)
|
adamc@1073
|
1180 in
|
adamc@1073
|
1181 ((ESetval (e1, e2), loc), st)
|
adamc@1073
|
1182 end
|
adamc@815
|
1183
|
adamc@1112
|
1184 | EUnurlify (e, t, b) =>
|
adamc@815
|
1185 let
|
adamc@815
|
1186 val (e, st) = exp outer (e, st)
|
adamc@815
|
1187 in
|
adamc@1112
|
1188 ((EUnurlify (e, t, b), loc), st)
|
adamc@815
|
1189 end
|
adamc@815
|
1190
|
adam@1422
|
1191 | EJavaScript (m as Source t, e') =>
|
adam@1422
|
1192 (foundJavaScript := true;
|
adam@1422
|
1193 let
|
adam@1422
|
1194 val (x', st) = jsExp m (t :: outer) ((ERel 0, loc), st)
|
adam@1422
|
1195 in
|
adam@1422
|
1196 ((ELet ("x", t, e', x'), loc), st)
|
adam@1422
|
1197 end
|
adam@1445
|
1198 handle CantEmbed _ =>
|
adam@1445
|
1199 (jsExp m outer (e', st)
|
adam@1445
|
1200 handle CantEmbed t => ((*ErrorMsg.errorAt loc "Unable to embed type in JavaScript";
|
adam@1445
|
1201 Print.preface ("Type",
|
adam@1445
|
1202 MonoPrint.p_typ MonoEnv.empty t);*)
|
adam@1445
|
1203 (e, st))))
|
adam@1422
|
1204
|
adamc@815
|
1205 | EJavaScript (m, e') =>
|
adamc@970
|
1206 (foundJavaScript := true;
|
adamc@970
|
1207 jsExp m outer (e', st)
|
adamc@1258
|
1208 handle CantEmbed t => ((*ErrorMsg.errorAt loc "Unable to embed type in JavaScript";
|
adamc@1258
|
1209 Print.preface ("Type",
|
adamc@1258
|
1210 MonoPrint.p_typ MonoEnv.empty t);*)
|
adamc@1176
|
1211 (e, st)))
|
adamc@815
|
1212
|
adamc@815
|
1213 | ESignalReturn e =>
|
adamc@815
|
1214 let
|
adamc@815
|
1215 val (e, st) = exp outer (e, st)
|
adamc@815
|
1216 in
|
adamc@815
|
1217 ((ESignalReturn e, loc), st)
|
adamc@815
|
1218 end
|
adamc@815
|
1219 | ESignalBind (e1, e2) =>
|
adamc@815
|
1220 let
|
adamc@815
|
1221 val (e1, st) = exp outer (e1, st)
|
adamc@815
|
1222 val (e2, st) = exp outer (e2, st)
|
adamc@815
|
1223 in
|
adamc@815
|
1224 ((ESignalBind (e1, e2), loc), st)
|
adamc@815
|
1225 end
|
adamc@815
|
1226 | ESignalSource e =>
|
adamc@815
|
1227 let
|
adamc@815
|
1228 val (e, st) = exp outer (e, st)
|
adamc@815
|
1229 in
|
adamc@815
|
1230 ((ESignalSource e, loc), st)
|
adamc@815
|
1231 end
|
adamc@815
|
1232
|
adamc@1020
|
1233 | EServerCall (e1, t, ef) =>
|
adamc@815
|
1234 let
|
adamc@815
|
1235 val (e1, st) = exp outer (e1, st)
|
adamc@815
|
1236 in
|
adamc@1020
|
1237 ((EServerCall (e1, t, ef), loc), st)
|
adamc@815
|
1238 end
|
adamc@1021
|
1239 | ERecv (e1, t) =>
|
adamc@815
|
1240 let
|
adamc@815
|
1241 val (e1, st) = exp outer (e1, st)
|
adamc@815
|
1242 in
|
adamc@1021
|
1243 ((ERecv (e1, t), loc), st)
|
adamc@815
|
1244 end
|
adamc@1021
|
1245 | ESleep e1 =>
|
adamc@815
|
1246 let
|
adamc@815
|
1247 val (e1, st) = exp outer (e1, st)
|
adamc@815
|
1248 in
|
adamc@1021
|
1249 ((ESleep e1, loc), st)
|
adamc@1021
|
1250 end
|
adamc@1021
|
1251 | ESpawn e1 =>
|
adamc@1021
|
1252 let
|
adamc@1021
|
1253 val (e1, st) = exp outer (e1, st)
|
adamc@1021
|
1254 in
|
adamc@1021
|
1255 ((ESpawn e1, loc), st)
|
adamc@815
|
1256 end)
|
adamc@815
|
1257
|
adamc@815
|
1258 fun decl (d as (_, loc), st) =
|
adamc@815
|
1259 case #1 d of
|
adamc@815
|
1260 DVal (x, n, t, e, s) =>
|
adamc@815
|
1261 let
|
adamc@815
|
1262 val (e, st) = exp [] (e, st)
|
adamc@815
|
1263 in
|
adamc@815
|
1264 ((DVal (x, n, t, e, s), loc), st)
|
adamc@815
|
1265 end
|
adamc@815
|
1266 | DValRec vis =>
|
adamc@815
|
1267 let
|
adamc@815
|
1268 val (vis, st) = ListUtil.foldlMap (fn ((x, n, t, e, s), st) =>
|
adamc@815
|
1269 let
|
adamc@815
|
1270 val (e, st) = exp [] (e, st)
|
adamc@815
|
1271 in
|
adamc@815
|
1272 ((x, n, t, e, s), st)
|
adamc@815
|
1273 end) st vis
|
adamc@815
|
1274 in
|
adamc@815
|
1275 ((DValRec vis, loc), st)
|
adamc@815
|
1276 end
|
adamc@815
|
1277 | _ => (d, st)
|
adamc@567
|
1278
|
adamc@567
|
1279 fun doDecl (d, st) =
|
adamc@567
|
1280 let
|
adamc@815
|
1281 (*val () = Print.preface ("doDecl", MonoPrint.p_decl MonoEnv.empty d)*)
|
adamc@815
|
1282 val (d, st) = decl (d, st)
|
adamc@840
|
1283
|
adamc@840
|
1284 val ds =
|
adamc@840
|
1285 case #decls st of
|
adamc@840
|
1286 [] => [d]
|
adamc@840
|
1287 | vis => [(DValRec vis, #2 d), d]
|
adamc@567
|
1288 in
|
adamc@840
|
1289 (ds,
|
adamc@567
|
1290 {decls = [],
|
adamc@589
|
1291 script = #script st,
|
adamc@595
|
1292 included = #included st,
|
adamc@595
|
1293 injectors = #injectors st,
|
adamc@800
|
1294 listInjectors = #listInjectors st,
|
adamc@638
|
1295 decoders = #decoders st,
|
adamc@595
|
1296 maxName = #maxName st})
|
adamc@567
|
1297 end
|
adamc@567
|
1298
|
adamc@567
|
1299 val (ds, st) = ListUtil.foldlMapConcat doDecl
|
adamc@567
|
1300 {decls = [],
|
adamc@589
|
1301 script = [],
|
adamc@595
|
1302 included = IS.empty,
|
adamc@595
|
1303 injectors = IM.empty,
|
adamc@800
|
1304 listInjectors = TM.empty,
|
adamc@638
|
1305 decoders = IM.empty,
|
adamc@595
|
1306 maxName = U.File.maxName file + 1}
|
adamc@815
|
1307 file
|
adamc@569
|
1308
|
adamc@569
|
1309 val inf = TextIO.openIn (OS.Path.joinDirFile {dir = Config.libJs, file = "urweb.js"})
|
adamc@569
|
1310 fun lines acc =
|
adamc@569
|
1311 case TextIO.inputLine inf of
|
adamc@569
|
1312 NONE => String.concat (rev acc)
|
adamc@569
|
1313 | SOME line => lines (line :: acc)
|
adamc@569
|
1314 val lines = lines []
|
adamc@794
|
1315
|
adamc@1323
|
1316 val urlRules = foldr (fn (r, s) =>
|
adamc@1323
|
1317 "cons({allow:"
|
adamc@1323
|
1318 ^ (if #action r = Settings.Allow then "true" else "false")
|
adamc@1323
|
1319 ^ ",prefix:"
|
adamc@1323
|
1320 ^ (if #kind r = Settings.Prefix then "true" else "false")
|
adamc@1323
|
1321 ^ ",pattern:\""
|
adamc@1323
|
1322 ^ #pattern r
|
adamc@1323
|
1323 ^ "\"},"
|
adamc@1323
|
1324 ^ s
|
adamc@1323
|
1325 ^ ")") "null" (Settings.getUrlRules ())
|
adamc@1323
|
1326
|
adamc@1323
|
1327 val urlRules = "urlRules = " ^ urlRules ^ ";\n\n"
|
adamc@1323
|
1328
|
adamc@794
|
1329 val script =
|
adamc@794
|
1330 if !foundJavaScript then
|
adamc@1323
|
1331 lines ^ urlRules ^ String.concat (rev (#script st))
|
adam@1656
|
1332 ^ "\ntime_format = \"" ^ Prim.toCString (Settings.getTimeFormat ()) ^ "\";\n"
|
adamc@794
|
1333 else
|
adamc@794
|
1334 ""
|
adamc@567
|
1335 in
|
adamc@569
|
1336 TextIO.closeIn inf;
|
adamc@794
|
1337 (DJavaScript script, ErrorMsg.dummySpan) :: ds
|
adamc@567
|
1338 end
|
adamc@567
|
1339
|
adamc@567
|
1340 end
|