summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--lib/basis.urs8
-rw-r--r--lib/top.ur6
-rw-r--r--lib/top.urs8
-rw-r--r--src/cjr_print.sml3
-rw-r--r--src/compiler.sml4
-rw-r--r--src/elaborate.sig3
-rw-r--r--src/elaborate.sml248
-rw-r--r--src/monoize.sml1
-rw-r--r--src/unpoly.sml16
-rw-r--r--src/urweb.grm86
-rw-r--r--tests/crud.ur40
-rw-r--r--tests/crud.urs11
-rw-r--r--tests/crud1.ur14
-rw-r--r--tests/crud1.urp7
14 files changed, 338 insertions, 117 deletions
diff --git a/lib/basis.urs b/lib/basis.urs
index a095a57e..8737cbde 100644
--- a/lib/basis.urs
+++ b/lib/basis.urs
@@ -250,6 +250,7 @@ val useMore : ctx ::: {Unit} -> use1 ::: {Type} -> use2 ::: {Type} -> bind ::: {
con xhtml = xml [Html]
con page = xhtml [] []
+con xbody = xml [Body] [] []
(*** HTML details *)
@@ -304,6 +305,13 @@ val submit : ctx ::: {Unit} -> [LForm] ~ ctx
-> use ::: {Type} -> unit
-> tag [Action = $use -> transaction page] ([LForm] ++ ctx) ([LForm] ++ ctx) use []
+(*** Tables *)
+
+val tabl : unit -> tag [Border = int] [Body] [Body, Table] [] []
+val tr : unit -> tag [] [Body, Table] [Body, Tr] [] []
+val th : unit -> tag [] [Body, Tr] [Body] [] []
+val td : unit -> tag [] [Body, Tr] [Body] [] []
+
(** Aborting *)
diff --git a/lib/top.ur b/lib/top.ur
new file mode 100644
index 00000000..16d2ed42
--- /dev/null
+++ b/lib/top.ur
@@ -0,0 +1,6 @@
+con mapTT (f :: Type -> Type) = fold (fn nm t acc => [nm] ~ acc =>
+ [nm = f t] ++ acc) []
+
+fun compose (t1 ::: Type) (t2 ::: Type) (t3 ::: Type) (f1 : t2 -> t3) (f2 : t1 -> t2) (x : t1) = f1 (f2 x)
+
+fun txt (t ::: Type) (ctx ::: {Unit}) (use ::: {Type}) (sh : show t) (v : t) = cdata (show sh v)
diff --git a/lib/top.urs b/lib/top.urs
new file mode 100644
index 00000000..80344602
--- /dev/null
+++ b/lib/top.urs
@@ -0,0 +1,8 @@
+con mapTT = fn f :: Type -> Type => fold (fn nm t acc => [nm] ~ acc =>
+ [nm = f t] ++ acc) []
+
+val compose : t1 ::: Type -> t2 ::: Type -> t3 ::: Type
+ -> (t2 -> t3) -> (t1 -> t2) -> (t1 -> t3)
+
+val txt : t ::: Type -> ctx ::: {Unit} -> use ::: {Type} -> show t -> t
+ -> xml ctx use []
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index bdf2873f..c235d2a2 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -738,6 +738,7 @@ fun p_exp' par env (e, loc) =
tables
val outputs = exps @ tables
+ val outputs = ListMergeSort.sort (fn ((s1, _), (s2, _)) => String.compare (s1, s2) = GREATER) outputs
val wontLeakStrings = notLeaky env true state
val wontLeakAnything = notLeaky env false state
@@ -1721,7 +1722,7 @@ fun p_file env (ds, ps) =
val q'' = String.concat ["SELECT COUNT(*) FROM pg_attribute WHERE attrelid = (SELECT oid FROM pg_class WHERE relname = '",
s,
- "') AND attnum >= 0"]
+ "') AND attname LIKE 'uw_%'"]
in
box [string "res = PQexec(conn, \"",
string q,
diff --git a/src/compiler.sml b/src/compiler.sml
index b2f5fc96..569980f4 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -355,8 +355,10 @@ val toParse = transform parse "parse" o toParseJob
val elaborate = {
func = fn file => let
val basis = #func parseUrs "lib/basis.urs"
+ val topSgn = #func parseUrs "lib/top.urs"
+ val topStr = #func parseUr "lib/top.ur"
in
- Elaborate.elabFile basis ElabEnv.empty file
+ Elaborate.elabFile basis topStr topSgn ElabEnv.empty file
end,
print = ElabPrint.p_file ElabEnv.empty
}
diff --git a/src/elaborate.sig b/src/elaborate.sig
index 0a7a6bbc..cab3c3c5 100644
--- a/src/elaborate.sig
+++ b/src/elaborate.sig
@@ -27,6 +27,7 @@
signature ELABORATE = sig
- val elabFile : Source.sgn_item list -> ElabEnv.env -> Source.file -> Elab.file
+ val elabFile : Source.sgn_item list -> Source.decl list -> Source.sgn_item list
+ -> ElabEnv.env -> Source.file -> Elab.file
end
diff --git a/src/elaborate.sml b/src/elaborate.sml
index 7ec9c620..5109feb4 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -2805,6 +2805,98 @@ fun positive self =
pos
end
+fun wildifyStr env (str, sgn) =
+ case #1 (hnormSgn env sgn) of
+ L'.SgnConst sgis =>
+ (case #1 str of
+ L.StrConst ds =>
+ let
+ fun decompileCon env (c, loc) =
+ case c of
+ L'.CRel i =>
+ let
+ val (s, _) = E.lookupCRel env i
+ in
+ SOME (L.CVar ([], s), loc)
+ end
+ | L'.CNamed i =>
+ let
+ val (s, _, _) = E.lookupCNamed env i
+ in
+ SOME (L.CVar ([], s), loc)
+ end
+ | L'.CModProj (m1, ms, x) =>
+ let
+ val (s, _) = E.lookupStrNamed env m1
+ in
+ SOME (L.CVar (s :: ms, x), loc)
+ end
+ | L'.CName s => SOME (L.CName s, loc)
+ | L'.CRecord (_, xcs) =>
+ let
+ fun fields xcs =
+ case xcs of
+ [] => SOME []
+ | (x, t) :: xcs =>
+ case (decompileCon env x, decompileCon env t, fields xcs) of
+ (SOME x, SOME t, SOME xcs) => SOME ((x, t) :: xcs)
+ | _ => NONE
+ in
+ Option.map (fn xcs => (L.CRecord xcs, loc))
+ (fields xcs)
+ end
+ | L'.CConcat (c1, c2) =>
+ (case (decompileCon env c1, decompileCon env c2) of
+ (SOME c1, SOME c2) => SOME (L.CConcat (c1, c2), loc)
+ | _ => NONE)
+ | L'.CUnit => SOME (L.CUnit, loc)
+
+ | _ => NONE
+
+ val (needed, constraints, _) =
+ foldl (fn ((sgi, loc), (needed, constraints, env')) =>
+ let
+ val (needed, constraints) =
+ case sgi of
+ L'.SgiConAbs (x, _, _) => (SS.add (needed, x), constraints)
+ | L'.SgiConstraint cs => (needed, (env', cs, loc) :: constraints)
+ | _ => (needed, constraints)
+ in
+ (needed, constraints, E.sgiBinds env' (sgi, loc))
+ end)
+ (SS.empty, [], env) sgis
+
+ val needed = foldl (fn ((d, _), needed) =>
+ case d of
+ L.DCon (x, _, _) => (SS.delete (needed, x)
+ handle NotFound =>
+ needed)
+ | L.DClass (x, _) => (SS.delete (needed, x)
+ handle NotFound => needed)
+ | L.DOpen _ => SS.empty
+ | _ => needed)
+ needed ds
+
+ val cds = List.mapPartial (fn (env', (c1, c2), loc) =>
+ case (decompileCon env' c1, decompileCon env' c2) of
+ (SOME c1, SOME c2) =>
+ SOME (L.DConstraint (c1, c2), loc)
+ | _ => NONE) constraints
+ in
+ case SS.listItems needed of
+ [] => (L.StrConst (ds @ cds), #2 str)
+ | xs =>
+ let
+ val kwild = (L.KWild, #2 str)
+ val cwild = (L.CWild kwild, #2 str)
+ val ds' = map (fn x => (L.DCon (x, NONE, cwild), #2 str)) xs
+ in
+ (L.StrConst (ds @ ds' @ cds), #2 str)
+ end
+ end
+ | _ => str)
+ | _ => str
+
fun elabDecl (dAll as (d, loc), (env, denv, gs : constraint list)) =
let
(*val () = preface ("elabDecl", SourcePrint.p_decl (d, loc))*)
@@ -3010,43 +3102,7 @@ fun elabDecl (dAll as (d, loc), (env, denv, gs : constraint list)) =
end
| SOME (formal, gs1) =>
let
- val str =
- case #1 (hnormSgn env formal) of
- L'.SgnConst sgis =>
- (case #1 str of
- L.StrConst ds =>
- let
- val needed = foldl (fn ((sgi, _), needed) =>
- case sgi of
- L'.SgiConAbs (x, _, _) => SS.add (needed, x)
- | _ => needed)
- SS.empty sgis
-
- val needed = foldl (fn ((d, _), needed) =>
- case d of
- L.DCon (x, _, _) => (SS.delete (needed, x)
- handle NotFound =>
- needed)
- | L.DClass (x, _) => (SS.delete (needed, x)
- handle NotFound => needed)
- | L.DOpen _ => SS.empty
- | _ => needed)
- needed ds
- in
- case SS.listItems needed of
- [] => str
- | xs =>
- let
- val kwild = (L.KWild, #2 str)
- val cwild = (L.CWild kwild, #2 str)
- val ds' = map (fn x => (L.DCon (x, NONE, cwild), #2 str)) xs
- in
- (L.StrConst (ds @ ds'), #2 str)
- end
- end
- | _ => str)
- | _ => str
-
+ val str = wildifyStr env (str, formal)
val (str', actual, gs2) = elabStr (env, denv) str
in
subSgn (env, denv) (selfifyAt env {str = str', sgn = actual}) formal;
@@ -3125,47 +3181,52 @@ fun elabDecl (dAll as (d, loc), (env, denv, gs : constraint list)) =
fun doOne (all as (sgi, _), env) =
(case sgi of
L'.SgiVal (x, n, t) =>
- (case hnormCon (env, denv) t of
- ((L'.TFun (dom, ran), _), []) =>
- (case (hnormCon (env, denv) dom, hnormCon (env, denv) ran) of
- (((L'.TRecord domR, _), []),
- ((L'.CApp (tf, arg), _), [])) =>
- (case (hnormCon (env, denv) tf, hnormCon (env, denv) arg) of
- (((L'.CModProj (basis, [], "transaction"), _), []),
- ((L'.CApp (tf, arg3), _), [])) =>
- (case (basis = !basis_r,
- hnormCon (env, denv) tf, hnormCon (env, denv) arg3) of
- (true,
- ((L'.CApp (tf, arg2), _), []),
- (((L'.CRecord (_, []), _), []))) =>
- (case (hnormCon (env, denv) tf) of
- ((L'.CApp (tf, arg1), _), []) =>
- (case (hnormCon (env, denv) tf,
- hnormCon (env, denv) domR,
- hnormCon (env, denv) arg1,
- hnormCon (env, denv) arg2) of
- ((tf, []), (domR, []), (arg1, []),
- ((L'.CRecord (_, []), _), [])) =>
- let
- val t = (L'.CApp (tf, arg1), loc)
- val t = (L'.CApp (t, arg2), loc)
- val t = (L'.CApp (t, arg3), loc)
- val t = (L'.CApp (
- (L'.CModProj
- (basis, [], "transaction"), loc),
- t), loc)
- in
- (L'.SgiVal (x, n, (L'.TFun ((L'.TRecord domR,
- loc),
- t),
- loc)), loc)
- end
- | _ => all)
- | _ => all)
- | _ => all)
- | _ => all)
- | _ => all)
- | _ => all)
+ let
+ fun doPage (makeRes, ran) =
+ case hnormCon (env, denv) ran of
+ ((L'.CApp (tf, arg), _), []) =>
+ (case (hnormCon (env, denv) tf, hnormCon (env, denv) arg) of
+ (((L'.CModProj (basis, [], "transaction"), _), []),
+ ((L'.CApp (tf, arg3), _), [])) =>
+ (case (basis = !basis_r,
+ hnormCon (env, denv) tf, hnormCon (env, denv) arg3) of
+ (true,
+ ((L'.CApp (tf, arg2), _), []),
+ (((L'.CRecord (_, []), _), []))) =>
+ (case (hnormCon (env, denv) tf) of
+ ((L'.CApp (tf, arg1), _), []) =>
+ (case (hnormCon (env, denv) tf,
+ hnormCon (env, denv) arg1,
+ hnormCon (env, denv) arg2) of
+ ((tf, []), (arg1, []),
+ ((L'.CRecord (_, []), _), [])) =>
+ let
+ val t = (L'.CApp (tf, arg1), loc)
+ val t = (L'.CApp (t, arg2), loc)
+ val t = (L'.CApp (t, arg3), loc)
+ val t = (L'.CApp (
+ (L'.CModProj
+ (basis, [], "transaction"), loc),
+ t), loc)
+ in
+ (L'.SgiVal (x, n, makeRes t), loc)
+ end
+ | _ => all)
+ | _ => all)
+ | _ => all)
+ | _ => all)
+ | _ => all
+ in
+ case hnormCon (env, denv) t of
+ ((L'.TFun (dom, ran), _), []) =>
+ (case hnormCon (env, denv) dom of
+ ((L'.TRecord domR, _), []) =>
+ doPage (fn t => (L'.TFun ((L'.TRecord domR,
+ loc),
+ t), loc), ran)
+ | _ => all)
+ | _ => doPage (fn t => t, t)
+ end
| _ => all,
E.sgiBinds env all)
in
@@ -3375,6 +3436,11 @@ and elabStr (env, denv) (str, loc) =
| L.StrApp (str1, str2) =>
let
val (str1', sgn1, gs1) = elabStr (env, denv) str1
+ val str2 =
+ case sgn1 of
+ (L'.SgnFun (_, _, dom, _), _) =>
+ wildifyStr env (str2, dom)
+ | _ => str2
val (str2', sgn2, gs2) = elabStr (env, denv) str2
in
case #1 (hnormSgn env sgn1) of
@@ -3392,7 +3458,7 @@ and elabStr (env, denv) (str, loc) =
(strerror, sgnerror, []))
end
-fun elabFile basis env file =
+fun elabFile basis topStr topSgn env file =
let
val (sgn, gs) = elabSgn (env, D.empty) (L.SgnConst basis, ErrorMsg.dummySpan)
val () = case gs of
@@ -3419,6 +3485,25 @@ fun elabFile basis env file =
val () = discoverC string "string"
val () = discoverC table "sql_table"
+ val (topSgn, gs) = elabSgn (env', D.empty) (L.SgnConst topSgn, ErrorMsg.dummySpan)
+ val () = case gs of
+ [] => ()
+ | _ => raise Fail "Unresolved disjointness constraints in top.urs"
+ val (topStr, topSgn', gs) = elabStr (env', D.empty) (L.StrConst topStr, ErrorMsg.dummySpan)
+ val () = case gs of
+ [] => ()
+ | _ => (app (fn Disjoint (_, env, _, c1, c2) =>
+ prefaces "Unresolved"
+ [("c1", p_con env c1),
+ ("c2", p_con env c2)]
+ | TypeClass _ => TextIO.print "Type class\n") gs;
+ raise Fail "Unresolved constraints in top.ur")
+ val () = subSgn (env', D.empty) topSgn' topSgn
+
+ val (env', top_n) = E.pushStrNamed env' "Top" topSgn
+
+ val (ds', (env', _)) = dopen (env', D.empty) {str = top_n, strs = [], sgn = topSgn}
+
fun elabDecl' (d, (env, gs)) =
let
val () = resetKunif ()
@@ -3461,7 +3546,10 @@ fun elabFile basis env file =
SOME e => r := SOME e
| NONE => expError env (Unresolvable (loc, c))) gs;
- (L'.DFfiStr ("Basis", basis_n, sgn), ErrorMsg.dummySpan) :: ds @ file
+ (L'.DFfiStr ("Basis", basis_n, sgn), ErrorMsg.dummySpan)
+ :: ds
+ @ (L'.DStr ("Top", top_n, topSgn, topStr), ErrorMsg.dummySpan)
+ :: ds' @ file
end
end
diff --git a/src/monoize.sml b/src/monoize.sml
index 472e04cb..e750c381 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -1372,6 +1372,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
| "loption" => normal ("option", NONE)
+ | "tabl" => normal ("table", NONE)
| _ => normal (tag, NONE)
end
diff --git a/src/unpoly.sml b/src/unpoly.sml
index 12cff6c8..5236961b 100644
--- a/src/unpoly.sml
+++ b/src/unpoly.sml
@@ -56,7 +56,19 @@ fun unpolyNamed (xn, rep) =
rep
else
e
- | ECApp (e, _) => #1 e
+ | ECApp (e', _) =>
+ let
+ fun isTheOne (e, _) =
+ case e of
+ ENamed xn' => xn' = xn
+ | ECApp (e, _) => isTheOne e
+ | _ => false
+ in
+ if isTheOne e' then
+ #1 e'
+ else
+ e
+ end
| _ => e}
type state = {
@@ -110,7 +122,7 @@ fun exp (e, st : state) =
let
val e = foldl (fn ((_, n, n_old, _, _, _), e) =>
unpolyNamed (n_old, ENamed n) e)
- e vis
+ e vis
in
SOME (t, e)
end
diff --git a/src/urweb.grm b/src/urweb.grm
index efa35117..c8dd5698 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -152,6 +152,11 @@ fun native_op (oper, e1, e2, loc) =
val inDml = ref false
+fun tagIn bt =
+ case bt of
+ "table" => "tabl"
+ | _ => bt
+
%%
%header (functor UrwebLrValsFn(structure Token : TOKEN))
@@ -187,7 +192,7 @@ val inDml = ref false
%nonterm
file of decl list
| decls of decl list
- | decl of decl
+ | decl of decl list
| vali of string * con option * exp
| valis of (string * con option * exp) list
| copt of con option
@@ -326,7 +331,7 @@ file : decls (decls)
s (SIGleft, sgisright))])
decls : ([])
- | decl decls (decl :: decls)
+ | decl decls (decl @ decls)
decl : CON SYMBOL cargl2 kopt EQ cexp (let
val loc = s (CONleft, cexpright)
@@ -334,47 +339,59 @@ decl : CON SYMBOL cargl2 kopt EQ cexp (let
val k = Option.getOpt (kopt, (KWild, loc))
val (c, k) = cargl2 (cexp, k)
in
- (DCon (SYMBOL, SOME k, c), loc)
+ [(DCon (SYMBOL, SOME k, c), loc)]
end)
- | LTYPE SYMBOL EQ cexp (DCon (SYMBOL, SOME (KType, s (LTYPEleft, cexpright)), cexp),
- s (LTYPEleft, cexpright))
- | DATATYPE SYMBOL dargs EQ barOpt dcons(DDatatype (SYMBOL, dargs, dcons), s (DATATYPEleft, dconsright))
+ | LTYPE SYMBOL EQ cexp ([(DCon (SYMBOL, SOME (KType, s (LTYPEleft, cexpright)), cexp),
+ s (LTYPEleft, cexpright))])
+ | DATATYPE SYMBOL dargs EQ barOpt dcons([(DDatatype (SYMBOL, dargs, dcons), s (DATATYPEleft, dconsright))])
| DATATYPE SYMBOL dargs EQ DATATYPE CSYMBOL DOT path
(case dargs of
- [] => (DDatatypeImp (SYMBOL, CSYMBOL :: #1 path, #2 path), s (DATATYPEleft, pathright))
+ [] => [(DDatatypeImp (SYMBOL, CSYMBOL :: #1 path, #2 path), s (DATATYPEleft, pathright))]
| _ => raise Fail "Arguments specified for imported datatype")
- | VAL vali (DVal vali, s (VALleft, valiright))
- | VAL REC valis (DValRec valis, s (VALleft, valisright))
- | FUN valis (DValRec valis, s (FUNleft, valisright))
+ | VAL vali ([(DVal vali, s (VALleft, valiright))])
+ | VAL REC valis ([(DValRec valis, s (VALleft, valisright))])
+ | FUN valis ([(DValRec valis, s (FUNleft, valisright))])
- | SIGNATURE CSYMBOL EQ sgn (DSgn (CSYMBOL, sgn), s (SIGNATUREleft, sgnright))
- | STRUCTURE CSYMBOL EQ str (DStr (CSYMBOL, NONE, str), s (STRUCTUREleft, strright))
- | STRUCTURE CSYMBOL COLON sgn EQ str (DStr (CSYMBOL, SOME sgn, str), s (STRUCTUREleft, strright))
+ | SIGNATURE CSYMBOL EQ sgn ([(DSgn (CSYMBOL, sgn), s (SIGNATUREleft, sgnright))])
+ | STRUCTURE CSYMBOL EQ str ([(DStr (CSYMBOL, NONE, str), s (STRUCTUREleft, strright))])
+ | STRUCTURE CSYMBOL COLON sgn EQ str ([(DStr (CSYMBOL, SOME sgn, str), s (STRUCTUREleft, strright))])
| FUNCTOR CSYMBOL LPAREN CSYMBOL COLON sgn RPAREN EQ str
- (DStr (CSYMBOL1, NONE,
- (StrFun (CSYMBOL2, sgn1, NONE, str), s (FUNCTORleft, strright))),
- s (FUNCTORleft, strright))
+ ([(DStr (CSYMBOL1, NONE,
+ (StrFun (CSYMBOL2, sgn1, NONE, str), s (FUNCTORleft, strright))),
+ s (FUNCTORleft, strright))])
| FUNCTOR CSYMBOL LPAREN CSYMBOL COLON sgn RPAREN COLON sgn EQ str
- (DStr (CSYMBOL1, NONE,
- (StrFun (CSYMBOL2, sgn1, SOME sgn2, str), s (FUNCTORleft, strright))),
- s (FUNCTORleft, strright))
- | EXTERN STRUCTURE CSYMBOL COLON sgn (DFfiStr (CSYMBOL, sgn), s (EXTERNleft, sgnright))
+ ([(DStr (CSYMBOL1, NONE,
+ (StrFun (CSYMBOL2, sgn1, SOME sgn2, str), s (FUNCTORleft, strright))),
+ s (FUNCTORleft, strright))])
+ | EXTERN STRUCTURE CSYMBOL COLON sgn ([(DFfiStr (CSYMBOL, sgn), s (EXTERNleft, sgnright))])
| OPEN mpath (case mpath of
[] => raise Fail "Impossible mpath parse [1]"
- | m :: ms => (DOpen (m, ms), s (OPENleft, mpathright)))
+ | m :: ms => [(DOpen (m, ms), s (OPENleft, mpathright))])
+ | OPEN mpath LPAREN str RPAREN (let
+ val loc = s (OPENleft, RPARENright)
+
+ val m = case mpath of
+ [] => raise Fail "Impossible mpath parse [4]"
+ | m :: ms =>
+ foldl (fn (m, str) => (StrProj (str, m), loc))
+ (StrVar m, loc) ms
+ in
+ [(DStr ("anon", NONE, (StrApp (m, str), loc)), loc),
+ (DOpen ("anon", []), loc)]
+ end)
| OPEN CONSTRAINTS mpath (case mpath of
[] => raise Fail "Impossible mpath parse [3]"
- | m :: ms => (DOpenConstraints (m, ms), s (OPENleft, mpathright)))
- | CONSTRAINT cterm TWIDDLE cterm (DConstraint (cterm1, cterm2), s (CONSTRAINTleft, ctermright))
- | EXPORT spath (DExport spath, s (EXPORTleft, spathright))
- | TABLE SYMBOL COLON cexp (DTable (SYMBOL, entable cexp), s (TABLEleft, cexpright))
- | CLASS SYMBOL EQ cexp (DClass (SYMBOL, cexp), s (CLASSleft, cexpright))
+ | m :: ms => [(DOpenConstraints (m, ms), s (OPENleft, mpathright))])
+ | CONSTRAINT cterm TWIDDLE cterm ([(DConstraint (cterm1, cterm2), s (CONSTRAINTleft, ctermright))])
+ | EXPORT spath ([(DExport spath, s (EXPORTleft, spathright))])
+ | TABLE SYMBOL COLON cexp ([(DTable (SYMBOL, entable cexp), s (TABLEleft, cexpright))])
+ | CLASS SYMBOL EQ cexp ([(DClass (SYMBOL, cexp), s (CLASSleft, cexpright))])
| CLASS SYMBOL SYMBOL EQ cexp (let
val loc = s (CLASSleft, cexpright)
val k = (KType, loc)
val c = (CAbs (SYMBOL2, SOME k, cexp), loc)
in
- (DClass (SYMBOL1, c), s (CLASSleft, cexpright))
+ [(DClass (SYMBOL1, c), s (CLASSleft, cexpright))]
end)
kopt : (NONE)
@@ -853,15 +870,19 @@ xmlOne : NOTAGS (EApp ((EVar (["Basis"], "cdata"), s (NO
| tag GT xml END_TAG (let
val pos = s (tagleft, GTright)
+ val et = tagIn END_TAG
in
- if #1 tag = END_TAG then
- if END_TAG = "lform" then
+ if #1 tag = et then
+ if et = "lform" then
(EApp ((EVar (["Basis"], "lform"), pos),
xml), pos)
else
(EApp (#2 tag, xml), pos)
else
- (ErrorMsg.errorAt pos "Begin and end tags don't match.";
+ (if ErrorMsg.anyErrors () then
+ ()
+ else
+ ErrorMsg.errorAt pos "Begin and end tags don't match.";
(EFold, pos))
end)
| LBRACE eexp RBRACE (eexp)
@@ -878,10 +899,11 @@ tag : tagHead attrs (let
end)
tagHead: BEGIN_TAG (let
+ val bt = tagIn BEGIN_TAG
val pos = s (BEGIN_TAGleft, BEGIN_TAGright)
in
- (BEGIN_TAG,
- (EVar ([], BEGIN_TAG), pos))
+ (bt,
+ (EVar ([], bt), pos))
end)
| tagHead LBRACE cexp RBRACE (#1 tagHead, (ECApp (#2 tagHead, cexp), s (tagHeadleft, RBRACEright)))
diff --git a/tests/crud.ur b/tests/crud.ur
new file mode 100644
index 00000000..101b1ba4
--- /dev/null
+++ b/tests/crud.ur
@@ -0,0 +1,40 @@
+functor Make(M : sig
+ con cols :: {Type}
+ constraint [Id] ~ cols
+ val tab : sql_table ([Id = int] ++ cols)
+
+ val title : string
+
+ val cols : $(mapTT (fn t => {Show : t -> xbody}) cols)
+end) = struct
+
+open constraints M
+val tab = M.tab
+
+fun list () =
+ rows <- query (SELECT * FROM tab AS T)
+ (fn fs acc => return <body>
+ {acc} <tr> <td>{txt _ fs.T.Id}</td> </tr>
+ </body>) <body></body>;
+ return <html><head>
+ <title>List</title>
+
+ </head><body>
+
+ <h1>List</h1>
+
+ <table border={1}>
+ <tr> <th>ID</th> </tr>
+ {rows}
+ </table>
+ </body></html>
+
+fun main () : transaction page = return <html><head>
+ <title>{cdata M.title}</title>
+ </head><body>
+ <h1>{cdata M.title}</h1>
+
+ <li> <a link={list ()}>List all rows</a></li>
+</body></html>
+
+end
diff --git a/tests/crud.urs b/tests/crud.urs
new file mode 100644
index 00000000..5f2ae695
--- /dev/null
+++ b/tests/crud.urs
@@ -0,0 +1,11 @@
+functor Make(M : sig
+ con cols :: {Type}
+ constraint [Id] ~ cols
+ val tab : sql_table ([Id = int] ++ cols)
+
+ val title : string
+
+ val cols : $(mapTT (fn t => {Show : t -> xbody}) cols)
+end) : sig
+ val main : unit -> transaction page
+end
diff --git a/tests/crud1.ur b/tests/crud1.ur
new file mode 100644
index 00000000..2253d459
--- /dev/null
+++ b/tests/crud1.ur
@@ -0,0 +1,14 @@
+table t1 : {Id : int, A : int, B : string, C : float, D : bool}
+
+open Crud.Make(struct
+ val tab = t1
+
+ val title = "Crud1"
+
+ val cols = {
+ A = {Show = txt _},
+ B = {Show = txt _},
+ C = {Show = txt _},
+ D = {Show = txt _}
+ }
+end)
diff --git a/tests/crud1.urp b/tests/crud1.urp
new file mode 100644
index 00000000..5920f354
--- /dev/null
+++ b/tests/crud1.urp
@@ -0,0 +1,7 @@
+debug
+database dbname=test
+exe /tmp/webapp
+sql /tmp/urweb.sql
+
+crud
+crud1
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-29 05:31:35 +0000