Mercurial > urweb

comparison src/jscomp.sml @ 568:55fc747a67dc

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Initial <dyn> support
author Adam Chlipala <adamc@hcoop.net>
date Sat, 20 Dec 2008 15:46:48 -0500
parents 1901db85acb4
children 162d5308e34f
comparison
equal deleted inserted replaced
567:1901db85acb4 568:55fc747a67dc
67 | EQuery _ => 0 67 | EQuery _ => 0
68 | EDml _ => 0 68 | EDml _ => 0
69 | ENextval _ => 0 69 | ENextval _ => 0
70 | EUnurlify _ => 0 70 | EUnurlify _ => 0
71 | EJavaScript _ => 0 71 | EJavaScript _ => 0
72 72 | ESignalReturn e => varDepth e
73 fun jsExp inAttr outer = 73
74 fun strcat loc es =
75 case es of
76 [] => (EPrim (Prim.String ""), loc)
77 | [x] => x
78 | x :: es' => (EStrcat (x, strcat loc es'), loc)
79
80 fun jsExp mode outer =
74 let 81 let
75 val len = length outer 82 val len = length outer
76 83
77 fun jsE inner (e as (_, loc), st) = 84 fun jsE inner (e as (_, loc), st) =
78 let 85 let
83 fun patCon pc = 90 fun patCon pc =
84 case pc of 91 case pc of
85 PConVar n => str (Int.toString n) 92 PConVar n => str (Int.toString n)
86 | PConFfi {con, ...} => str ("\"_" ^ con ^ "\"") 93 | PConFfi {con, ...} => str ("\"_" ^ con ^ "\"")
87 94
88 fun strcat es = 95
89 case es of
90 [] => (EPrim (Prim.String ""), loc)
91 | [x] => x
92 | x :: es' => (EStrcat (x, strcat es'), loc)
93 96
94 fun isNullable (t, _) = 97 fun isNullable (t, _) =
95 case t of 98 case t of
96 TOption _ => true 99 TOption _ => true
97 | _ => false 100 | _ => false
98 101
99 fun unsupported s = 102 fun unsupported s =
100 (EM.errorAt loc (s ^ " in code to be compiled to JavaScript"); 103 (EM.errorAt loc (s ^ " in code to be compiled to JavaScript");
101 (str "ERROR", st)) 104 (str "ERROR", st))
105
106 val strcat = strcat loc
102 in 107 in
103 case #1 e of 108 case #1 e of
104 EPrim (Prim.String s) => 109 EPrim (Prim.String s) =>
105 (str ("\"" 110 (str ("\""
106 ^ String.translate (fn #"'" => 111 ^ String.translate (fn #"'" =>
107 if inAttr then 112 if mode = Attribute then
108 "\\047" 113 "\\047"
109 else 114 else
110 "'" 115 "'"
111 | #"<" => 116 | #"<" =>
112 if inAttr then 117 if mode = Script then
113 "<" 118 "<"
114 else 119 else
115 "\\074" 120 "\\074"
116 | #"\\" => "\\\\" 121 | #"\\" => "\\\\"
117 | ch => String.str ch) s 122 | ch => String.str ch) s
272 in 277 in
273 (strcat [str "alert(\"ERROR: \"+", e, str ")"], 278 (strcat [str "alert(\"ERROR: \"+", e, str ")"],
274 st) 279 st)
275 end 280 end
276 281
277 | EWrite _ => unsupported "EWrite" 282 | EWrite e =>
283 let
284 val (e, st) = jsE inner (e, st)
285 in
286 (strcat [str "document.write(",
287 e,
288 str ")"], st)
289 end
278 290
279 | ESeq (e1, e2) => 291 | ESeq (e1, e2) =>
280 let 292 let
281 val (e1, st) = jsE inner (e1, st) 293 val (e1, st) = jsE inner (e1, st)
282 val (e2, st) = jsE inner (e2, st) 294 val (e2, st) = jsE inner (e2, st)
299 | EQuery _ => unsupported "Query" 311 | EQuery _ => unsupported "Query"
300 | EDml _ => unsupported "DML" 312 | EDml _ => unsupported "DML"
301 | ENextval _ => unsupported "Nextval" 313 | ENextval _ => unsupported "Nextval"
302 | EUnurlify _ => unsupported "EUnurlify" 314 | EUnurlify _ => unsupported "EUnurlify"
303 | EJavaScript _ => unsupported "Nested JavaScript" 315 | EJavaScript _ => unsupported "Nested JavaScript"
316 | ESignalReturn e =>
317 let
318 val (e, st) = jsE inner (e, st)
319 in
320 (strcat [(*str "sreturn(",*)
321 e(*,
322 str ")"*)],
323 st)
324 end
304 end 325 end
305 in 326 in
306 jsE 327 jsE
307 end 328 end
308 329
309 val decl : state -> decl -> decl * state = 330 val decl : state -> decl -> decl * state =
310 U.Decl.foldMapB {typ = fn x => x, 331 U.Decl.foldMapB {typ = fn x => x,
311 exp = fn (env, e, st) => 332 exp = fn (env, e, st) =>
312 case e of 333 let
313 EJavaScript (EAbs (_, t, _, e), _) => 334 fun doCode m env e =
314 let 335 let
315 val (e, st) = jsExp true (t :: env) 0 (e, st) 336 val len = length env
316 in 337 fun str s = (EPrim (Prim.String s), #2 e)
317 (#1 e, st) 338
318 end 339 val locals = List.tabulate
319 | _ => (e, st), 340 (varDepth e,
341 fn i => str ("var uwr" ^ Int.toString (len + i) ^ ";"))
342 val (e, st) = jsExp m env 0 (e, st)
343 in
344 (#1 (strcat (#2 e) (locals @ [e])), st)
345 end
346 in
347 case e of
348 EJavaScript (m, (EAbs (_, t, _, e), _)) => doCode m (t :: env) e
349 | EJavaScript (m, e) => doCode m env e
350 | _ => (e, st)
351 end,
320 decl = fn (_, e, st) => (e, st), 352 decl = fn (_, e, st) => (e, st),
321 bind = fn (env, U.Decl.RelE (_, t)) => t :: env 353 bind = fn (env, U.Decl.RelE (_, t)) => t :: env
322 | (env, _) => env} 354 | (env, _) => env}
323 [] 355 []
324 356