Mercurial > urweb

comparison src/jscomp.sml @ 590:57f476c934da

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Injecting an int
author Adam Chlipala <adamc@hcoop.net>
date Thu, 01 Jan 2009 15:11:17 -0500
parents 102e81d975e3
children 8f8771f32909
comparison
equal deleted inserted replaced
589:102e81d975e3 590:57f476c934da
100 case es of 100 case es of
101 [] => (EPrim (Prim.String ""), loc) 101 [] => (EPrim (Prim.String ""), loc)
102 | [x] => x 102 | [x] => x
103 | x :: es' => (EStrcat (x, strcat loc es'), loc) 103 | x :: es' => (EStrcat (x, strcat loc es'), loc)
104 104
105 exception Unsupported of string * EM.span
106
105 fun process file = 107 fun process file =
106 let 108 let
107 val nameds = foldl (fn ((DVal (_, n, t, e, _), _), nameds) => IM.insert (nameds, n, e) 109 val nameds = foldl (fn ((DVal (_, n, t, e, _), _), nameds) => IM.insert (nameds, n, e)
108 | ((DValRec vis, _), nameds) => 110 | ((DValRec vis, _), nameds) =>
109 foldl (fn ((_, n, _, e, _), nameds) => IM.insert (nameds, n, e)) 111 foldl (fn ((_, n, _, e, _), nameds) => IM.insert (nameds, n, e))
110 nameds vis 112 nameds vis
111 | (_, nameds) => nameds) 113 | (_, nameds) => nameds)
112 IM.empty file 114 IM.empty file
113 115
116 fun str loc s = (EPrim (Prim.String s), loc)
117
118 fun quoteExp loc (t : typ) e =
119 case #1 t of
120 TSource => strcat loc [str loc "s",
121 (EFfiApp ("Basis", "htmlifyInt", [e]), loc)]
122 | TRecord [] => str loc "null"
123
124 | TFfi ("Basis", "string") => e
125 | TFfi ("Basis", "int") => (EFfiApp ("Basis", "htmlifyInt", [e]), loc)
126
127 | _ => (EM.errorAt loc "Don't know how to embed type in JavaScript";
128 Print.prefaces "Can't embed" [("t", MonoPrint.p_typ MonoEnv.empty t)];
129 str loc "ERROR")
130
114 fun jsExp mode skip outer = 131 fun jsExp mode skip outer =
115 let 132 let
116 val len = length outer 133 val len = length outer
117 134
118 fun jsE inner (e as (_, loc), st) = 135 fun jsE inner (e as (_, loc), st) =
119 let 136 let
120 fun str s = (EPrim (Prim.String s), loc) 137 val str = str loc
121 138
122 fun var n = Int.toString (len + inner - n - 1) 139 fun var n = Int.toString (len + inner - n - 1)
123 140
124 fun patCon pc = 141 fun patCon pc =
125 case pc of 142 case pc of
132 case t of 149 case t of
133 TOption _ => true 150 TOption _ => true
134 | TRecord [] => true 151 | TRecord [] => true
135 | _ => false 152 | _ => false
136 153
137 fun unsupported s = 154 fun unsupported s = raise Unsupported (s, loc)
138 (EM.errorAt loc (s ^ " in code to be compiled to JavaScript");
139 (str "ERROR", st))
140 155
141 val strcat = strcat loc 156 val strcat = strcat loc
142
143 fun quoteExp (t : typ) e =
144 case #1 t of
145 TSource => strcat [str "s",
146 (EFfiApp ("Basis", "htmlifyInt", [e]), loc)]
147 | TRecord [] => str "null"
148 | TFfi ("Basis", "string") => e
149 | _ => (EM.errorAt loc "Don't know how to embed type in JavaScript";
150 Print.prefaces "Can't embed" [("t", MonoPrint.p_typ MonoEnv.empty t)];
151 str "ERROR")
152 157
153 fun jsPrim p = 158 fun jsPrim p =
154 case p of 159 case p of
155 Prim.String s => 160 Prim.String s =>
156 str ("\"" 161 str ("\""
239 fun deStrcat (e, _) = 244 fun deStrcat (e, _) =
240 case e of 245 case e of
241 EPrim (Prim.String s) => s 246 EPrim (Prim.String s) => s
242 | EStrcat (e1, e2) => deStrcat e1 ^ deStrcat e2 247 | EStrcat (e1, e2) => deStrcat e1 ^ deStrcat e2
243 | _ => raise Fail "Jscomp: deStrcat" 248 | _ => raise Fail "Jscomp: deStrcat"
249
250 val quoteExp = quoteExp loc
244 in 251 in
252 (*Print.prefaces "jsE" [("e", MonoPrint.p_exp MonoEnv.empty e)];*)
253
245 case #1 e of 254 case #1 e of
246 EPrim p => (jsPrim p, st) 255 EPrim p => (jsPrim p, st)
247 | ERel n => 256 | ERel n =>
248 if n < inner then 257 if n < inner then
249 (str ("_" ^ var n), st) 258 (str ("_" ^ var n), st)
511 str ",", 520 str ",",
512 e2, 521 e2,
513 str ")"], st) 522 str ")"], st)
514 end 523 end
515 524
525 | EJavaScript (_, _, SOME e) => (e, st)
526
516 | EClosure _ => unsupported "EClosure" 527 | EClosure _ => unsupported "EClosure"
517 | EQuery _ => unsupported "Query" 528 | EQuery _ => unsupported "Query"
518 | EDml _ => unsupported "DML" 529 | EDml _ => unsupported "DML"
519 | ENextval _ => unsupported "Nextval" 530 | ENextval _ => unsupported "Nextval"
520 | EUnurlify _ => unsupported "EUnurlify" 531 | EUnurlify _ => unsupported "EUnurlify"
521 | EJavaScript _ => unsupported "Nested JavaScript" 532 | EJavaScript (_, e, _) => unsupported "Nested JavaScript"
533
522 | ESignalReturn e => 534 | ESignalReturn e =>
523 let 535 let
524 val (e, st) = jsE inner (e, st) 536 val (e, st) = jsE inner (e, st)
525 in 537 in
526 (strcat [str "sr(", 538 (strcat [str "sr(",
570 in 582 in
571 (EJavaScript (m, orig, SOME (strcat (#2 e) (locals @ [e]))), st) 583 (EJavaScript (m, orig, SOME (strcat (#2 e) (locals @ [e]))), st)
572 end 584 end
573 in 585 in
574 case e of 586 case e of
575 EJavaScript (m, orig as (EAbs (_, t, _, e), _), _) => 587 EJavaScript (m as Source t, orig, _) =>
576 doCode m 1 (t :: env) orig e 588 (doCode m 0 env orig orig
577 | EJavaScript (m, e, _) => doCode m 0 env e e 589 handle Unsupported (s, loc) =>
590 let
591 val e = ELet ("js", t, orig, quoteExp (#2 orig) t
592 (ERel 0, #2 orig))
593 in
594 (EJavaScript (m, orig, SOME (e, #2 orig)), st)
595 end)
596
597 | EJavaScript (m, orig as (EAbs (_, t, _, e), _), _) =>
598 (doCode m 1 (t :: env) orig e
599 handle Unsupported (s, loc) =>
600 (EM.errorAt loc (s ^ " in code to be compiled to JavaScript");
601 (EPrim (Prim.String "ERROR"), st)))
602
603 | EJavaScript (m, orig, _) =>
604 (doCode m 0 env orig orig
605 handle Unsupported (s, loc) =>
606 (EM.errorAt loc (s ^ " in code to be compiled to JavaScript");
607 (EPrim (Prim.String "ERROR"), st)))
608
578 | _ => (e, st) 609 | _ => (e, st)
579 end, 610 end,
580 decl = fn (_, e, st) => (e, st), 611 decl = fn (_, e, st) => (e, st),
581 bind = fn (env, U.Decl.RelE (_, t)) => t :: env 612 bind = fn (env, U.Decl.RelE (_, t)) => t :: env
582 | (env, _) => env} 613 | (env, _) => env}