diff options
| -rw-r--r-- | src/jscomp.sml | 77 | ||||
| -rw-r--r-- | 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> |