# HG changeset patch # User Adam Chlipala # Date 1221169312 14400 # Node ID e457d8972ff1b538133cddd02e691211ae2eb531 # Parent b91480c9a729240083a9aafee650636ec985eeb7 Crud listing IDs diff -r b91480c9a729 -r e457d8972ff1 lib/basis.urs --- a/lib/basis.urs Thu Sep 11 13:06:51 2008 -0400 +++ b/lib/basis.urs Thu Sep 11 17:41:52 2008 -0400 @@ -250,6 +250,7 @@ con xhtml = xml [Html] con page = xhtml [] [] +con xbody = xml [Body] [] [] (*** HTML details *) @@ -304,6 +305,13 @@ -> 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 -r b91480c9a729 -r e457d8972ff1 lib/top.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/top.ur Thu Sep 11 17:41:52 2008 -0400 @@ -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 -r b91480c9a729 -r e457d8972ff1 lib/top.urs --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/top.urs Thu Sep 11 17:41:52 2008 -0400 @@ -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 -r b91480c9a729 -r e457d8972ff1 src/cjr_print.sml --- a/src/cjr_print.sml Thu Sep 11 13:06:51 2008 -0400 +++ b/src/cjr_print.sml Thu Sep 11 17:41:52 2008 -0400 @@ -738,6 +738,7 @@ 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 @@ 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 -r b91480c9a729 -r e457d8972ff1 src/compiler.sml --- a/src/compiler.sml Thu Sep 11 13:06:51 2008 -0400 +++ b/src/compiler.sml Thu Sep 11 17:41:52 2008 -0400 @@ -355,8 +355,10 @@ 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 -r b91480c9a729 -r e457d8972ff1 src/elaborate.sig --- a/src/elaborate.sig Thu Sep 11 13:06:51 2008 -0400 +++ b/src/elaborate.sig Thu Sep 11 17:41:52 2008 -0400 @@ -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 -r b91480c9a729 -r e457d8972ff1 src/elaborate.sml --- a/src/elaborate.sml Thu Sep 11 13:06:51 2008 -0400 +++ b/src/elaborate.sml Thu Sep 11 17:41:52 2008 -0400 @@ -2805,6 +2805,98 @@ 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 @@ 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 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 @@ | 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 @@ (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 @@ 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 @@ 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 -r b91480c9a729 -r e457d8972ff1 src/monoize.sml --- a/src/monoize.sml Thu Sep 11 13:06:51 2008 -0400 +++ b/src/monoize.sml Thu Sep 11 17:41:52 2008 -0400 @@ -1372,6 +1372,7 @@ | "loption" => normal ("option", NONE) + | "tabl" => normal ("table", NONE) | _ => normal (tag, NONE) end diff -r b91480c9a729 -r e457d8972ff1 src/unpoly.sml --- a/src/unpoly.sml Thu Sep 11 13:06:51 2008 -0400 +++ b/src/unpoly.sml Thu Sep 11 17:41:52 2008 -0400 @@ -56,7 +56,19 @@ 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 @@ 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 -r b91480c9a729 -r e457d8972ff1 src/urweb.grm --- a/src/urweb.grm Thu Sep 11 13:06:51 2008 -0400 +++ b/src/urweb.grm Thu Sep 11 17:41:52 2008 -0400 @@ -152,6 +152,11 @@ val inDml = ref false +fun tagIn bt = + case bt of + "table" => "tabl" + | _ => bt + %% %header (functor UrwebLrValsFn(structure Token : TOKEN)) @@ -187,7 +192,7 @@ %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 @@ 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 @@ 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 @@ | 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 @@ 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 -r b91480c9a729 -r e457d8972ff1 tests/crud.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/crud.ur Thu Sep 11 17:41:52 2008 -0400 @@ -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 + {acc} {txt _ fs.T.Id} + ) ; + return + List + + + +

List

+ + + + {rows} +
ID
+ + +fun main () : transaction page = return + {cdata M.title} + +

{cdata M.title}

+ +
  • List all rows
    • + + +end diff -r b91480c9a729 -r e457d8972ff1 tests/crud.urs --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/crud.urs Thu Sep 11 17:41:52 2008 -0400 @@ -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 -r b91480c9a729 -r e457d8972ff1 tests/crud1.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/crud1.ur Thu Sep 11 17:41:52 2008 -0400 @@ -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 -r b91480c9a729 -r e457d8972ff1 tests/crud1.urp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/crud1.urp Thu Sep 11 17:41:52 2008 -0400 @@ -0,0 +1,7 @@ +debug +database dbname=test +exe /tmp/webapp +sql /tmp/urweb.sql + +crud +crud1