changeset 590:57f476c934da

Injecting an int
author Adam Chlipala <adamc@hcoop.net>
date Thu, 01 Jan 2009 15:11:17 -0500
parents 102e81d975e3
children 8f8771f32909
files src/jscomp.sml src/mono.sml src/monoize.sml tests/jsinj.ur tests/jsinj.urp
diffstat 5 files changed, 70 insertions(+), 21 deletions(-) [+]
line wrap: on
line diff
--- a/src/jscomp.sml	Thu Jan 01 11:58:00 2009 -0500
+++ b/src/jscomp.sml	Thu Jan 01 15:11:17 2009 -0500
@@ -102,6 +102,8 @@
       | [x] => x
       | x :: es' => (EStrcat (x, strcat loc es'), loc)
 
+exception Unsupported of string * EM.span
+
 fun process file =
     let
         val nameds = foldl (fn ((DVal (_, n, t, e, _), _), nameds) => IM.insert (nameds, n, e)
@@ -111,13 +113,28 @@
                              | (_, nameds) => nameds)
                            IM.empty file
 
+        fun str loc s = (EPrim (Prim.String s), loc)
+
+        fun quoteExp loc (t : typ) e =
+            case #1 t of
+                TSource => strcat loc [str loc "s",
+                                   (EFfiApp ("Basis", "htmlifyInt", [e]), loc)]
+              | TRecord [] => str loc "null"
+
+              | TFfi ("Basis", "string") => e
+              | TFfi ("Basis", "int") => (EFfiApp ("Basis", "htmlifyInt", [e]), loc)
+
+              | _ => (EM.errorAt loc "Don't know how to embed type in JavaScript";
+                      Print.prefaces "Can't embed" [("t", MonoPrint.p_typ MonoEnv.empty t)];
+                      str loc "ERROR")
+
         fun jsExp mode skip outer =
             let
                 val len = length outer
 
                 fun jsE inner (e as (_, loc), st) =
                     let
-                        fun str s = (EPrim (Prim.String s), loc)
+                        val str = str loc
 
                         fun var n = Int.toString (len + inner - n - 1)
 
@@ -134,22 +151,10 @@
                               | TRecord [] => true
                               | _ => false
 
-                        fun unsupported s =
-                            (EM.errorAt loc (s ^ " in code to be compiled to JavaScript");
-                             (str "ERROR", st))
+                        fun unsupported s = raise Unsupported (s, loc)
 
                         val strcat = strcat loc
 
-                        fun quoteExp (t : typ) e =
-                            case #1 t of
-                                TSource => strcat [str "s",
-                                                   (EFfiApp ("Basis", "htmlifyInt", [e]), loc)]
-                              | TRecord [] => str "null"
-                              | TFfi ("Basis", "string") => e
-                              | _ => (EM.errorAt loc "Don't know how to embed type in JavaScript";
-                                      Print.prefaces "Can't embed" [("t", MonoPrint.p_typ MonoEnv.empty t)];
-                                      str "ERROR")
-
                         fun jsPrim p =
                             case p of
                                 Prim.String s =>
@@ -241,7 +246,11 @@
                                 EPrim (Prim.String s) => s
                               | EStrcat (e1, e2) => deStrcat e1 ^ deStrcat e2
                               | _ => raise Fail "Jscomp: deStrcat"
+
+                        val quoteExp = quoteExp loc
                     in
+                        (*Print.prefaces "jsE" [("e", MonoPrint.p_exp MonoEnv.empty e)];*)
+
                         case #1 e of
                             EPrim p => (jsPrim p, st)
                           | ERel n =>
@@ -513,12 +522,15 @@
                                          str ")"], st)
                             end
 
+                          | EJavaScript (_, _, SOME e) => (e, st)
+
                           | EClosure _ => unsupported "EClosure"
                           | EQuery _ => unsupported "Query"
                           | EDml _ => unsupported "DML"
                           | ENextval _ => unsupported "Nextval"
                           | EUnurlify _ => unsupported "EUnurlify"
