summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--include/urweb.h2
-rw-r--r--lib/basis.urs8
-rw-r--r--src/c/urweb.c13
-rw-r--r--src/cjr.sml3
-rw-r--r--src/cjr_print.sml67
-rw-r--r--src/cjrize.sml20
-rw-r--r--src/core_print.sml36
-rw-r--r--src/corify.sml3
-rw-r--r--src/expl_print.sml36
-rw-r--r--src/mono.sml3
-rw-r--r--src/mono_env.sml2
-rw-r--r--src/mono_print.sml13
-rw-r--r--src/mono_util.sml10
-rw-r--r--src/monoize.sml5
-rw-r--r--tests/fromString.ur10
-rw-r--r--tests/fromString.urp5
16 files changed, 204 insertions, 32 deletions
diff --git a/include/urweb.h b/include/urweb.h
index 3995585e..84cc6719 100644
--- a/include/urweb.h
+++ b/include/urweb.h
@@ -77,3 +77,5 @@ char *lw_Basis_ensqlBool(lw_Basis_bool);
lw_Basis_string lw_Basis_intToString(lw_context, lw_Basis_int);
lw_Basis_string lw_Basis_floatToString(lw_context, lw_Basis_float);
lw_Basis_string lw_Basis_boolToString(lw_context, lw_Basis_bool);
+
+lw_Basis_int *lw_Basis_stringToInt(lw_context, lw_Basis_string);
diff --git a/lib/basis.urs b/lib/basis.urs
index 22a033a0..e6072690 100644
--- a/lib/basis.urs
+++ b/lib/basis.urs
@@ -6,7 +6,7 @@ type unit = {}
datatype bool = False | True
-(*datatype option t = None | Some of t*)
+datatype option t = None | Some of t
(** Basic type classes *)
@@ -23,10 +23,6 @@ val eq_bool : eq bool
val strcat : string -> string -> string
-val intToString : int -> string
-val floatToString : float -> string
-val boolToString : bool -> string
-
class show
val show : t ::: Type -> show t -> t -> string
val show_int : show int
@@ -34,6 +30,8 @@ val show_float : show float
val show_string : show string
val show_bool : show bool
+val stringToInt : string -> option int
+
(** SQL *)
diff --git a/src/c/urweb.c b/src/c/urweb.c
index 9836e502..dce33bf1 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -756,3 +756,16 @@ lw_Basis_string lw_Basis_boolToString(lw_context ctx, lw_Basis_bool b) {
else
return "True";
}
+
+
+lw_Basis_int *lw_Basis_stringToInt(lw_context ctx, lw_Basis_string s) {
+ char *endptr;
+ lw_Basis_int n = strtoll(s, &endptr, 10);
+
+ if (*s != '\0' && *endptr == '\0') {
+ lw_Basis_int *r = lw_malloc(ctx, sizeof(lw_Basis_int));
+ *r = n;
+ return r;
+ } else
+ return NULL;
+}
diff --git a/src/cjr.sml b/src/cjr.sml
index 398f94c6..d4c88246 100644
--- a/src/cjr.sml
+++ b/src/cjr.sml
@@ -36,6 +36,7 @@ datatype typ' =
| TRecord of int
| TDatatype of datatype_kind * int * (string * int * typ option) list ref
| TFfi of string * string
+ | TOption of typ
withtype typ = typ' located
@@ -49,6 +50,8 @@ datatype pat' =
| PPrim of Prim.t
| PCon of datatype_kind * patCon * pat option
| PRecord of (string * pat * typ) list
+ | PNone of typ
+ | PSome of typ * pat
withtype pat = pat' located
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 25a84b9c..8ca7c09d 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -90,6 +90,12 @@ fun p_typ' par env (t, loc) =
string ("__lwd_" ^ #1 (E.lookupDatatype env n) ^ "_" ^ Int.toString n ^ "*")]
handle CjrEnv.UnboundNamed _ => string ("__lwd_UNBOUND__" ^ Int.toString n))
| TFfi (m, x) => box [string "lw_", string m, string "_", string x]
+ | TOption t =>
+ (case #1 t of
+ TDatatype _ => p_typ' par env t
+ | TFfi ("Basis", "string") => p_typ' par env t
+ | _ => box [p_typ' par env t,
+ string "*"])
and p_typ env = p_typ' false env
@@ -127,6 +133,8 @@ fun p_pat_preamble env (p, _) =
in
(box [pp', pp], env)
end) (box [], env) xps
+ | PNone _ => (box [], env)
+ | PSome (_, p) => p_pat_preamble env p
fun p_patCon env pc =
case pc of
@@ -293,6 +301,65 @@ fun p_pat (env, exit, depth) (p, _) =
env)
end
+ | PNone t =>
+ (box [string "if",
+ space,
+ string "(disc",
+ string (Int.toString depth),
+ space,
+ string "!=",
+ space,
+ string "NULL)",
+ space,
+ exit,
+ newline],
+ env)
+
+ | PSome (t, p) =>
+ let
+ val (p, env) =
+ let
+ val (p, env) = p_pat (env, exit, depth + 1) p
+ in
+ (box [string "{",
+ newline,
+ p_typ env t,
+ space,
+ string "disc",
+ string (Int.toString (depth + 1)),
+ space,
+ string "=",
+ space,
+ case #1 t of
+ TDatatype _ => box [string "disc",
+ string (Int.toString depth)]
+ | TFfi ("Basis", "string") => box [string "disc",
+ string (Int.toString depth)]
+ | _ => box [string "*disc",
+ string (Int.toString depth)],
+ string ";",
+ newline,
+ p,
+ newline,
+ string "}"],
+ env)
+ end
+ in
+ (box [string "if",
+ space,
+ string "(disc",
+ string (Int.toString depth),
+ space,
+ string "==",
+ space,
+ string "NULL)",
+ space,
+ exit,
+ newline,
+ p],
+ env)
+ end
+
local
val count = ref 0
in
diff --git a/src/cjrize.sml b/src/cjrize.sml
index f3e24710..a45cf02d 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -111,6 +111,12 @@ fun cifyTyp x =
((L'.TDatatype (dk, n, r), loc), sm)
end)
| L.TFfi mx => ((L'.TFfi mx, loc), sm)
+ | L.TOption t =>
+ let
+ val (t, sm) = cify dtmap (t, sm)
+ in
+ ((L'.TOption t, loc), sm)
+ end
in
cify IM.empty x
end
@@ -170,6 +176,20 @@ fun cifyPat ((p, loc), sm) =
in
((L'.PRecord xps, loc), sm)
end
+ | L.PNone t =>
+ let
+ val (t, sm) = cifyTyp (t, sm)
+ in
+ ((L'.PNone t, loc), sm)
+ end
+ | L.PSome (t, p) =>
+ let
+ val (t, sm) = cifyTyp (t, sm)
+ val (p, sm) = cifyPat (p, sm)
+ in
+ ((L'.PSome (t, p), loc), sm)
+ end
+
fun cifyExp (eAll as (e, loc), sm) =
case e of
diff --git a/src/core_print.sml b/src/core_print.sml
index 0d5a61c1..cfd01e2d 100644
--- a/src/core_print.sml
+++ b/src/core_print.sml
@@ -306,18 +306,30 @@ fun p_exp' par env (e, _) =
p_con' true env c])
| EFold _ => string "fold"
- | ECase (e, pes, _) => parenIf par (box [string "case",
- space,
- p_exp env e,
- space,
- string "of",
- space,
- p_list_sep (box [space, string "|", space])
- (fn (p, e) => box [p_pat env p,
- space,
- string "=>",
- space,
- p_exp (E.patBinds env p) e]) pes])
+ | ECase (e, pes, {disc, result}) =>
+ parenIf par (box [string "case",
+ space,
+ p_exp env e,
+ space,
+ if !debug then
+ box [string "in",
+ space,
+ p_con env disc,
+ space,
+ string "return",
+ space,
+ p_con env result,
+ space]
+ else
+ box [],
+ string "of",
+ space,
+ p_list_sep (box [space, string "|", space])
+ (fn (p, e) => box [p_pat env p,
+ space,
+ string "=>",
+ space,
+ p_exp (E.patBinds env p) e]) pes])
| EWrite e => box [string "write(",
p_exp env e,
diff --git a/src/corify.sml b/src/corify.sml
index 91c82375..fac83ee3 100644
--- a/src/corify.sml
+++ b/src/corify.sml
@@ -607,6 +607,7 @@ fun corifyDecl ((d, loc : EM.span), st) =
end) st xncs
val nxs = length xs - 1
+ val cBase = c
val c = ListUtil.foldli (fn (i, _, c) => (L'.CApp (c, (L'.CRel (nxs - i), loc)), loc)) c xs
val k = (L'.KType, loc)
val k' = foldl (fn (_, k') => (L'.KArrow (k, k'), loc)) k xs
@@ -623,7 +624,7 @@ fun corifyDecl ((d, loc : EM.span), st) =
(L'.DVal (x, n, t, e, x), loc)
end) xncs
in
- ((L'.DCon (x, n, k', c), loc) :: cds, st)
+ ((L'.DCon (x, n, k', cBase), loc) :: cds, st)
end
| L.DVal (x, n, t, e) =>
let
diff --git a/src/expl_print.sml b/src/expl_print.sml
index 05e6da02..10819fbc 100644
--- a/src/expl_print.sml
+++ b/src/expl_print.sml
@@ -316,18 +316,30 @@ fun p_exp' par env (e, loc) =
p_exp env e,
string ")"]
- | ECase (e, pes, _) => parenIf par (box [string "case",
- space,
- p_exp env e,
- space,
- string "of",
- space,
- p_list_sep (box [space, string "|", space])
- (fn (p, e) => box [p_pat env p,
- space,
- string "=>",
- space,
- p_exp env e]) pes])
+ | ECase (e, pes, {disc, result}) =>
+ parenIf par (box [string "case",
+ space,
+ p_exp env e,
+ space,
+ if !debug then
+ box [string "in",
+ space,
+ p_con env disc,
+ space,
+ string "return",
+ space,
+ p_con env result,
+ space]
+ else
+ box [],
+ string "of",
+ space,
+ p_list_sep (box [space, string "|", space])
+ (fn (p, e) => box [p_pat env p,
+ space,
+ string "=>",
+ space,
+ p_exp env e]) pes])
and p_exp env = p_exp' false env
diff --git a/src/mono.sml b/src/mono.sml
index 4ac21330..3885c789 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -36,6 +36,7 @@ datatype typ' =
| TRecord of (string * typ) list
| TDatatype of int * (datatype_kind * (string * int * typ option) list) ref
| TFfi of string * string
+ | TOption of typ
withtype typ = typ' located
@@ -49,6 +50,8 @@ datatype pat' =
| PPrim of Prim.t
| PCon of datatype_kind * patCon * pat option
| PRecord of (string * pat * typ) list
+ | PNone of typ
+ | PSome of typ * pat
withtype pat = pat' located
diff --git a/src/mono_env.sml b/src/mono_env.sml
index 387e887e..9981ec01 100644
--- a/src/mono_env.sml
+++ b/src/mono_env.sml
@@ -118,5 +118,7 @@ fun patBinds env (p, loc) =
| PCon (_, _, NONE) => env
| PCon (_, _, SOME p) => patBinds env p
| PRecord xps => foldl (fn ((_, p, _), env) => patBinds env p) env xps
+ | PNone _ => env
+ | PSome (_, p) => patBinds env p
end
diff --git a/src/mono_print.sml b/src/mono_print.sml
index 7ae28cf7..da777a82 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -62,6 +62,11 @@ fun p_typ' par env (t, _) =
string (#1 (E.lookupDatatype env n)))
handle E.UnboundNamed _ => string ("UNBOUND_DATATYPE_" ^ Int.toString n))
| TFfi (m, x) => box [string "FFI(", string m, string ".", string x, string ")"]
+ | TOption t =>
+ (case #1 t of
+ TDatatype _ => p_typ env t
+ | TFfi ("Basis", "string") => p_typ env t
+ | _ => box [p_typ env t, string "*"])
and p_typ env = p_typ' false env
@@ -95,8 +100,8 @@ fun p_pat' par env (p, _) =
| PPrim p => Prim.p_t p
| PCon (_, n, NONE) => p_patCon env n
| PCon (_, n, SOME p) => parenIf par (box [p_patCon env n,
- space,
- p_pat' true env p])
+ space,
+ p_pat' true env p])
| PRecord xps =>
box [string "{",
p_list_sep (box [string ",", space]) (fn (x, p, _) =>
@@ -106,6 +111,10 @@ fun p_pat' par env (p, _) =
space,
p_pat env p]) xps,
string "}"]
+ | PNone _ => string "None"
+ | PSome (_, p) => box [string "Some",
+ space,
+ p_pat' true env p]
and p_pat x = p_pat' false x
diff --git a/src/mono_util.sml b/src/mono_util.sml
index f3604cf3..b2fdff52 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -50,6 +50,7 @@ fun compare ((t1, _), (t2, _)) =
end
| (TDatatype (n1, _), TDatatype (n2, _)) => Int.compare (n1, n2)
| (TFfi (m1, x1), TFfi (m2, x2)) => join (String.compare (m1, m2), fn () => String.compare (x1, x2))
+ | (TOption t1, TOption t2) => compare (t1, t2)
| (TFun _, _) => LESS
| (_, TFun _) => GREATER
@@ -60,6 +61,9 @@ fun compare ((t1, _), (t2, _)) =
| (TDatatype _, _) => LESS
| (_, TDatatype _) => GREATER
+ | (TFfi _, _) => LESS
+ | (_, TFfi _) => GREATER
+
and compareFields ((x1, t1), (x2, t2)) =
join (String.compare (x1, x2),
fn () => compare (t1, t2))
@@ -88,6 +92,10 @@ fun mapfold fc =
fn xts' => (TRecord xts', loc))
| TDatatype _ => S.return2 cAll
| TFfi _ => S.return2 cAll
+ | TOption t =>
+ S.map2 (mft t,
+ fn t' =>
+ (TOption t, loc))
in
mft
end
@@ -186,6 +194,8 @@ fun mapfoldB {typ = fc, exp = fe, bind} =
| PCon (_, _, SOME p) => pb (p, ctx)
| PRecord xps => foldl (fn ((_, p, _), ctx) =>
pb (p, ctx)) ctx xps
+ | PNone _ => ctx
+ | PSome (_, p) => pb (p, ctx)
in
S.map2 (mfe (pb (p, ctx)) e,
fn e' => (p, e'))
diff --git a/src/monoize.sml b/src/monoize.sml
index 4e2340a7..802b12f8 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -80,6 +80,9 @@ fun monoType env =
(L'.TRecord (map (fn (x, t) => (monoName env x, mt env dtmap t)) xcs), loc)
| L.TRecord _ => poly ()
+ | L.CApp ((L.CFfi ("Basis", "option"), _), t) =>
+ (L'.TOption (mt env dtmap t), loc)
+
| L.CApp ((L.CFfi ("Basis", "show"), _), t) =>
(L'.TFun (mt env dtmap t, (L'.TFfi ("Basis", "string"), loc)), loc)
@@ -397,6 +400,8 @@ fun monoPat env (all as (p, loc)) =
| L.PVar (x, t) => (L'.PVar (x, monoType env t), loc)
| L.PPrim p => (L'.PPrim p, loc)
| L.PCon (dk, pc, [], po) => (L'.PCon (dk, monoPatCon env pc, Option.map (monoPat env) po), loc)
+ | L.PCon (L.Option, _, [t], NONE) => (L'.PNone (monoType env t), loc)
+ | L.PCon (L.Option, _, [t], SOME p) => (L'.PSome (monoType env t, monoPat env p), loc)
| L.PCon _ => poly ()
| L.PRecord xps => (L'.PRecord (map (fn (x, p, t) => (x, monoPat env p, monoType env t)) xps), loc)
end
diff --git a/tests/fromString.ur b/tests/fromString.ur
new file mode 100644
index 00000000..d9a087e4
--- /dev/null
+++ b/tests/fromString.ur
@@ -0,0 +1,10 @@
+fun i2s s =
+ case stringToInt s of
+ None => 0
+ | Some n => n
+
+fun main () : transaction page = return <html><body>
+ Error = {cdata (show _ (i2s "Error"))}<br/>
+ 3 = {cdata (show _ (i2s "+3"))}<br/>
+</body></html>
+
diff --git a/tests/fromString.urp b/tests/fromString.urp
new file mode 100644
index 00000000..0e6b6640
--- /dev/null
+++ b/tests/fromString.urp
@@ -0,0 +1,5 @@
+debug
+database dbname=test
+exe /tmp/webapp
+
+fromString
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-03 12:57:43 +0000