summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2009-05-26 12:25:06 -0400
committerGravatar Adam Chlipala <adamc@hcoop.net>2009-05-26 12:25:06 -0400
commitd8801e05ef2f81f21eb27555b626ee2e52c3365f (patch)
tree53e0b285bbcb0e28d3cbbd507da21fcc41d8995e
parent5232b7e45cf55208a0a3ea41395bb9f87d06dd21 (diff)
Chars and more string operations
-rw-r--r--include/types.h1
-rw-r--r--include/urweb.h5
-rw-r--r--lib/js/urweb.js3
-rw-r--r--lib/ur/basis.urs7
-rw-r--r--lib/ur/list.ur34
-rw-r--r--lib/ur/list.urs8
-rw-r--r--lib/ur/string.ur4
-rw-r--r--lib/ur/string.urs4
-rw-r--r--src/c/urweb.c44
-rw-r--r--src/elaborate.sml3
-rw-r--r--src/jscomp.sml1
-rw-r--r--src/monoize.sml31
-rw-r--r--src/prim.sig1
-rw-r--r--src/prim.sml11
-rw-r--r--src/settings.sml5
-rw-r--r--src/urweb.grm4
-rw-r--r--src/urweb.lex27
-rw-r--r--tests/char.ur4
-rw-r--r--tests/char.urp3
-rw-r--r--tests/char.urs1
20 files changed, 197 insertions, 4 deletions
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]+;
<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());
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 <xml/>
+ | _ => return <xml>A!</xml>
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