Chars and more string operations

9 files changed, 123 insertions, 4 deletions

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]+;
 <COMMENT> "*)"        => (if exitComment () then YYBEGIN INITIAL else ();
 			  continue ());
 
+<INITIAL> "#\""       => (YYBEGIN CHAR; strEnder := #"\""; strStart := pos yypos; str := []; continue());
+<CHAR> "\\\""         => (str := #"\"" :: !str; continue());
+<CHAR> "\\'"          => (str := #"'" :: !str; continue());
+<CHAR> "\n"           => (newline yypos;
+			  str := #"\n" :: !str; continue());
+<CHAR> .              => (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);
+
 <INITIAL> "\""        => (YYBEGIN STRING; strEnder := #"\""; strStart := pos yypos; str := []; continue());
 <INITIAL> "'"         => (YYBEGIN STRING; strEnder := #"'"; strStart := pos yypos; str := []; continue());
 <STRING> "\\\""       => (str := #"\"" :: !str; continue());