changeset 829:20fe00fd81da

Substring functions; fix a nasty MonoReduce pattern match substitution bug
author Adam Chlipala <adamc@hcoop.net>
date Sat, 30 May 2009 13:29:00 -0400
parents 14a6c0971d89
children d07980bf1444
files include/urweb.h lib/js/urweb.js lib/ur/basis.urs lib/ur/string.ur lib/ur/string.urs src/c/urweb.c src/jscomp.sml src/mono_reduce.sml src/settings.sml tests/substring.ur tests/substring.urp
diffstat 11 files changed, 116 insertions(+), 14 deletions(-) [+]
line wrap: on
line diff
--- a/include/urweb.h	Sat May 30 09:59:10 2009 -0400
+++ b/include/urweb.h	Sat May 30 13:29:00 2009 -0400
@@ -115,6 +115,10 @@
 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);
--- a/lib/js/urweb.js	Sat May 30 09:59:10 2009 -0400
+++ b/lib/js/urweb.js	Sat May 30 13:29:00 2009 -0400
@@ -353,6 +353,23 @@
 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);
--- a/lib/ur/basis.urs	Sat May 30 09:59:10 2009 -0400
+++ b/lib/ur/basis.urs	Sat May 30 13:29:00 2009 -0400
@@ -57,6 +57,9 @@
 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
--- a/lib/ur/string.ur	Sat May 30 09:59:10 2009 -0400
+++ b/lib/ur/string.ur	Sat May 30 13:29:00 2009 -0400
@@ -5,3 +5,14 @@
 
 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})
--- a/lib/ur/string.urs	Sat May 30 09:59:10 2009 -0400
+++ b/lib/ur/string.urs	Sat May 30 13:29:00 2009 -0400
@@ -6,3 +6,10 @@
 
 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)
--- a/src/c/urweb.c	Sat May 30 09:59:10 2009 -0400
+++ b/src/c/urweb.c	Sat May 30 13:29:00 2009 -0400
@@ -1811,6 +1811,21 @@
   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 @@
   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;
--- a/src/jscomp.sml	Sat May 30 09:59:10 2009 -0400
+++ b/src/jscomp.sml	Sat May 30 13:29:00 2009 -0400
@@ -625,16 +625,17 @@
                                                    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 #"\"" => "\\\""
                                                              | #"\\" => "\\\\"
--- a/src/mono_reduce.sml	Sat May 30 09:59:10 2009 -0400
+++ b/src/mono_reduce.sml	Sat May 30 13:29:00 2009 -0400
@@ -85,6 +85,11 @@
 
 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 @@
                                       | 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 @@
 
                       | _ => 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
 
--- a/src/settings.sml	Sat May 30 09:59:10 2009 -0400
+++ b/src/settings.sml	Sat May 30 13:29:00 2009 -0400
@@ -153,7 +153,10 @@
                           ("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)
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/substring.ur	Sat May 30 13:29:00 2009 -0400
@@ -0,0 +1,5 @@
+fun main () : transaction page = return <xml>
+  {[case String.split "abc{" #"{" of
+        None => "!"
+      | Some (pre, post) => pre ^ post]}
+</xml>
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/substring.urp	Sat May 30 13:29:00 2009 -0400
@@ -0,0 +1,4 @@
+debug
+
+$/string
+substring