-                          | EJavaScript _ => unsupported "Nested JavaScript"
+                          | EJavaScript (_, e, _) => unsupported "Nested JavaScript"
+
                           | ESignalReturn e =>
                             let
                                 val (e, st) = jsE inner (e, st)
@@ -572,9 +584,28 @@
                                               end
                                       in
                                           case e of
-                                              EJavaScript (m, orig as (EAbs (_, t, _, e), _), _) =>
-                                              doCode m 1 (t :: env) orig e
-                                            | EJavaScript (m, e, _) => doCode m 0 env e e
+                                              EJavaScript (m as Source t, orig, _) =>
+                                              (doCode m 0 env orig orig
+                                               handle Unsupported (s, loc) =>
+                                                      let
+                                                          val e = ELet ("js", t, orig, quoteExp (#2 orig) t
+                                                                                                (ERel 0, #2 orig))
+                                                      in
+                                                          (EJavaScript (m, orig, SOME (e, #2 orig)), st)
+                                                      end)
+
+                                            | EJavaScript (m, orig as (EAbs (_, t, _, e), _), _) =>
+                                              (doCode m 1 (t :: env) orig e
+                                               handle Unsupported (s, loc) =>
+                                                      (EM.errorAt loc (s ^ " in code to be compiled to JavaScript");
+                                                       (EPrim (Prim.String "ERROR"), st)))
+                                                      
+                                            | EJavaScript (m, orig, _) =>
+                                              (doCode m 0 env orig orig
+                                               handle Unsupported (s, loc) =>
+                                                      (EM.errorAt loc (s ^ " in code to be compiled to JavaScript");
+                                                       (EPrim (Prim.String "ERROR"), st)))
+
                                             | _ => (e, st)
                                       end,
                              decl = fn (_, e, st) => (e, st),
--- a/src/mono.sml	Thu Jan 01 11:58:00 2009 -0500
+++ b/src/mono.sml	Thu Jan 01 15:11:17 2009 -0500
@@ -60,7 +60,7 @@
 datatype javascript_mode =
          Attribute
        | Script
-       | File
+       | Source of typ
 
 datatype exp' =
          EPrim of Prim.t
--- a/src/monoize.sml	Thu Jan 01 11:58:00 2009 -0500
+++ b/src/monoize.sml	Thu Jan 01 15:11:17 2009 -0500
@@ -976,7 +976,7 @@
                 ((L'.EAbs ("x", t, (L'.TFun ((L'.TRecord [], loc), (L'.TSource, loc)), loc),
                            (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TSource, loc),
                                      (L'.EFfiApp ("Basis", "new_client_source",
-                                                  [(L'.EJavaScript (L'.File, (L'.ERel 1, loc), NONE), loc)]),
+                                                  [(L'.EJavaScript (L'.Source t, (L'.ERel 1, loc), NONE), loc)]),
                                       loc)), loc)),
                   loc),
                  fm)
@@ -991,7 +991,8 @@
                                      (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc),
                                                (L'.EFfiApp ("Basis", "set_client_source",
                                                             [(L'.ERel 2, loc),
-                                                             (L'.EJavaScript (L'.File, (L'.ERel 1, loc), NONE), loc)]),
+                                                             (L'.EJavaScript (L'.Source t,
+                                                                              (L'.ERel 1, loc), NONE), loc)]),
                                                 loc)), loc)), loc)), loc),
                  fm)
             end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/jsinj.ur	Thu Jan 01 15:11:17 2009 -0500
@@ -0,0 +1,14 @@
+cookie int : int
+
+fun getOpt (t ::: Type) (o : option t) (v : t) : t =
+    case o of
+        None => v
+      | Some x => x
+
+fun main () : transaction page =
+    n <- getCookie int;
+    sn <- source (getOpt n 7);
+    return <xml><body>
+      <dyn signal={n <- signal sn; return <xml>{[n]}</xml>}/>
+      <a onclick={set sn 6}>CHANGE</a>
+    </body></xml>
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/jsinj.urp	Thu Jan 01 15:11:17 2009 -0500
@@ -0,0 +1,3 @@
+debug
+
+jsinj