summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2009-01-08 09:57:45 -0500
committerGravatar Adam Chlipala <adamc@hcoop.net>2009-01-08 09:57:45 -0500
commit21118ae45de71e6d1c144064ed09d136466d8a4f (patch)
tree5b424af0a7198fc453bb3187f0de73b7d6b3fae4
parent06334cca38dfb430071426e79c98c685b7d53a8c (diff)
Injected an enumeration
-rw-r--r--src/jscomp.sml77
-rw-r--r--tests/jsinj.ur24
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>