Mercurial > urweb

comparison src/jscomp.sml @ 579:0094e0242100

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Propagated a source change into a dynamic document element
author Adam Chlipala <adamc@hcoop.net>
date Tue, 30 Dec 2008 15:53:04 -0500
parents 1e589a60b86f
children 66463006f893
comparison
equal deleted inserted replaced
578:1e589a60b86f 579:0094e0242100
33 structure E = MonoEnv 33 structure E = MonoEnv
34 structure U = MonoUtil 34 structure U = MonoUtil
35 35
36 val funcs = [(("Basis", "alert"), "alert"), 36 val funcs = [(("Basis", "alert"), "alert"),
37 (("Basis", "htmlifyString"), "escape"), 37 (("Basis", "htmlifyString"), "escape"),
38 (("Basis", "new_client_source"), "sc")] 38 (("Basis", "new_client_source"), "sc"),
39 (("Basis", "set_client_source"), "sv")]
39 40
40 structure FM = BinaryMapFn(struct 41 structure FM = BinaryMapFn(struct
41 type ord_key = string * string 42 type ord_key = string * string
42 fun compare ((m1, x1), (m2, x2)) = 43 fun compare ((m1, x1), (m2, x2)) =
43 Order.join (String.compare (m1, m2), 44 Order.join (String.compare (m1, m2),
92 case es of 93 case es of
93 [] => (EPrim (Prim.String ""), loc) 94 [] => (EPrim (Prim.String ""), loc)
94 | [x] => x 95 | [x] => x
95 | x :: es' => (EStrcat (x, strcat loc es'), loc) 96 | x :: es' => (EStrcat (x, strcat loc es'), loc)
96 97
97 fun jsExp mode outer = 98 fun jsExp mode skip outer =
98 let 99 let
99 val len = length outer 100 val len = length outer
100 101
101 fun jsE inner (e as (_, loc), st) = 102 fun jsE inner (e as (_, loc), st) =
102 let 103 let
124 125
125 fun quoteExp (t : typ) e = 126 fun quoteExp (t : typ) e =
126 case #1 t of 127 case #1 t of
127 TSource => strcat [str "s", 128 TSource => strcat [str "s",
128 (EFfiApp ("Basis", "htmlifyInt", [e]), loc)] 129 (EFfiApp ("Basis", "htmlifyInt", [e]), loc)]
130 | TRecord [] => str "null"
131 | TFfi ("Basis", "string") => e
129 | _ => (EM.errorAt loc "Don't know how to embed type in JavaScript"; 132 | _ => (EM.errorAt loc "Don't know how to embed type in JavaScript";
133 Print.prefaces "Can't embed" [("t", MonoPrint.p_typ MonoEnv.empty t)];
130 str "ERROR") 134 str "ERROR")
131 in 135 in
132 case #1 e of 136 case #1 e of
133 EPrim (Prim.String s) => 137 EPrim (Prim.String s) =>
134 (str ("\"" 138 (str ("\""
152 (str ("uwr" ^ var n), st) 156 (str ("uwr" ^ var n), st)
153 else 157 else
154 let 158 let
155 val n = n - inner 159 val n = n - inner
156 in 160 in
157 (quoteExp (List.nth (outer, n)) (ERel n, loc), st) 161 (quoteExp (List.nth (outer, n)) (ERel (n - skip), loc), st)
158 end 162 end
159 | ENamed _ => raise Fail "Named" 163 | ENamed _ => raise Fail "Named"
160 | ECon (_, pc, NONE) => (patCon pc, st) 164 | ECon (_, pc, NONE) => (patCon pc, st)
161 | ECon (_, pc, SOME e) => 165 | ECon (_, pc, SOME e) =>
162 let 166 let
401 405
402 val decl : state -> decl -> decl * state = 406 val decl : state -> decl -> decl * state =
403 U.Decl.foldMapB {typ = fn x => x, 407 U.Decl.foldMapB {typ = fn x => x,
404 exp = fn (env, e, st) => 408 exp = fn (env, e, st) =>
405 let 409 let
406 fun doCode m env orig e = 410 fun doCode m skip env orig e =
407 let 411 let
408 val len = length env 412 val len = length env
409 fun str s = (EPrim (Prim.String s), #2 e) 413 fun str s = (EPrim (Prim.String s), #2 e)
410 414
411 val locals = List.tabulate 415 val locals = List.tabulate
412 (varDepth e, 416 (varDepth e,
413 fn i => str ("var uwr" ^ Int.toString (len + i) ^ ";")) 417 fn i => str ("var uwr" ^ Int.toString (len + i) ^ ";"))
414 val (e, st) = jsExp m env 0 (e, st) 418 val (e, st) = jsExp m skip env 0 (e, st)
415 in 419 in
416 (EJavaScript (m, orig, SOME (strcat (#2 e) (locals @ [e]))), st) 420 (EJavaScript (m, orig, SOME (strcat (#2 e) (locals @ [e]))), st)
417 end 421 end
418 in 422 in
419 case e of 423 case e of
420 EJavaScript (m, orig as (EAbs (_, t, _, e), _), _) => doCode m (t :: env) orig e 424 EJavaScript (m, orig as (EAbs (_, t, _, e), _), _) => doCode m 1 (t :: env) orig e
421 | EJavaScript (m, e, _) => doCode m env e e 425 | EJavaScript (m, e, _) => doCode m 0 env e e
422 | _ => (e, st) 426 | _ => (e, st)
423 end, 427 end,
424 decl = fn (_, e, st) => (e, st), 428 decl = fn (_, e, st) => (e, st),
425 bind = fn (env, U.Decl.RelE (_, t)) => t :: env 429 bind = fn (env, U.Decl.RelE (_, t)) => t :: env
426 | (env, _) => env} 430 | (env, _) => env}