summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2009-01-01 10:49:42 -0500
committerGravatar Adam Chlipala <adamc@hcoop.net>2009-01-01 10:49:42 -0500
commit914c437ab2251be982c4c19f659589360bf41a59 (patch)
tree153e0b43138171ab20f686aff9c6612f62729f4a
parentbad5b1a5635b3db83b4178c200e9a83d49ffc2d7 (diff)
Used an option as a source
-rw-r--r--jslib/urweb.js1
-rw-r--r--src/jscomp.sml104
-rw-r--r--tests/stypes.ur5
3 files changed, 92 insertions, 18 deletions
diff --git a/jslib/urweb.js b/jslib/urweb.js
index e661a739..fec37d1b 100644
--- a/jslib/urweb.js
+++ b/jslib/urweb.js
@@ -42,3 +42,4 @@ function dyn(s) {
}
function ts(x) { return x.toString() }
+function pf() { alert("Pattern match failure") }
diff --git a/src/jscomp.sml b/src/jscomp.sml
index c6299f83..91ec56a7 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -133,25 +133,64 @@ fun jsExp mode skip outer =
| _ => (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 =>
+ str ("\""
+ ^ String.translate (fn #"'" =>
+ if mode = Attribute then
+ "\\047"
+ else
+ "'"
+ | #"\"" => "\\\""
+ | #"<" =>
+ if mode = Script then
+ "<"
+ else
+ "\\074"
+ | #"\\" => "\\\\"
+ | ch => String.str ch) s
+ ^ "\"")
+ | _ => str (Prim.toString p)
+
+ fun jsPat inner (p, _) succ fail =
+ case p of
+ PWild => succ
+ | PVar _ => strcat [str ("(_" ^ Int.toString (len + inner) ^ "=d,"),
+ succ,
+ str ")"]
+ | PPrim p => strcat [str "(d==",
+ jsPrim p,
+ str "?",
+ succ,
+ str ":",
+ fail,
+ str ")"]
+ | PCon _ => raise Fail "jsPat: PCon"
+ | PRecord xps =>
+ let
+ val (_, succ) = foldl
+ (fn ((x, p, _), (inner, succ)) =>
+ (inner + E.patBindsN p,
+ jsPat inner p succ fail))
+ (inner, succ) xps
+ in
+ succ
+ end
+ | PNone _ => strcat [str "(d?",
+ fail,
+ str ":",
+ succ,
+ str ")"]
+ | PSome (_, p) => strcat [str "(d?",
+ jsPat inner p succ fail,
+ str ":",
+ fail,
+ str ")"]
in
case #1 e of
- EPrim (Prim.String s) =>
- (str ("\""
- ^ String.translate (fn #"'" =>
- if mode = Attribute then
- "\\047"
- else
- "'"
- | #"\"" => "\\\""
- | #"<" =>
- if mode = Script then
- "<"
- else
- "\\074"
- | #"\\" => "\\\\"
- | ch => String.str ch) s
- ^ "\""), st)
- | EPrim p => (str (Prim.toString p), st)
+ EPrim p => (jsPrim p, st)
| ERel n =>
if n < inner then
(str ("_" ^ var n), st)
@@ -317,7 +356,36 @@ fun jsExp mode skip outer =
str ("._" ^ x)], st)
end
- | ECase _ => raise Fail "Jscomp: ECase"
+ | ECase (e, pes, _) =>
+ let
+ val plen = length pes
+
+ val (cases, st) = ListUtil.foldliMap
+ (fn (i, (p, e), st) =>
+ let
+ val (e, st) = jsE (inner + E.patBindsN p) (e, st)
+ val fail =
+ if i = plen - 1 then
+ str "pf()"
+ else
+ str ("c" ^ Int.toString (i+1) ^ "()")
+ val c = jsPat inner p e fail
+ in
+ (strcat [str ("c" ^ Int.toString i ^ "=function(){return "),
+ c,
+ str "},"],
+ st)
+ end)
+ st pes
+
+ val (e, st) = jsE inner (e, st)
+ in
+ (strcat (str "("
+ :: List.revAppend (cases,
+ [str "d=",
+ e,
+ str ",c0())"])), st)
+ end
| EStrcat (e1, e2) =>
let
diff --git a/tests/stypes.ur b/tests/stypes.ur
index 4d918a91..1ac70834 100644
--- a/tests/stypes.ur
+++ b/tests/stypes.ur
@@ -11,4 +11,9 @@ fun main () : transaction page =
<dyn signal={n <- signal sFloat; return <xml>{[n + 1.0]}</xml>}/> <a onclick={set sFloat 4.56}>Change</a><br/>
<dyn signal={p <- signal sBoth; return <xml>{[p.1]}, {[p.2]}</xml>}/> <a onclick={set sBoth (8, 100.001)}>Change</a><br/>
+
+ <dyn signal={o <- signal sOpt; case o of
+ None => return <xml>None</xml>
+ | Some n => return <xml>{[n]}</xml>}/>
+ <a onclick={set sOpt (Some 7)}>Change</a><br/>
</body></xml>