summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--include/urweb.h2
-rw-r--r--lib/basis.urs4
-rw-r--r--src/c/urweb.c38
-rw-r--r--src/cjr_env.sml4
-rw-r--r--src/cjr_print.sml11
-rw-r--r--src/cjrize.sml3
-rw-r--r--src/compiler.sml16
-rw-r--r--src/elaborate.sml27
-rw-r--r--src/mono_reduce.sml6
-rw-r--r--src/tag.sml4
-rw-r--r--tests/pquery.ur16
-rw-r--r--tests/pquery.urp6
-rw-r--r--tests/pquery.urs1
13 files changed, 110 insertions, 28 deletions
diff --git a/include/urweb.h b/include/urweb.h
index b923e1b0..fd8660e6 100644
--- a/include/urweb.h
+++ b/include/urweb.h
@@ -59,3 +59,5 @@ lw_Basis_bool lw_Basis_unurlifyBool(lw_context, char **);
lw_Basis_string lw_Basis_strcat(lw_context, lw_Basis_string, lw_Basis_string);
lw_Basis_string lw_Basis_strdup(lw_context, lw_Basis_string);
+
+lw_Basis_string lw_Basis_sqlifyString(lw_context, lw_Basis_string);
diff --git a/lib/basis.urs b/lib/basis.urs
index cd355316..38049f13 100644
--- a/lib/basis.urs
+++ b/lib/basis.urs
@@ -230,7 +230,7 @@ val font : bodyTag [Size = int, Face = string]
val h1 : bodyTag []
val li : bodyTag []
-val a : bodyTag [Link = page]
+val a : bodyTag [Link = transaction page]
val lform : ctx ::: {Unit} -> [Body] ~ ctx -> bind ::: {Type}
-> xml lform [] bind
@@ -255,4 +255,4 @@ val loption : unit -> tag [Value = string] select [] [] []
val submit : ctx ::: {Unit} -> [LForm] ~ ctx
-> use ::: {Type} -> unit
- -> tag [Action = $use -> page] ([LForm] ++ ctx) ([LForm] ++ ctx) use []
+ -> tag [Action = $use -> transaction page] ([LForm] ++ ctx) ([LForm] ++ ctx) use []
diff --git a/src/c/urweb.c b/src/c/urweb.c
index f0e93e46..57caa03d 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -589,3 +589,41 @@ lw_Basis_string lw_Basis_strdup(lw_context ctx, lw_Basis_string s1) {
return s;
}
+
+
+lw_Basis_string lw_Basis_sqlifyString(lw_context ctx, lw_Basis_string s) {
+ char *r, *s2;
+
+ lw_check_heap(ctx, strlen(s) * 2 + 4);
+
+ r = s2 = ctx->heap_front;
+ *s2++ = 'E';
+ *s2++ = '\'';
+
+ for (; *s; s++) {
+ char c = *s;
+
+ switch (c) {
+ case '\'':
+ strcpy(s2, "\\'");
+ s2 += 2;
+ break;
+ case '\\':
+ strcpy(s2, "\\\\");
+ s2 += 2;
+ break;
+ default:
+ if (isprint(c))
+ *s2++ = c;
+ else {
+ sprintf(s2, "\\%3o", c);
+ s2 += 4;
+ }
+ }
+ }
+
+ *s2++ = '\'';
+ *s2++ = 0;
+ ctx->heap_front = s2;
+ return r;
+}
diff --git a/src/cjr_env.sml b/src/cjr_env.sml
index 482b93f6..0859abe5 100644
--- a/src/cjr_env.sml
+++ b/src/cjr_env.sml
@@ -48,7 +48,7 @@ type env = {
structs : (string * typ) list IM.map
}
-val empty = {
+val empty : env = {
datatypes = IM.empty,
constructors = IM.empty,
@@ -56,7 +56,7 @@ val empty = {
relE = [],
namedE = IM.empty,
- structs = IM.empty
+ structs = IM.insert (IM.empty, 0, [])
}
fun pushDatatype (env : env) x n xncs =
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 938821be..50098a99 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -881,7 +881,7 @@ fun p_file env (ds, ps) =
case ek of
Core.Link => fields
| Core.Action =>
- case List.last ts of
+ case List.nth (ts, length ts - 2) of
(TRecord i, _) =>
let
val xts = E.lookupStruct env i
@@ -1222,12 +1222,12 @@ fun p_file env (ds, ps) =
case ek of
Core.Link => (ts, string "", string "")
| Core.Action =>
- case List.last ts of
+ case List.nth (ts, length ts - 2) of
(TRecord i, _) =>
let
val xts = E.lookupStruct env i
in
- (List.drop (ts, 1),
+ (List.take (ts, length ts - 2),
box [box (map (fn (x, t) => box [p_typ env t,
space,
string "lw_input_",
@@ -1324,10 +1324,9 @@ fun p_file env (ds, ps) =
p_list_sep (box [string ",", space])
(fn x => x)
(string "ctx"
- :: ListUtil.mapi (fn (i, _) => string ("arg" ^ Int.toString i)) ts
- @ [string "lw_unit_v"]),
+ :: ListUtil.mapi (fn (i, _) => string ("arg" ^ Int.toString i)) ts),
inputsVar,
- string ");",
+ string ", lw_unit_v);",
newline,
string "return;",
newline,
diff --git a/src/cjrize.sml b/src/cjrize.sml
index 88fae6f0..ed8182c2 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -171,7 +171,7 @@ fun cifyPat ((p, loc), sm) =
((L'.PRecord xps, loc), sm)
end
-fun cifyExp ((e, loc), sm) =
+fun cifyExp (eAll as (e, loc), sm) =
case e of
L.EPrim p => ((L'.EPrim p, loc), sm)
| L.ERel n => ((L'.ERel n, loc), sm)
@@ -206,6 +206,7 @@ fun cifyExp ((e, loc), sm) =
((L'.EApp (e1, e2), loc), sm)
end
| L.EAbs _ => (ErrorMsg.errorAt loc "Anonymous function remains at code generation";
+ Print.prefaces' [("Function", MonoPrint.p_exp MonoEnv.empty eAll)];
(dummye, sm))
| L.ERecord xes =>
diff --git a/src/compiler.sml b/src/compiler.sml
index f9fe0da8..263aaf9a 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -93,15 +93,17 @@ fun op o (tr2 : ('b, 'c) transform, tr1 : ('a, 'b) transform) = {
end
}
-fun run (tr : ('src, 'dst) transform) = #func tr
+fun run (tr : ('src, 'dst) transform) x = (ErrorMsg.resetErrors ();
+ #func tr x)
fun runPrint (tr : ('src, 'dst) transform) input =
- case #func tr input of
- NONE => print "Failure\n"
- | SOME v =>
- (print "Success\n";
- Print.print (#print tr v);
- print "\n")
+ (ErrorMsg.resetErrors ();
+ case #func tr input of
+ NONE => print "Failure\n"
+ | SOME v =>
+ (print "Success\n";
+ Print.print (#print tr v);
+ print "\n"))
fun time (tr : ('src, 'dst) transform) input =
let
diff --git a/src/elaborate.sml b/src/elaborate.sml
index d4b71b80..5770fe5b 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -1482,11 +1482,9 @@ fun normClassConstraint envs (c, loc) =
fun elabExp (env, denv) (eAll as (e, loc)) =
let
-
- in
- (*eprefaces "elabExp" [("eAll", SourcePrint.p_exp eAll)];*)
+ (*val () = eprefaces "elabExp" [("eAll", SourcePrint.p_exp eAll)];*)
- case e of
+ val r = case e of
L.EAnnot (e, t) =>
let
val (e', et, gs1) = elabExp (env, denv) e
@@ -1756,6 +1754,12 @@ fun elabExp (env, denv) (eAll as (e, loc)) =
((L'.ECase (e', pes', {disc = et, result = result}), loc), result, enD gs' @ gs)
end
+
+ (*val tcs = List.filter (fn TypeClass _ => true | _ => false) (#3 r)*)
+ in
+ (*prefaces "elabExp" [("e", SourcePrint.p_exp eAll),
+ ("|tcs|", PD.string (Int.toString (length tcs)))];*)
+ r
end
@@ -2731,7 +2735,7 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) =
| _ => sgnError env (SgnWrongForm (sgn1, sgn2))
-fun elabDecl ((d, loc), (env, denv, gs : constraint list)) =
+fun elabDecl (dAll as (d, loc), (env, denv, gs : constraint list)) =
let
(*val () = preface ("elabDecl", SourcePrint.p_decl (d, loc))*)
@@ -2873,7 +2877,7 @@ fun elabDecl ((d, loc), (env, denv, gs : constraint list)) =
| SOME c => elabCon (env, denv) c
in
((x, c', e), enD gs1 @ gs)
- end) [] vis
+ end) gs vis
val (vis, env) = ListUtil.foldlMap (fn ((x, c', e), env) =>
let
@@ -3103,16 +3107,21 @@ fun elabDecl ((d, loc), (env, denv, gs : constraint list)) =
| L.DClass (x, c) =>
let
val k = (L'.KArrow ((L'.KType, loc), (L'.KType, loc)), loc)
- val (c', ck, gs) = elabCon (env, denv) c
+ val (c', ck, gs') = elabCon (env, denv) c
val (env, n) = E.pushCNamed env x k (SOME c')
val env = E.pushClass env n
in
checkKind env c' ck k;
- ([(L'.DClass (x, n, c'), loc)], (env, denv, []))
+ ([(L'.DClass (x, n, c'), loc)], (env, denv, enD gs' @ gs))
end
- | L.DDatabase s => ([(L'.DDatabase s, loc)], (env, denv, []))
+ | L.DDatabase s => ([(L'.DDatabase s, loc)], (env, denv, gs))
+
+ (*val tcs = List.filter (fn TypeClass _ => true | _ => false) (#3 (#2 r))*)
in
+ (*prefaces "elabDecl" [("e", SourcePrint.p_decl dAll),
+ ("|tcs|", PD.string (Int.toString (length tcs)))];*)
+
r
end
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index 5367be60..cc44869a 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -97,6 +97,12 @@ fun match (env, p : pat, e : exp) =
(PWild, _) => Yes env
| (PVar (x, t), _) => Yes (E.pushERel env x t (SOME e))
+ | (PPrim (Prim.String s), EStrcat ((EPrim (Prim.String s'), _), _)) =>
+ if String.isPrefix s' s then
+ Maybe
+ else
+ No
+
| (PPrim p, EPrim p') =>
if Prim.equal (p, p') then
Yes env
diff --git a/src/tag.sml b/src/tag.sml
index a8b59c5a..34595732 100644
--- a/src/tag.sml
+++ b/src/tag.sml
@@ -216,7 +216,9 @@ fun tag file =
((EApp (app, (ERel n, loc)), loc),
n - 1))
((ENamed f, loc), length args - 1) args
+ val app = (EApp (app, (ERecord [], loc)), loc)
val body = (EWrite app, loc)
+ val t = (TFun (unit, unit), loc)
val (abs, _, t) = foldr (fn (t, (abs, n, rest)) =>
((EAbs ("x" ^ Int.toString n,
t,
@@ -224,7 +226,7 @@ fun tag file =
abs), loc),
n + 1,
(TFun (t, rest), loc)))
- (body, 0, unit) args
+ (body, 0, t) args
in
(abs, t)
end
diff --git a/tests/pquery.ur b/tests/pquery.ur
new file mode 100644
index 00000000..0ccbc9f2
--- /dev/null
+++ b/tests/pquery.ur
@@ -0,0 +1,16 @@
+table t1 : {A : int, B : string, C : float}
+
+fun lookup (inp : {B : string}) =
+ s <- query (SELECT t1.B FROM t1 WHERE t1.B = {inp.B})
+ (fn fs _ => return fs.T1.B)
+ "Couldn't find it!";
+ return <html><body>
+ Result: {cdata s}
+ </body></html>
+
+fun main () : transaction page = return <html><body>
+ <lform>
+ B: <textbox{#B}/>
+ <submit action={lookup}/>
+ </lform>
+</body></html>
diff --git a/tests/pquery.urp b/tests/pquery.urp
new file mode 100644
index 00000000..802281cd
--- /dev/null
+++ b/tests/pquery.urp
@@ -0,0 +1,6 @@
+debug
+database dbname=test
+exe /tmp/webapp
+sql /tmp/urweb.sql
+
+pquery
diff --git a/tests/pquery.urs b/tests/pquery.urs
new file mode 100644
index 00000000..6ac44e0b
--- /dev/null
+++ b/tests/pquery.urs
@@ -0,0 +1 @@
+val main : unit -> transaction page
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-29 08:05:41 +0000