Substring functions; fix a nasty MonoReduce pattern match substitution bug

11 files changed, 116 insertions, 14 deletions

diff --git a/include/urweb.h b/include/urweb.h
index f5a4c391..8c1fa920 100644
--- a/include/urweb.h
+++ b/include/urweb.h
@@ -115,6 +115,10 @@ uw_Basis_int uw_Basis_strlen(uw_context, const char *);
 uw_Basis_char uw_Basis_strsub(uw_context, const char *, uw_Basis_int);
 uw_Basis_string uw_Basis_strsuffix(uw_context, const char *, uw_Basis_int);
 uw_Basis_string uw_Basis_strcat(uw_context, const char *, const char *);
+uw_Basis_int *uw_Basis_strindex(uw_context, const char *, uw_Basis_char);
+uw_Basis_string uw_Basis_strchr(uw_context, const char *, uw_Basis_char);
+uw_Basis_string uw_Basis_substring(uw_context, const char *, uw_Basis_int, uw_Basis_int);
+
 uw_Basis_string uw_strdup(uw_context, const char *);
 uw_Basis_string uw_maybe_strdup(uw_context, const char *);
 char *uw_memdup(uw_context, const char *, size_t);
diff --git a/lib/js/urweb.js b/lib/js/urweb.js
index db3c934c..be3d652a 100644
--- a/lib/js/urweb.js
+++ b/lib/js/urweb.js
@@ -353,6 +353,23 @@ function bs(b) { return (b ? "True" : "False") }
 function sub(s, i) { return s[i]; }
 function suf(s, i) { return s.substring(i); }
 function slen(s) { return s.length; }
