From 21118ae45de71e6d1c144064ed09d136466d8a4f Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adamc@hcoop.net>
Date: Thu, 8 Jan 2009 09:57:45 -0500
Subject: Injected an enumeration

---
 src/jscomp.sml | 77 +++++++++++++++++++++++++++++++++++++++++++++++++---------
 tests/jsinj.ur | 24 +++++++++++++++---
 2 files changed, 87 insertions(+), 14 deletions(-)

diff --git a/src/jscomp.sml b/src/jscomp.sml
index 270dedf8..1ae14e1a 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -58,7 +58,9 @@ fun ffi k = FM.find (funcs, k)
 type state = {
      decls : decl list,
      script : string list,
-     included : IS.set
+     included : IS.set,
+     injectors : int IM.map,
+     maxName : int
 }
 
 fun varDepth (e, _) =
@@ -147,12 +149,13 @@ fun strcat loc es =
 
 fun process file =
     let
-        val nameds = foldl (fn ((DVal (_, n, t, e, _), _), nameds) => IM.insert (nameds, n, e)
-                             | ((DValRec vis, _), nameds) =>
-                               foldl (fn ((_, n, _, e, _), nameds) => IM.insert (nameds, n, e))
-                                     nameds vis
-                             | (_, nameds) => nameds)
-                           IM.empty file
+        val nameds =
+            foldl (fn ((DVal (_, n, t, e, _), _), nameds) => IM.insert (nameds, n, e)
+                    | ((DValRec vis, _), nameds) =>
+                      foldl (fn ((_, n, _, e, _), nameds) => IM.insert (nameds, n, e))
+                            nameds vis
+                    | (_, state) => state)
+                  IM.empty file
 
         fun str loc s = (EPrim (Prim.String s), loc)
 
@@ -230,6 +233,50 @@ fun process file =
                      st)
                 end
 
+              | TDatatype (n, ref (dk, cs)) =>
+                (case IM.find (#injectors st, n) of
+                     SOME n' => ((EApp ((ENamed n', loc), e), loc), st)
+                   | NONE =>
+                     let
+                         val dk = ElabUtil.classifyDatatype cs
+
+                         val n' = #maxName st
+                         val st = {decls = #decls st,
+                                   script = #script st,
+                                   included = #included st,
+                                   injectors = IM.insert (#injectors st, n, n'),
+                                   maxName = n' + 1}
+
+                         val (pes, st) = ListUtil.foldlMap
+                                             (fn ((_, cn, NONE), st) =>
+                                                 (((PCon (dk, PConVar cn, NONE), loc),
+                                                   str loc (Int.toString cn)),
+                                                  st)
+                                               | ((_, cn, SOME t), st) =>
+                                                 let
+                                                     val (e, st) = quoteExp loc t ((ERel 0, loc), st)
+                                                 in
+                                                     (((PCon (dk, PConVar cn, SOME (PVar ("x", t), loc)), loc),
+                                                       e),
+                                                      st)
+                                                 end)
+                                             st cs
+
+                         val s = (TFfi ("Basis", "string"), loc)
+                         val body = (ECase ((ERel 0, loc), pes,
+                                            {disc = t, result = s}), loc)
+                         val body = (EAbs ("x", t, s, body), loc)
+
+                         val st = {decls = (DValRec [("jsify", n', (TFun (t, s), loc),
+                                                      body, "jsify")], loc) :: #decls st,
+                                   script = #script st,
+                                   included = #included st,
+                                   injectors = #injectors st,
+                                   maxName = #maxName st}
+                     in
+                         ((EApp ((ENamed n', loc), e), loc), st)
+                     end)
+
               | _ => (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", st))
@@ -382,7 +429,9 @@ fun process file =
                                             let
                                                 val st = {decls = #decls st,
                                                           script = #script st,
-                                                          included = IS.add (#included st, n)}
+                                                          included = IS.add (#included st, n),
+                                                          injectors = #injectors st,
+                                                          maxName = #maxName st}
 
                                                 val (e, st) = jsExp mode skip [] 0 (e, st)
                                                 val e = deStrcat e
@@ -391,7 +440,9 @@ fun process file =
                                             in
                                                 {decls = #decls st,
                                                  script = sc :: #script st,
-                                                 included = #included st}
+                                                 included = #included st,
+                                                 injectors = #injectors st,
+                                                 maxName = #maxName st}
                                             end
                             in
                                 (str ("_n" ^ Int.toString n), st)
@@ -717,13 +768,17 @@ fun process file =
                 (List.revAppend (#decls st, [d]),
                  {decls = [],
                   script = #script st,
-                  included = #included st})
+                  included = #included st,
+                  injectors = #injectors st,
+                  maxName = #maxName st})
             end
 
         val (ds, st) = ListUtil.foldlMapConcat doDecl
                        {decls = [],
                         script = [],
-                        included = IS.empty}
+                        included = IS.empty,
+                        injectors = IM.empty,
+                        maxName = U.File.maxName file + 1}
                        file
 
         val inf = TextIO.openIn (OS.Path.joinDirFile {dir = Config.libJs, file = "urweb.js"})
diff --git a/tests/jsinj.ur b/tests/jsinj.ur
index 632a2839..518748d8 100644
--- a/tests/jsinj.ur
+++ b/tests/jsinj.ur
@@ -3,12 +3,23 @@ fun getOpt (t ::: Type) (o : option t) (v : t) : t =
         None => v
       | Some x => x
 
+datatype color = Red | White | Blue
+
+fun colorToString c =
+    case c of
+        Red => "R"
+      | White => "W"
+      | Blue => "B"
+
+val show_color = mkShow colorToString
+
 cookie int : int
 cookie float : float
 cookie string : string
 cookie bool : bool
 cookie pair : int * float
 cookie option : option int
+cookie color : color
 
 fun main () : transaction page =
     n <- getCookie int;
@@ -33,7 +44,11 @@ fun main () : transaction page =
 
     o <- getCookie option;
     o <- return (getOpt o (Some 1));
-    op <- source None;
+    so <- source None;
+
+    c <- getCookie color;
+    c <- return (getOpt c White);
+    sc <- source Blue;
 
     return <xml><body>
       <dyn signal={n <- signal sn; return <xml>{[n]}</xml>}/>
@@ -51,8 +66,11 @@ fun main () : transaction page =
       <dyn signal={p <- signal sp; return <xml>{[p.1]}, {[p.2]}</xml>}/>
       <a onclick={set sp p}>CHANGE</a><br/>
 
-      <dyn signal={o <- signal op; case o of
+      <dyn signal={o <- signal so; case o of
                                        None => return <xml>None</xml>
                                      | Some x => return <xml>{[x]}</xml>}/>
-      <a onclick={set op o}>CHANGE</a><br/>
+      <a onclick={set so o}>CHANGE</a><br/>
+
+      <dyn signal={c <- signal sc; return <xml>{[c]}</xml>}/>
+      <a onclick={set sc c}>CHANGE</a><br/>
     </body></xml>
-- 
cgit v1.2.3