Compiled an 'option' pattern-match

3 files changed, 73 insertions, 18 deletions

diff --git a/lib/js/urweb.js b/lib/js/urweb.js
index 0cafd8f8..13f93867 100644
--- a/lib/js/urweb.js
+++ b/lib/js/urweb.js
@@ -803,6 +803,39 @@ function lookup(env, n) {
   throw "Out-of-bounds Ur variable reference";
 }
 
+function execP(env, p, v) {
+  switch (p.c) {
+  case "w":
+    return env;
+  case "v":
+    return cons(v, env);
+  case "c":
+    if (v == p.v)
+      return env;
+    else
+      return false;
+  case "s":
+    if (v == null)
+      return false;
+    else
+      return execP(env, p.p, p.n ? v.v : v);
+  case "1":
+    if (v.n != p.n)
+      return false;
+    else
+      return execP(env, p.p, v.v);
+  case "r":
+    for (var fs = p.l; fs != null; fs = fs.next) {
+      env = execP(env, fs.data.p, v["_" + fs.data.n]);
+      if (env == false)
+        return false;
+    }
+    return env;
+  default:
+    throw ("Unknown Ur pattern kind" + p.c);
+  }
+}
+
 function exec0(env, e) {
   var stack = null;
 
@@ -872,16 +905,25 @@ function exec0(env, e) {
         e = fr.e2;
         stack = stack.next;
         break;
-      case "=1":
-        env = cons(v, env);
-        e = fr.e2;
-        stack = stack.next;
-        break;
       case "=":
         env = cons(v, env);
         e = fr.e2;
         stack = cons({c: "a3", env: env}, stack.next);
         break;
+      case "m":
+        var ps;
+        for (ps = fr.p; ps != null; ps = ps.next) {
+          var r = execP(env, ps.data.p, v);
+          if (r != false) {
+            stack = cons({c: "a3", env: env}, stack.next);
+            env = r;
+            e = ps.data.b;
+            break;
+          }
+        }
+        if (ps == null)
+          throw "Match failure in Ur interpretation";
+        break;
       default:
         throw ("Unknown Ur continuation kind " + fr.c);
       }
@@ -936,6 +978,10 @@ function exec0(env, e) {
       stack = cons({c: "=", e2: e.e2}, stack);
       e = e.e1;
       break;
+    case "m":
+      stack = cons({c: "m", p: e.p}, stack);
+      e = e.e;
+      break;
     case "e":
       var env0 = env;
       var e0 = e.e;
diff --git a/src/jscomp.sml b/src/jscomp.sml
index 1f5d669a..570a708c 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -463,15 +463,16 @@ fun process file =
                               | PCon (Option, PConVar n, SOME p) =>
                                 (case IM.find (someTs, n) of
                                      NONE => raise Fail "Jscomp: Not in someTs"
-                                   | SOME t => strcat [str ("{c:\"s\",n:"
-                                                            ^ (if isNullable t then
-                                                                   "true"
-                                                               else
-                                                                   "false")
-                                                            ^ ",p:"),
-                                                       jsPat p,
-                                                       str "}"])
-                              | PCon (_, pc, NONE) => strcat [str "{c:\"0\",n:",
+                                   | SOME t =>
+                                     strcat [str ("{c:\"s\",n:"
+                                                  ^ (if isNullable t then
+                                                         "true"
+                                                     else
+                                                         "false")
+                                                  ^ ",p:"),
+                                             jsPat p,
+                                             str "}"])
+                              | PCon (_, pc, NONE) => strcat [str "{c:\"c\",v:",
                                                               patCon pc,
                                                               str "}"]
                               | PCon (_, pc, SOME p) => strcat [str "{c:\"1\",n:",
@@ -560,7 +561,6 @@ fun process file =
 
                                                 val old = e
                                                 val (e, st) = jsExp mode [] (e, st)
-                                                val new = e
                                                 val e = deStrcat 0 e
                                                 
                                                 val sc = "urfuncs[" ^ Int.toString n ^ "] = " ^ e ^ ";\n"
@@ -791,7 +791,7 @@ fun process file =
                                 val (ps, st) =
                                     foldr (fn ((p, e), (ps, st)) =>
                                               let
-                                                  val (e, st) = jsE inner (e, st)
+                                                  val (e, st) = jsE (inner + E.patBindsN p) (e, st)
                                               in
                                                   (strcat [str "cons({p:",
                                                            jsPat p,
@@ -805,7 +805,7 @@ fun process file =
                                           (str "null", st) pes
                             in
                                 (strcat [str "{c:\"m\",e:",
-                                         e,
+                                         e',
                                          str ",p:",
                                          ps,
                                          str "}"], st)
diff --git a/tests/jscomp.ur b/tests/jscomp.ur
index c283ae4d..1d5e3b54 100644
--- a/tests/jscomp.ur
+++ b/tests/jscomp.ur
@@ -1,6 +1,11 @@
 fun fst [a] [b] (x : a) (y : b) = x
 fun snd [a] [b] (x : a) (y : b) = y
 
+fun fact n =
+    case n of
+        0 => 1
+      | _ => n * fact (n - 1)
+
 fun main () =
     s <- source "";
     s' <- source "";
@@ -21,7 +26,11 @@ fun main () =
       <button value="-" onclick={s <- get s; alert (show (-(readError s : int)))}/>
       <button value="+1" onclick={s <- get s; alert (show (readError s + 1))}/>
       <button value="*3" onclick={s <- get s; alert (show ((readError s) * 3))}/>
-      <button value="f" onclick={s <- get s; f <- get f; alert (show (f (readError s)))}/><br/><br/>
+      <button value="!" onclick={s <- get s; alert (show (fact (readError s)))}/>
+      <button value="f" onclick={s <- get s; f <- get f; alert (show (f (readError s)))}/>
+      <button value="+1P" onclick={s <- get s; case read s of
+                                                   None => alert "Nada!"
+                                                 | Some (n : int) => alert (show (n + 1))}/>
 
       <button value="f2" onclick={s <- get s; s' <- get s'; f2 <- get f2; alert (f2 s s')}/><br/><br/>