+function sidx(s, ch) {
+  var r = s.indexOf(ch);
+  if (r == -1)
+    return null;
+  else
+    return r;
+}
+function schr(s, ch) {
+  var r = s.indexOf(ch);
+  if (r == -1)
+    return null;
+  else
+    return s.substring(r);
+}
+function ssub(s, start, len) {
+  return s.substring(start, start+len);
+}
 
 function pi(s) {
   var r = parseInt(s);
diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index c63c5ed4..d70ccc24 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -57,6 +57,9 @@ val strlen : string -> int
 val strcat : string -> string -> string
 val strsub : string -> int -> char
 val strsuffix : string -> int -> string
+val strchr : string -> char -> option string
+val strindex : string -> char -> option int
+val substring : string -> int -> int -> string
 
 class show
 val show : t ::: Type -> show t -> t -> string
diff --git a/lib/ur/string.ur b/lib/ur/string.ur
index 23670966..e6d5903e 100644
--- a/lib/ur/string.ur
+++ b/lib/ur/string.ur
@@ -5,3 +5,14 @@ val append = Basis.strcat
 
 val sub = Basis.strsub
 val suffix = Basis.strsuffix
+
+val index = Basis.strindex
+val atFirst = Basis.strchr
+
+fun substring s {Start = start, Len = len} = Basis.substring s start len
+
+fun split s ch =
+    case index s ch of
+        None => None
+      | Some i => Some (substring s {Start = 0, Len = i},
+                        substring s {Start = i + 1, Len = length s - i - 1})
diff --git a/lib/ur/string.urs b/lib/ur/string.urs
index ef522387..097a423f 100644
--- a/lib/ur/string.urs
+++ b/lib/ur/string.urs
@@ -6,3 +6,10 @@ val append : t -> t -> t
 
 val sub : t -> int -> char
 val suffix : t -> int -> string
+
+val index : t -> char -> option int
+val atFirst : t -> char -> option string
+
+val substring : t -> {Start : int, Len : int} -> string
+
+val split : t -> char -> option (string * string)
diff --git a/src/c/urweb.c b/src/c/urweb.c
index cffbb57c..d8b606fd 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -1811,6 +1811,21 @@ uw_Basis_int uw_Basis_strlen(uw_context ctx, uw_Basis_string s) {
   return strlen(s);
 }
 
+uw_Basis_string uw_Basis_strchr(uw_context ctx, uw_Basis_string s, uw_Basis_char ch) {
+  return strchr(s, ch);
+}
+
+uw_Basis_int *uw_Basis_strindex(uw_context ctx, uw_Basis_string s, uw_Basis_char ch) {
+  uw_Basis_string r = strchr(s, ch);
+  if (r == NULL)
+    return NULL;
+  else {
+    uw_Basis_int *nr = uw_malloc(ctx, sizeof(uw_Basis_int));
+    *nr = r - s;
+    return nr;
+  }
+}
+
 uw_Basis_string uw_Basis_strcat(uw_context ctx, uw_Basis_string s1, uw_Basis_string s2) {
   int len = uw_Basis_strlen(ctx, s1) + uw_Basis_strlen(ctx, s2) + 1;
   char *s;
@@ -1826,6 +1841,27 @@ uw_Basis_string uw_Basis_strcat(uw_context ctx, uw_Basis_string s1, uw_Basis_str
   return s;
 }
 
+uw_Basis_string uw_Basis_substring(uw_context ctx, uw_Basis_string s, uw_Basis_int start, uw_Basis_int len) {
+  size_t full_len = uw_Basis_strlen(ctx, s);
+
+  if (start < 0)
+    uw_error(ctx, FATAL, "substring: Negative start index");
+  if (len < 0)
+    uw_error(ctx, FATAL, "substring: Negative length");
+  if (start + len > full_len)
+    uw_error(ctx, FATAL, "substring: Start index plus length is too large");
+
+  if (start + len == full_len)
+    return &s[start];
+  else {
+    uw_Basis_string r = uw_malloc(ctx, len+1);
+    memcpy(r, s, len);
+    r[len] = 0;
+    return r;
+  }
+    
+}
+
 uw_Basis_string uw_strdup(uw_context ctx, uw_Basis_string s1) {
   int len = uw_Basis_strlen(ctx, s1) + 1;
   char *s;
diff --git a/src/jscomp.sml b/src/jscomp.sml
index 3edb670f..e162aa7f 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -625,16 +625,17 @@ fun process file =
                                                    str ":",
                                                    succ,
                                                    str ")"]
-                              | PSome (t, p) => strcat (str ("(d" ^ Int.toString depth ^ "?")
-                                                        :: (if isNullable t then
-                                                                [str ("d" ^ Int.toString depth
-                                                                      ^ "=d" ^ Int.toString depth ^ ".v")]
-                                                            else
-                                                                [])
-                                                        @ [jsPat depth inner p succ fail,
-                                                           str ":",
-                                                           fail,
-                                                           str ")"])
+                              | PSome (t, p) => strcat [str ("(d" ^ Int.toString depth ^ "?(d" ^ Int.toString (depth+1)
+                                                             ^ "=d" ^ Int.toString depth
+                                                             ^ (if isNullable t then
+                                                                    ".v"
+                                                                else
+                                                                    "")
+                                                             ^ ","),
+                                                        jsPat (depth+1) inner p succ fail,
+                                                        str "):",
+                                                        fail,
+                                                        str ")"]
 
                         val jsifyString = String.translate (fn #"\"" => "\\\""
                                                              | #"\\" => "\\\\"
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index 985f76a2..1ea3df36 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -85,6 +85,11 @@ fun impure (e, _) =
 
 val liftExpInExp = Monoize.liftExpInExp
 
+fun multiLift n e =
+    case n of
+        0 => e
+      | _ => multiLift (n - 1) (liftExpInExp 0 e)
+
 val subExpInExp' =
     U.Exp.mapB {typ = fn t => t,
                 exp = fn (xn, rep) => fn e =>
@@ -419,11 +424,16 @@ fun reduce file =
                                       | Maybe => push ()
                                       | Yes subs =>
                                         let
-                                            val body = foldr (fn (e, body) => subExpInExp (0, e) body) body subs
+                                            val (body, remaining) =
+                                                foldl (fn (e, (body, remaining)) =>
+                                                          (subExpInExp (0, multiLift remaining e) body, remaining - 1))
+                                                      (body, length subs - 1) subs
                                             val r = reduceExp env body
                                         in
+                                            (*Print.preface ("subs", Print.p_list (MonoPrint.p_exp env) subs);*)
                                             (*Print.prefaces "ECase"
-                                                           [("body", MonoPrint.p_exp env' body),
+                                                           [("old", MonoPrint.p_exp env body),
+                                                            ("body", MonoPrint.p_exp env body),
                                                             ("r", MonoPrint.p_exp env r)];*)
                                             #1 r
                                         end
@@ -533,7 +543,8 @@ fun reduce file =
 
                       | _ => e
             in
-                (*Print.prefaces "exp'" [("r", MonoPrint.p_exp env (r, ErrorMsg.dummySpan))];*)
+                (*Print.prefaces "exp'" [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan)),
+                                       ("r", MonoPrint.p_exp env (r, ErrorMsg.dummySpan))];*)
                 r
             end
 
diff --git a/src/settings.sml b/src/settings.sml
index fa162660..75302cb9 100644
--- a/src/settings.sml
+++ b/src/settings.sml
@@ -153,7 +153,10 @@ val jsFuncsBase = basisM [("alert", "alert"),
                           ("boolToString", "ts"),
                           ("strsub", "sub"),
                           ("strsuffix", "suf"),
-                          ("strlen", "slen")]
+                          ("strlen", "slen"),
+                          ("strindex", "sidx"),
+                          ("strchr", "schr"),
+                          ("substring", "ssub")]
 val jsFuncs = ref jsFuncsBase
 fun setJsFuncs ls = jsFuncs := foldl (fn ((k, v), m) => M.insert (m, k, v)) jsFuncsBase ls
 fun jsFunc x = M.find (!jsFuncs, x)
diff --git a/tests/substring.ur b/tests/substring.ur
new file mode 100644
index 00000000..bc7b5068
--- /dev/null
+++ b/tests/substring.ur
@@ -0,0 +1,5 @@
+fun main () : transaction page = return <xml>
+  {[case String.split "abc{" #"{" of
+        None => "!"
+      | Some (pre, post) => pre ^ post]}
+</xml>
diff --git a/tests/substring.urp b/tests/substring.urp
new file mode 100644
index 00000000..acc6288b
--- /dev/null
+++ b/tests/substring.urp
@@ -0,0 +1,4 @@
+debug
+
+$/string
+substring