Mercurial > urweb
changeset 596:d1ec54288b1a
Injected a polymorphic, recursive type
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Thu, 08 Jan 2009 10:15:45 -0500 |
| parents | 02c8ab9f3e8b |
| children | d49d58a69877 |
| files | src/jscomp.sml tests/jsinj.ur |
| diffstat | 2 files changed, 77 insertions(+), 8 deletions(-) [+] |
line wrap: on
line diff
--- a/src/jscomp.sml Thu Jan 08 09:57:45 2009 -0500 +++ b/src/jscomp.sml Thu Jan 08 10:15:45 2009 -0500 @@ -149,13 +149,20 @@ 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 + val (someTs, nameds) = + foldl (fn ((DVal (_, n, t, e, _), _), (someTs, nameds)) => (someTs, IM.insert (nameds, n, e)) + | ((DValRec vis, _), (someTs, nameds)) => + (someTs, foldl (fn ((_, n, _, e, _), nameds) => IM.insert (nameds, n, e)) + nameds vis) + | ((DDatatype (_, _, cs), _), state as (someTs, nameds)) => + if ElabUtil.classifyDatatype cs = Option then + (foldl (fn ((_, n, SOME t), someTs) => IM.insert (someTs, n, t) + | (_, someTs) => someTs) someTs cs, + nameds) + else + state | (_, state) => state) - IM.empty file + (IM.empty, IM.empty) file fun str loc s = (EPrim (Prim.String s), loc) @@ -250,14 +257,24 @@ val (pes, st) = ListUtil.foldlMap (fn ((_, cn, NONE), st) => (((PCon (dk, PConVar cn, NONE), loc), - str loc (Int.toString cn)), + case dk of + Option => str loc "null" + | _ => 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), + case dk of + Option => + if isNullable t then + strcat loc [str loc "{_v:", + e, + str loc "}"] + else + e + | _ => e), st) end) st cs @@ -350,6 +367,26 @@ str ":", succ, str ")"] + | PCon (Option, _, NONE) => + strcat [str ("(d" ^ Int.toString depth ^ "?"), + fail, + str ":", + succ, + str ")"] + | PCon (Option, PConVar n, SOME p) => + (case IM.find (someTs, n) of + NONE => raise Fail "Jscomp: Not in someTs" + | SOME t => + strcat [str ("(d" ^ Int.toString depth ^ "?(" + ^ (if isNullable t then + "d" ^ Int.toString depth ^ "=d" + ^ Int.toString depth ^ ".v," + else + "")), + jsPat depth inner p succ fail, + str "):", + fail, + str ")"]) | PCon (_, pc, NONE) => strcat [str ("(d" ^ Int.toString depth ^ "=="), patCon pc, @@ -448,6 +485,22 @@ (str ("_n" ^ Int.toString n), st) end + | ECon (Option, _, NONE) => (str "null", st) + | ECon (Option, PConVar n, SOME e) => + let + val (e, st) = jsE inner (e, st) + in + case IM.find (someTs, n) of + NONE => raise Fail "Jscomp: Not in someTs [2]" + | SOME t => + (if isNullable t then + strcat [str "{v:", + e, + str "}"] + else + e, st) + end + | ECon (_, pc, NONE) => (patCon pc, st) | ECon (_, pc, SOME e) => let @@ -459,6 +512,7 @@ s, str "}"], st) end + | ENone _ => (str "null", st) | ESome (t, e) => let
--- a/tests/jsinj.ur Thu Jan 08 09:57:45 2009 -0500 +++ b/tests/jsinj.ur Thu Jan 08 10:15:45 2009 -0500 @@ -13,6 +13,13 @@ val show_color = mkShow colorToString +datatype list a = Nil | Cons of a * list a + +fun delist ls : xbody = + case ls of + Nil => <xml>Nil</xml> + | Cons (h, t) => <xml>{cdata h} :: {delist t}</xml> + cookie int : int cookie float : float cookie string : string @@ -20,6 +27,7 @@ cookie pair : int * float cookie option : option int cookie color : color +cookie list : list string fun main () : transaction page = n <- getCookie int; @@ -50,6 +58,10 @@ c <- return (getOpt c White); sc <- source Blue; + l <- getCookie list; + l <- return (getOpt l (Cons ("A", Cons ("B", Nil)))); + sl <- source Nil; + return <xml><body> <dyn signal={n <- signal sn; return <xml>{[n]}</xml>}/> <a onclick={set sn n}>CHANGE</a><br/> @@ -73,4 +85,7 @@ <dyn signal={c <- signal sc; return <xml>{[c]}</xml>}/> <a onclick={set sc c}>CHANGE</a><br/> + + <dyn signal={l <- signal sl; return <xml>{delist l}</xml>}/> + <a onclick={set sl l}>CHANGE</a><br/> </body></xml>