From adefca12f83d73986b0f860621232b17c130c742 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 30 May 2009 13:29:00 -0400 Subject: Substring functions; fix a nasty MonoReduce pattern match substitution bug --- include/urweb.h | 4 ++++ lib/js/urweb.js | 17 +++++++++++++++++ lib/ur/basis.urs | 3 +++ lib/ur/string.ur | 11 +++++++++++ lib/ur/string.urs | 7 +++++++ src/c/urweb.c | 36 ++++++++++++++++++++++++++++++++++++ src/jscomp.sml | 21 +++++++++++---------- src/mono_reduce.sml | 17 ++++++++++++++--- src/settings.sml | 5 ++++- tests/substring.ur | 5 +++++ tests/substring.urp | 4 ++++ 11 files changed, 116 insertions(+), 14 deletions(-) create mode 100644 tests/substring.ur create mode 100644 tests/substring.urp 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 + {[case String.split "abc{" #"{" of + None => "!" + | Some (pre, post) => pre ^ post]} + 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 -- cgit v1.2.3