From d8801e05ef2f81f21eb27555b626ee2e52c3365f Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 26 May 2009 12:25:06 -0400 Subject: Chars and more string operations --- include/types.h | 1 + include/urweb.h | 5 +++++ lib/js/urweb.js | 3 +++ lib/ur/basis.urs | 7 +++++++ lib/ur/list.ur | 34 ++++++++++++++++++++++++++++++++++ lib/ur/list.urs | 8 ++++++++ lib/ur/string.ur | 4 ++++ lib/ur/string.urs | 4 ++++ src/c/urweb.c | 44 ++++++++++++++++++++++++++++++++++++++++++++ src/elaborate.sml | 3 +++ src/jscomp.sml | 1 + src/monoize.sml | 31 +++++++++++++++++++++++++++++++ src/prim.sig | 1 + src/prim.sml | 11 ++++++++++- src/settings.sml | 5 ++++- src/urweb.grm | 4 +++- src/urweb.lex | 27 ++++++++++++++++++++++++++- tests/char.ur | 4 ++++ tests/char.urp | 3 +++ tests/char.urs | 1 + 20 files changed, 197 insertions(+), 4 deletions(-) create mode 100644 lib/ur/string.ur create mode 100644 lib/ur/string.urs create mode 100644 tests/char.ur create mode 100644 tests/char.urp create mode 100644 tests/char.urs diff --git a/include/types.h b/include/types.h index 89e88b88..ca9ef152 100644 --- a/include/types.h +++ b/include/types.h @@ -6,6 +6,7 @@ typedef long long uw_Basis_int; typedef double uw_Basis_float; typedef char* uw_Basis_string; +typedef char uw_Basis_char; typedef time_t uw_Basis_time; typedef struct { size_t size; diff --git a/include/urweb.h b/include/urweb.h index 974d3c01..1b4a5558 100644 --- a/include/urweb.h +++ b/include/urweb.h @@ -111,6 +111,8 @@ uw_Basis_string uw_Basis_unurlifyString(uw_context, char **); uw_Basis_bool uw_Basis_unurlifyBool(uw_context, char **); uw_Basis_time uw_Basis_unurlifyTime(uw_context, 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_string uw_strdup(uw_context, const char *); uw_Basis_string uw_maybe_strdup(uw_context, const char *); @@ -138,16 +140,19 @@ char *uw_Basis_jsifyChannel(uw_context, uw_Basis_channel); uw_Basis_string uw_Basis_intToString(uw_context, uw_Basis_int); uw_Basis_string uw_Basis_floatToString(uw_context, uw_Basis_float); +uw_Basis_string uw_Basis_charToString(uw_context, uw_Basis_char); uw_Basis_string uw_Basis_boolToString(uw_context, uw_Basis_bool); uw_Basis_string uw_Basis_timeToString(uw_context, uw_Basis_time); uw_Basis_int *uw_Basis_stringToInt(uw_context, uw_Basis_string); uw_Basis_float *uw_Basis_stringToFloat(uw_context, uw_Basis_string); +uw_Basis_char *uw_Basis_stringToChar(uw_context, uw_Basis_string); uw_Basis_bool *uw_Basis_stringToBool(uw_context, uw_Basis_string); uw_Basis_time *uw_Basis_stringToTime(uw_context, uw_Basis_string); uw_Basis_int uw_Basis_stringToInt_error(uw_context, uw_Basis_string); uw_Basis_float uw_Basis_stringToFloat_error(uw_context, uw_Basis_string); +uw_Basis_char uw_Basis_stringToChar_error(uw_context, uw_Basis_string); uw_Basis_bool uw_Basis_stringToBool_error(uw_context, uw_Basis_string); uw_Basis_time uw_Basis_stringToTime_error(uw_context, uw_Basis_string); uw_Basis_blob uw_Basis_stringToBlob_error(uw_context, uw_Basis_string, size_t); diff --git a/lib/js/urweb.js b/lib/js/urweb.js index c031678a..2b4d2643 100644 --- a/lib/js/urweb.js +++ b/lib/js/urweb.js @@ -351,6 +351,9 @@ function eh(x) { function ts(x) { return x.toString() } function bs(b) { return (b ? "True" : "False") } +function sub(x, i) { return x[i]; } +function suf(x, i) { return x.substring(i); } + function pi(s) { var r = parseInt(s); if (r.toString() == s) diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index c5251bb8..1209d265 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -1,6 +1,7 @@ type int type float type string +type char type time type blob @@ -21,6 +22,7 @@ val ne : t ::: Type -> eq t -> t -> t -> bool val eq_int : eq int val eq_float : eq float val eq_string : eq string +val eq_char : eq char val eq_bool : eq bool val eq_time : eq time val mkEq : t ::: Type -> (t -> t -> bool) -> eq t @@ -44,6 +46,7 @@ val ge : t ::: Type -> ord t -> t -> t -> bool val ord_int : ord int val ord_float : ord float val ord_string : ord string +val ord_char : ord char val ord_bool : ord bool val ord_time : ord time @@ -51,12 +54,15 @@ val ord_time : ord time (** String operations *) val strcat : string -> string -> string +val strsub : string -> int -> char +val strsuffix : string -> int -> string class show val show : t ::: Type -> show t -> t -> string val show_int : show int val show_float : show float val show_string : show string +val show_char : show char val show_bool : show bool val show_time : show time val mkShow : t ::: Type -> (t -> string) -> show t @@ -68,6 +74,7 @@ val readError : t ::: Type -> read t -> string -> t val read_int : read int val read_float : read float val read_string : read string +val read_char : read char val read_bool : read bool val read_time : read time val mkRead : t ::: Type -> (string -> t) -> (string -> option t) -> read t diff --git a/lib/ur/list.ur b/lib/ur/list.ur index 7079f6bc..7527362d 100644 --- a/lib/ur/list.ur +++ b/lib/ur/list.ur @@ -20,6 +20,18 @@ val rev (a ::: Type) = rev' [] end +val revAppend (a ::: Type) = + let + fun ra (ls : list a) acc = + case ls of + [] => acc + | x :: ls => ra ls (x :: acc) + in + ra + end + +fun append (a ::: Type) (ls1 : t a) (ls2 : t a) = revAppend (rev ls1) ls2 + fun mp (a ::: Type) (b ::: Type) f = let fun mp' acc ls = @@ -30,6 +42,18 @@ fun mp (a ::: Type) (b ::: Type) f = mp' [] end +fun mapPartial (a ::: Type) (b ::: Type) f = + let + fun mp' acc ls = + case ls of + [] => rev acc + | x :: ls => mp' (case f x of + None => acc + | Some y => y :: acc) ls + in + mp' [] + end + fun mapX (a ::: Type) (ctx ::: {Unit}) f = let fun mapX' ls = @@ -49,3 +73,13 @@ fun mapM (m ::: (Type -> Type)) (_ : monad m) (a ::: Type) (b ::: Type) f = in mapM' [] end + +fun filter (a ::: Type) f = + let + fun fil acc ls = + case ls of + [] => rev acc + | x :: ls => fil (if f x then x :: acc else acc) ls + in + fil [] + end diff --git a/lib/ur/list.urs b/lib/ur/list.urs index d27ad997..fb3407ae 100644 --- a/lib/ur/list.urs +++ b/lib/ur/list.urs @@ -4,9 +4,17 @@ val show : a ::: Type -> show a -> show (list a) val rev : a ::: Type -> t a -> t a +val revAppend : a ::: Type -> t a -> t a -> t a + +val append : a ::: Type -> t a -> t a -> t a + val mp : a ::: Type -> b ::: Type -> (a -> b) -> t a -> t b +val mapPartial : a ::: Type -> b ::: Type -> (a -> option b) -> t a -> t b + val mapX : a ::: Type -> ctx ::: {Unit} -> (a -> xml ctx [] []) -> t a -> xml ctx [] [] val mapM : m ::: (Type -> Type) -> monad m -> a ::: Type -> b ::: Type -> (a -> m b) -> list a -> m (list b) + +val filter : a ::: Type -> (a -> bool) -> t a -> t a diff --git a/lib/ur/string.ur b/lib/ur/string.ur new file mode 100644 index 00000000..5362805b --- /dev/null +++ b/lib/ur/string.ur @@ -0,0 +1,4 @@ +type t = Basis.string + +val sub = Basis.strsub +val suffix = Basis.strsuffix diff --git a/lib/ur/string.urs b/lib/ur/string.urs new file mode 100644 index 00000000..524e002d --- /dev/null +++ b/lib/ur/string.urs @@ -0,0 +1,4 @@ +type t = string + +val sub : t -> int -> char +val suffix : t -> int -> string diff --git a/src/c/urweb.c b/src/c/urweb.c index a75ccf56..d399b3bd 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -1793,6 +1793,20 @@ uw_unit uw_Basis_htmlifyTime_w(uw_context ctx, uw_Basis_time t) { return uw_unit_v; } +uw_Basis_char uw_Basis_strsub(uw_context ctx, uw_Basis_string s, uw_Basis_int n) { + if (n >= 0 && n < strlen(s)) + return s[n]; + else + uw_error(ctx, FATAL, "Out-of-bounds strsub"); +} + +uw_Basis_string uw_Basis_strsuffix(uw_context ctx, uw_Basis_string s, uw_Basis_int n) { + if (n >= 0 && n < strlen(s)) + return &s[n]; + else + uw_error(ctx, FATAL, "Out-of-bounds strsuffix"); +} + uw_Basis_string uw_Basis_strcat(uw_context ctx, uw_Basis_string s1, uw_Basis_string s2) { int len = strlen(s1) + strlen(s2) + 1; char *s; @@ -2081,6 +2095,13 @@ uw_Basis_string uw_Basis_floatToString(uw_context ctx, uw_Basis_float n) { return r; } +uw_Basis_string uw_Basis_charToString(uw_context ctx, uw_Basis_char ch) { + char *r = uw_malloc(ctx, 2); + r[0] = ch; + r[1] = 0; + return r; +} + uw_Basis_string uw_Basis_boolToString(uw_context ctx, uw_Basis_bool b) { if (b == uw_Basis_False) return "False"; @@ -2127,6 +2148,20 @@ uw_Basis_float *uw_Basis_stringToFloat(uw_context ctx, uw_Basis_string s) { return NULL; } +uw_Basis_char *uw_Basis_stringToChar(uw_context ctx, uw_Basis_string s) { + if (s[0] == 0) { + uw_Basis_char *r = uw_malloc(ctx, 1); + r[0] = 0; + return r; + } else if (s[1] != 0) + return NULL; + else { + uw_Basis_char *r = uw_malloc(ctx, 1); + r[0] = s[0]; + return r; + } +} + uw_Basis_bool *uw_Basis_stringToBool(uw_context ctx, uw_Basis_string s) { static uw_Basis_bool true = uw_Basis_True; static uw_Basis_bool false = uw_Basis_False; @@ -2215,6 +2250,15 @@ uw_Basis_float uw_Basis_stringToFloat_error(uw_context ctx, uw_Basis_string s) { uw_error(ctx, FATAL, "Can't parse float: %s", s); } +uw_Basis_char uw_Basis_stringToChar_error(uw_context ctx, uw_Basis_string s) { + if (s[0] == 0) + return 0; + else if (s[1] != 0) + uw_error(ctx, FATAL, "Can't parse char: %s", s); + else + return s[0]; +} + uw_Basis_bool uw_Basis_stringToBool_error(uw_context ctx, uw_Basis_string s) { if (!strcasecmp(s, "T") || !strcasecmp (s, "True")) return uw_Basis_True; diff --git a/src/elaborate.sml b/src/elaborate.sml index fb376df2..49b826eb 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -140,6 +140,7 @@ val int = ref cerror val float = ref cerror val string = ref cerror + val char = ref cerror val table = ref cerror local @@ -1096,6 +1097,7 @@ P.Int _ => !int | P.Float _ => !float | P.String _ => !string + | P.Char _ => !char datatype constraint = Disjoint of D.goal @@ -3974,6 +3976,7 @@ fun elabFile basis topStr topSgn env file = val () = discoverC int "int" val () = discoverC float "float" val () = discoverC string "string" + val () = discoverC char "char" val () = discoverC table "sql_table" val (topSgn, gs) = elabSgn (env', D.empty) (L.SgnConst topSgn, ErrorMsg.dummySpan) diff --git a/src/jscomp.sml b/src/jscomp.sml index 4352693f..0e5c70de 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -541,6 +541,7 @@ fun process file = Int.fmt StringCvt.OCT (ord ch), 3)) s ^ "\"") + | Prim.Char ch => str ("'" ^ String.str ch ^ "'") | _ => str (Prim.toString p) fun jsPat depth inner (p, _) succ fail = diff --git a/src/monoize.sml b/src/monoize.sml index 19bb1a11..87c4d86c 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -762,6 +762,13 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.TFfi ("Basis", "bool"), loc), (L'.EBinop ("!strcmp", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc), fm) + | L.EFfi ("Basis", "eq_char") => + ((L'.EAbs ("x", (L'.TFfi ("Basis", "char"), loc), + (L'.TFun ((L'.TFfi ("Basis", "char"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc), + (L'.EAbs ("y", (L'.TFfi ("Basis", "char"), loc), + (L'.TFfi ("Basis", "bool"), loc), + (L'.EBinop ("==", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc), + fm) | L.EFfi ("Basis", "eq_time") => ((L'.EAbs ("x", (L'.TFfi ("Basis", "time"), loc), (L'.TFun ((L'.TFfi ("Basis", "time"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc), @@ -971,6 +978,19 @@ fun monoExp (env, st, fm) (all as (e, loc)) = boolBin "<", boolBin "<=") end + | L.EFfi ("Basis", "ord_char") => + let + fun charBin s = + (L'.EAbs ("x", (L'.TFfi ("Basis", "char"), loc), + (L'.TFun ((L'.TFfi ("Basis", "char"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc), + (L'.EAbs ("y", (L'.TFfi ("Basis", "char"), loc), + (L'.TFfi ("Basis", "bool"), loc), + (L'.EBinop (s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc) + in + ordEx ((L'.TFfi ("Basis", "char"), loc), + charBin "<", + charBin "<=") + end | L.EFfi ("Basis", "ord_time") => let fun boolBin s = @@ -1003,6 +1023,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) = in ((L'.EAbs ("s", s, s, (L'.ERel 0, loc)), loc), fm) end + | L.EFfi ("Basis", "show_char") => + ((L'.EFfi ("Basis", "charToString"), loc), fm) | L.EFfi ("Basis", "show_bool") => ((L'.EFfi ("Basis", "boolToString"), loc), fm) | L.EFfi ("Basis", "show_time") => @@ -1080,6 +1102,15 @@ fun monoExp (env, st, fm) (all as (e, loc)) = ("ReadError", (L'.EAbs ("s", s, s, (L'.ERel 0, loc)), loc), readErrType (s, loc))], loc), fm) end + | L.EFfi ("Basis", "read_char") => + let + val t = (L'.TFfi ("Basis", "char"), loc) + in + ((L'.ERecord [("Read", (L'.EFfi ("Basis", "stringToChar"), loc), readType' (t, loc)), + ("ReadError", (L'.EFfi ("Basis", "stringToChar_error"), loc), readErrType (t, loc))], + loc), + fm) + end | L.EFfi ("Basis", "read_bool") => let val t = (L'.TFfi ("Basis", "bool"), loc) diff --git a/src/prim.sig b/src/prim.sig index 54625379..fb067b3a 100644 --- a/src/prim.sig +++ b/src/prim.sig @@ -31,6 +31,7 @@ signature PRIM = sig Int of Int64.int | Float of Real64.real | String of string + | Char of char val p_t : t Print.printer val p_t_GCC : t Print.printer diff --git a/src/prim.sml b/src/prim.sml index 95df6e02..597b3fba 100644 --- a/src/prim.sml +++ b/src/prim.sml @@ -31,6 +31,7 @@ datatype t = Int of Int64.int | Float of Real64.real | String of string + | Char of char open Print.PD open Print @@ -40,6 +41,7 @@ fun p_t t = Int n => string (Int64.toString n) | Float n => string (Real64.toString n) | String s => box [string "\"", string (String.toString s), string "\""] + | Char ch => box [string "#\"", string (String.str ch), string "\""] fun int2s n = if Int64.compare (n, Int64.fromInt 0) = LESS then @@ -64,18 +66,21 @@ fun toString t = Int n => int2s' n | Float n => float2s n | String s => s + | Char ch => str ch fun p_t_GCC t = case t of Int n => string (int2s n) | Float n => string (float2s n) | String s => box [string "\"", string (String.toString s), string "\""] + | Char ch => box [string "'", string (str ch), string "'"] fun equal x = case x of (Int n1, Int n2) => n1 = n2 | (Float n1, Float n2) => Real64.== (n1, n2) | (String s1, String s2) => s1 = s2 + | (Char ch1, Char ch2) => ch1 = ch2 | _ => false @@ -87,8 +92,12 @@ fun compare (p1, p2) = | (Float n1, Float n2) => Real64.compare (n1, n2) | (Float _, _) => LESS - | (_, Float _) => GREATER + | (_, Float _) => GREATER | (String n1, String n2) => String.compare (n1, n2) + | (String _, _) => LESS + | (_, String _) => GREATER + + | (Char ch1, Char ch2) => Char.compare (ch1, ch2) end diff --git a/src/settings.sml b/src/settings.sml index 9dc6e414..4b2092d2 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -140,6 +140,7 @@ val jsFuncsBase = basisM [("alert", "alert"), ("strcat", "cat"), ("intToString", "ts"), ("floatToString", "ts"), + ("charToString", "ts"), ("onError", "onError"), ("onFail", "onFail"), ("onConnectFail", "onConnectFail"), @@ -149,7 +150,9 @@ val jsFuncsBase = basisM [("alert", "alert"), ("attrifyInt", "ts"), ("attrifyFloat", "ts"), ("attrifyBool", "bs"), - ("boolToString", "ts")] + ("boolToString", "ts"), + ("strsub", "sub"), + ("strsuffix", "suf")] 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/src/urweb.grm b/src/urweb.grm index bd834b47..bfb230a6 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -183,7 +183,7 @@ datatype attr = Class of exp | Normal of con * exp %term EOF - | STRING of string | INT of Int64.int | FLOAT of Real64.real + | STRING of string | INT of Int64.int | FLOAT of Real64.real | CHAR of char | SYMBOL of string | CSYMBOL of string | LPAREN | RPAREN | LBRACK | RBRACK | LBRACE | RBRACE | EQ | COMMA | COLON | DCOLON | TCOLON | DOT | HASH | UNDER | UNDERUNDER | BAR @@ -1080,6 +1080,7 @@ eterm : LPAREN eexp RPAREN (#1 eexp, s (LPARENleft, RPARENright)) | INT (EPrim (Prim.Int INT), s (INTleft, INTright)) | FLOAT (EPrim (Prim.Float FLOAT), s (FLOATleft, FLOATright)) | STRING (EPrim (Prim.String STRING), s (STRINGleft, STRINGright)) + | CHAR (EPrim (Prim.Char CHAR), s (CHARleft, CHARright)) | path DOT idents (let val loc = s (pathleft, identsright) @@ -1228,6 +1229,7 @@ pterm : SYMBOL (PVar SYMBOL, s (SYMBOLleft, SYMBOLright | UNDER (PWild, s (UNDERleft, UNDERright)) | INT (PPrim (Prim.Int INT), s (INTleft, INTright)) | STRING (PPrim (Prim.String STRING), s (STRINGleft, STRINGright)) + | CHAR (PPrim (Prim.Char CHAR), s (CHARleft, CHARright)) | LPAREN pat RPAREN (pat) | LBRACE RBRACE (PRecord ([], false), s (LBRACEleft, RBRACEright)) | UNIT (PRecord ([], false), s (UNITleft, UNITright)) diff --git a/src/urweb.lex b/src/urweb.lex index 46835fa2..b2f715d5 100644 --- a/src/urweb.lex +++ b/src/urweb.lex @@ -160,7 +160,7 @@ fun unescape loc s = %% %header (functor UrwebLexFn(structure Tokens : Urweb_TOKENS)); %full -%s COMMENT STRING XML XMLTAG; +%s COMMENT STRING CHAR XML XMLTAG; id = [a-z_][A-Za-z0-9_']*; cid = [A-Z][A-Za-z0-9_]*; @@ -193,6 +193,31 @@ notags = [^<{\n]+; "*)" => (if exitComment () then YYBEGIN INITIAL else (); continue ()); + "#\"" => (YYBEGIN CHAR; strEnder := #"\""; strStart := pos yypos; str := []; continue()); + "\\\"" => (str := #"\"" :: !str; continue()); + "\\'" => (str := #"'" :: !str; continue()); + "\n" => (newline yypos; + str := #"\n" :: !str; continue()); + . => (let + val ch = String.sub (yytext, 0) + in + if ch = !strEnder then + let + val s = String.implode (List.rev (!str)) + in + YYBEGIN INITIAL; + if size s = 1 then + Tokens.CHAR (String.sub (s, 0), !strStart, pos yypos + 1) + else + (ErrorMsg.errorAt' (yypos, yypos) + "Character constant is zero or multiple characters"; + continue ()) + end + else + (str := ch :: !str; + continue ()) + end); + "\"" => (YYBEGIN STRING; strEnder := #"\""; strStart := pos yypos; str := []; continue()); "'" => (YYBEGIN STRING; strEnder := #"'"; strStart := pos yypos; str := []; continue()); "\\\"" => (str := #"\"" :: !str; continue()); diff --git a/tests/char.ur b/tests/char.ur new file mode 100644 index 00000000..08621eba --- /dev/null +++ b/tests/char.ur @@ -0,0 +1,4 @@ +fun main () = + case #"A" of + #"B" => return + | _ => return A! diff --git a/tests/char.urp b/tests/char.urp new file mode 100644 index 00000000..840c4478 --- /dev/null +++ b/tests/char.urp @@ -0,0 +1,3 @@ +debug + +char diff --git a/tests/char.urs b/tests/char.urs new file mode 100644 index 00000000..6ac44e0b --- /dev/null +++ b/tests/char.urs @@ -0,0 +1 @@ +val main : unit -> transaction page -- cgit v1.2.3