# HG changeset patch # User Adam Chlipala # Date 1240954013 14400 # Node ID 8ce31c052dce6cbbfa3388d1ac8be71bbdc950d9 # Parent 58d8f877e1eeb3b3ef65530fc9fc824caf10a18b Subforms diff -r 58d8f877e1ee -r 8ce31c052dce CHANGELOG --- a/CHANGELOG Tue Apr 28 15:15:21 2009 -0400 +++ b/CHANGELOG Tue Apr 28 17:26:53 2009 -0400 @@ -11,6 +11,7 @@ - Blobs and HTTP file upload - SQL outer joins - SQL views +- Subforms ======== 20090405 diff -r 58d8f877e1ee -r 8ce31c052dce demo/form.urp --- a/demo/form.urp Tue Apr 28 15:15:21 2009 -0400 +++ b/demo/form.urp Tue Apr 28 17:26:53 2009 -0400 @@ -1,2 +1,3 @@ +debug form diff -r 58d8f877e1ee -r 8ce31c052dce include/types.h --- a/include/types.h Tue Apr 28 15:15:21 2009 -0400 +++ b/include/types.h Tue Apr 28 17:26:53 2009 -0400 @@ -35,6 +35,7 @@ typedef enum { SUCCESS, FATAL, BOUNDED_RETRY, UNLIMITED_RETRY, RETURN_BLOB } failure_kind; +typedef struct input *uw_input; #define INTS_MAX 50 #define FLOATS_MAX 100 diff -r 58d8f877e1ee -r 8ce31c052dce include/urweb.h --- a/include/urweb.h Tue Apr 28 15:15:21 2009 -0400 +++ b/include/urweb.h Tue Apr 28 17:26:53 2009 -0400 @@ -41,11 +41,13 @@ int uw_send(uw_context, int sock); void uw_set_input(uw_context, const char *name, char *value); +void uw_set_file_input(uw_context, char *name, uw_Basis_file); + char *uw_get_input(uw_context, int name); char *uw_get_optional_input(uw_context, int name); - -void uw_set_file_input(uw_context, char *name, uw_Basis_file); uw_Basis_file uw_get_file_input(uw_context, int name); +void uw_enter_subform(uw_context, int name); +void uw_leave_subform(uw_context); void uw_write(uw_context, const char*); diff -r 58d8f877e1ee -r 8ce31c052dce lib/ur/basis.urs --- a/lib/ur/basis.urs Tue Apr 28 15:15:21 2009 -0400 +++ b/lib/ur/basis.urs Tue Apr 28 17:26:53 2009 -0400 @@ -555,9 +555,16 @@ val img : bodyTag [Src = url] val form : ctx ::: {Unit} -> bind ::: {Type} - -> [[Body] ~ ctx] => - xml form [] bind - -> xml ([Body] ++ ctx) [] [] + -> [[Body] ~ ctx] => + xml form [] bind + -> xml ([Body] ++ ctx) [] [] + +val subform : ctx ::: {Unit} -> use ::: {Type} -> bind ::: {Type} + -> [[Form] ~ ctx] => + nm :: Name -> [[nm] ~ use] => + xml form [] bind + -> xml ([Form] ++ ctx) use [nm = $bind] + con formTag = fn (ty :: Type) (inner :: {Unit}) (attrs :: {Type}) => ctx ::: {Unit} -> [[Form] ~ ctx] => diff -r 58d8f877e1ee -r 8ce31c052dce src/c/urweb.c --- a/src/c/urweb.c Tue Apr 28 15:15:21 2009 -0400 +++ b/src/c/urweb.c Tue Apr 28 17:26:53 2009 -0400 @@ -284,14 +284,17 @@ } delta; typedef enum { - UNSET, NORMAL, FIL + UNSET, NORMAL, FIL, SUBFORM } input_kind; -typedef struct { +typedef struct input { input_kind kind; union { char *normal; uw_Basis_file file; + struct { + struct input *fields, *prev; + } subform; } data; } input; @@ -299,7 +302,8 @@ char *headers, *headers_end; buf outHeaders, page, heap, script; - input *inputs; + input *inputs, *subinputs, *cur_inputs; + size_t n_subinputs, used_subinputs; int source_count; @@ -339,6 +343,9 @@ ctx->script.start[0] = 0; ctx->inputs = calloc(uw_inputs_len, sizeof(input)); + ctx->cur_inputs = NULL; + ctx->subinputs = malloc(0); + ctx->n_subinputs = ctx->used_subinputs = 0; ctx->db = NULL; @@ -383,6 +390,7 @@ buf_free(&ctx->page); buf_free(&ctx->heap); free(ctx->inputs); + free(ctx->subinputs); free(ctx->cleanup); for (i = 0; i < ctx->n_deltas; ++i) @@ -392,6 +400,8 @@ } void uw_reset_keep_error_message(uw_context ctx) { + size_t i; + buf_reset(&ctx->outHeaders); buf_reset(&ctx->script); ctx->script.start[0] = 0; @@ -412,6 +422,9 @@ void uw_reset(uw_context ctx) { uw_reset_keep_request(ctx); memset(ctx->inputs, 0, uw_inputs_len * sizeof(input)); + memset(ctx->subinputs, 0, ctx->n_subinputs * sizeof(input)); + ctx->cur_inputs = NULL; + ctx->used_subinputs = 0; } void uw_db_init(uw_context); @@ -564,17 +577,72 @@ extern int uw_input_num(const char*); +#define INP(ctx) (ctx->cur_inputs ? ctx->cur_inputs : ctx->inputs) + void uw_set_input(uw_context ctx, const char *name, char *value) { - int n = uw_input_num(name); - - if (n < 0) - uw_error(ctx, FATAL, "Bad input name %s", name); - - if (n >= uw_inputs_len) - uw_error(ctx, FATAL, "For input name %s, index %d is out of range", name, n); - - ctx->inputs[n].kind = NORMAL; - ctx->inputs[n].data.normal = value; + if (!strcasecmp(name, ".b")) { + size_t i; + int n = uw_input_num(value); + input *inps; + + if (n < 0) + uw_error(ctx, FATAL, "Bad subform name %s", value); + + if (n >= uw_inputs_len) + uw_error(ctx, FATAL, "For subform name %s, index %d is out of range", value, n); + + if (ctx->used_subinputs + uw_inputs_len >= ctx->n_subinputs) { + input *new_subinputs = realloc(ctx->subinputs, sizeof(input) * (ctx->used_subinputs + uw_inputs_len)); + size_t offset = new_subinputs - ctx->subinputs; + + for (i = 0; i < ctx->used_subinputs; ++i) + if (new_subinputs[i].kind == SUBFORM) { + new_subinputs[i].data.subform.fields += offset; + if (new_subinputs[i].data.subform.prev != NULL) + new_subinputs[i].data.subform.prev += offset; + } + + for (i = 0; i < uw_inputs_len; ++i) + if (ctx->inputs[i].kind == SUBFORM) { + ctx->inputs[i].data.subform.fields += offset; + if (ctx->inputs[i].data.subform.prev != NULL) + ctx->inputs[i].data.subform.prev += offset; + } + + if (ctx->cur_inputs != NULL) + ctx->cur_inputs += offset; + + ctx->n_subinputs = ctx->used_subinputs + uw_inputs_len; + ctx->subinputs = new_subinputs; + } + + ctx->inputs[n].kind = SUBFORM; + ctx->inputs[n].data.subform.prev = ctx->cur_inputs; + ctx->cur_inputs = ctx->inputs[n].data.subform.fields = &ctx->subinputs[ctx->used_subinputs]; + + for (i = 0; i < uw_inputs_len; ++i) + ctx->subinputs[ctx->used_subinputs++].kind = UNUSED; + } else if (!strcasecmp(name, ".e")) { + input *tmp; + + if (ctx->cur_inputs == NULL) + uw_error(ctx, FATAL, "Unmatched subform closer"); + + tmp = ctx->cur_inputs; + ctx->cur_inputs = tmp->data.subform.prev; + tmp->data.subform.prev = NULL; + } else { + int n = uw_input_num(name); + + if (n < 0) + uw_error(ctx, FATAL, "Bad input name %s", name); + + if (n >= uw_inputs_len) + uw_error(ctx, FATAL, "For input name %s, index %d is out of range", name, n); + + INP(ctx)[n].kind = NORMAL; + INP(ctx)[n].data.normal = value; + } } char *uw_get_input(uw_context ctx, int n) { @@ -583,13 +651,15 @@ if (n >= uw_inputs_len) uw_error(ctx, FATAL, "Out-of-bounds input index %d", n); - switch (ctx->inputs[n].kind) { + switch (INP(ctx)[n].kind) { case UNSET: return NULL; case FIL: uw_error(ctx, FATAL, "Tried to read a file form input as normal"); + case SUBFORM: + uw_error(ctx, FATAL, "Tried to read a subform form input as normal"); case NORMAL: - return ctx->inputs[n].data.normal; + return INP(ctx)[n].data.normal; default: uw_error(ctx, FATAL, "Impossible input kind"); } @@ -601,13 +671,15 @@ if (n >= uw_inputs_len) uw_error(ctx, FATAL, "Out-of-bounds input index %d", n); - switch (ctx->inputs[n].kind) { + switch (INP(ctx)[n].kind) { case UNSET: return ""; case FIL: uw_error(ctx, FATAL, "Tried to read a file form input as normal"); + case SUBFORM: + uw_error(ctx, FATAL, "Tried to read a subform form input as normal"); case NORMAL: - return ctx->inputs[n].data.normal; + return INP(ctx)[n].data.normal; default: uw_error(ctx, FATAL, "Impossible input kind"); } @@ -634,7 +706,7 @@ if (n >= uw_inputs_len) uw_error(ctx, FATAL, "Out-of-bounds file input index %d", n); - switch (ctx->inputs[n].kind) { + switch (INP(ctx)[n].kind) { case UNSET: { char *data = uw_malloc(ctx, 0); @@ -642,14 +714,49 @@ return f; } case FIL: - return ctx->inputs[n].data.file; + return INP(ctx)[n].data.file; case NORMAL: uw_error(ctx, FATAL, "Tried to read a normal form input as files"); + case SUBFORM: + uw_error(ctx, FATAL, "Tried to read a subform form input as files"); default: uw_error(ctx, FATAL, "Impossible input kind"); } } +void uw_enter_subform(uw_context ctx, int n) { + if (n < 0) + uw_error(ctx, FATAL, "Negative subform index %d", n); + if (n >= uw_inputs_len) + uw_error(ctx, FATAL, "Out-of-bounds subform index %d", n); + + switch (INP(ctx)[n].kind) { + case UNSET: + uw_error(ctx, FATAL, "Missing subform"); + case FIL: + uw_error(ctx, FATAL, "Tried to read a file form input as subform"); + case NORMAL: + uw_error(ctx, FATAL, "Tried to read a normal form input as subform"); + case SUBFORM: + INP(ctx)[n].data.subform.prev = ctx->cur_inputs; + ctx->cur_inputs = INP(ctx)[n].data.subform.fields; + return; + default: + uw_error(ctx, FATAL, "Impossible input kind"); + } +} + +void uw_leave_subform(uw_context ctx) { + input *tmp; + + if (ctx->cur_inputs == NULL) + uw_error(ctx, FATAL, "Unmatched uw_leave_subform"); + + tmp = ctx->cur_inputs; + ctx->cur_inputs = tmp->data.subform.prev; + tmp->data.subform.prev = NULL; +} + void uw_set_script_header(uw_context ctx, const char *s) { ctx->script_header = s; } diff -r 58d8f877e1ee -r 8ce31c052dce src/cjr_print.sml --- a/src/cjr_print.sml Tue Apr 28 15:15:21 2009 -0400 +++ b/src/cjr_print.sml Tue Apr 28 17:26:53 2009 -0400 @@ -2340,31 +2340,50 @@ E.declBinds env d)) env ds + fun flatFields (t : typ) = + case #1 t of + TRecord i => + let + val xts = E.lookupStruct env i + in + SOME (map #1 xts :: List.concat (List.mapPartial (flatFields o #2) xts)) + end + | _ => NONE + val fields = foldl (fn ((ek, _, _, ts, _, _), fields) => case ek of Link => fields | Rpc _ => fields | Action eff => case List.nth (ts, length ts - 2) of - (TRecord i, _) => + (TRecord i, loc) => let val xts = E.lookupStruct env i val xts = case eff of ReadCookieWrite => (sigName xts, (TRecord 0, ErrorMsg.dummySpan)) :: xts | _ => xts - val xtsSet = SS.addList (SS.empty, map #1 xts) in - foldl (fn ((x, _), fields) => - let - val xtsSet' = Option.getOpt (SM.find (fields, x), SS.empty) - in - SM.insert (fields, x, SS.union (SS.delete (xtsSet, x), - xtsSet')) - end) fields xts + case flatFields (TRecord i, loc) of + NONE => raise Fail "CjrPrint: flatFields impossible" + | SOME fields' => List.revAppend (fields', fields) end | _ => raise Fail "CjrPrint: Last argument of action isn't record") - SM.empty ps + [] ps + + val fields = foldl (fn (xts, fields) => + let + val xtsSet = SS.addList (SS.empty, xts) + in + foldl (fn (x, fields) => + let + val xtsSet' = Option.getOpt (SM.find (fields, x), SS.empty) + in + SM.insert (fields, x, SS.union (SS.delete (xtsSet, x), + xtsSet')) + end) fields xts + end) + SM.empty fields val fnums = SM.foldli (fn (x, xs, fnums) => let @@ -2467,6 +2486,97 @@ string "}"] end + fun getInput (x, t) = + let + val n = case SM.find (fnums, x) of + NONE => raise Fail "CjrPrint: Can't find in fnums" + | SOME n => n + + val f = case t of + (TFfi ("Basis", "bool"), _) => "optional_" + | _ => "" + in + if isFile t then + box [string "uw_input_", + p_ident x, + space, + string "=", + space, + string "uw_get_file_input(ctx, ", + string (Int.toString n), + string ");", + newline] + else case #1 t of + TRecord i => + let + val xts = E.lookupStruct env i + in + box [string "uw_enter_subform(ctx, ", + string (Int.toString n), + string ");", + newline, + string "uw_input_", + p_ident x, + space, + string "=", + space, + string "({", + box [p_typ env t, + space, + string "result;", + newline, + p_list_sep (box []) + (fn (x, t) => + box [p_typ env t, + space, + string "uw_input_", + string x, + string ";", + newline]) + xts, + newline, + p_list_sep (box []) (fn (x, t) => + box [getInput (x, t), + string "result.__uwf_", + string x, + space, + string "=", + space, + string "uw_input_", + string x, + string ";", + newline]) + xts, + newline, + string "result;", + newline], + string "});", + newline, + string "uw_leave_subform(ctx);"] + end + | _ => + box [string "request = uw_get_", + string f, + string "input(ctx, ", + string (Int.toString n), + string ");", + newline, + string "if (request == NULL)", + newline, + box [string "uw_error(ctx, FATAL, \"Missing input ", + string x, + string "\");"], + newline, + string "uw_input_", + p_ident x, + space, + string "=", + space, + unurlify env t, + string ";", + newline] + end + fun p_page (ek, s, n, ts, ran, side) = let val (ts, defInputs, inputsVar, fields) = @@ -2487,48 +2597,7 @@ string ";", newline]) xts), newline, - box (map (fn (x, t) => - let - val n = case SM.find (fnums, x) of - NONE => raise Fail "CjrPrint: Can't find in fnums" - | SOME n => n - - val f = case t of - (TFfi ("Basis", "bool"), _) => "optional_" - | _ => "" - in - if isFile t then - box [string "uw_input_", - p_ident x, - space, - string "=", - space, - string "uw_get_file_input(ctx, ", - string (Int.toString n), - string ");", - newline] - else - box [string "request = uw_get_", - string f, - string "input(ctx, ", - string (Int.toString n), - string ");", - newline, - string "if (request == NULL)", - newline, - box [string "uw_error(ctx, FATAL, \"Missing input ", - string x, - string "\");"], - newline, - string "uw_input_", - p_ident x, - space, - string "=", - space, - unurlify env t, - string ";", - newline] - end) xts), + box (map getInput xts), string "struct __uws_", string (Int.toString i), space, diff -r 58d8f877e1ee -r 8ce31c052dce src/monoize.sml --- a/src/monoize.sml Tue Apr 28 15:15:21 2009 -0400 +++ b/src/monoize.sml Tue Apr 28 17:26:53 2009 -0400 @@ -2686,6 +2686,21 @@ fm) end + | L.ECApp ((L.ECApp ((L.ECApp ((L.ECApp ( + (L.EFfi ("Basis", "subform"), _), _), _), _), + _), _), _), (L.CName nm, loc)) => + let + val s = (L'.TFfi ("Basis", "string"), loc) + in + ((L'.EAbs ("xml", s, s, + strcat [(L'.EPrim (Prim.String ("")), loc), + (L'.ERel 0, loc), + (L'.EPrim (Prim.String ("")), loc)]), + loc), + fm) + end + | L.EApp ((L.ECApp ( (L.ECApp ( (L.ECApp ( diff -r 58d8f877e1ee -r 8ce31c052dce src/urweb.grm --- a/src/urweb.grm Tue Apr 28 15:15:21 2009 -0400 +++ b/src/urweb.grm Tue Apr 28 17:26:53 2009 -0400 @@ -280,7 +280,7 @@ | rexp of (con * exp) list | xml of exp | xmlOne of exp - | tag of string * exp + | tag of (string * exp) * exp | tagHead of string * exp | bind of string * con option * exp | edecl of edecl @@ -1240,7 +1240,7 @@ val pos = s (tagleft, GTright) val cdata = - if #1 tag = "submit" orelse #1 tag = "dyn" then + if #1 (#1 tag) = "submit" orelse #1 (#1 tag) = "dyn" then let val e = (EVar (["Basis"], "cdata", DontInfer), pos) val e = (ECApp (e, (CWild (KWild, pos), pos)), pos) @@ -1261,10 +1261,13 @@ val pos = s (tagleft, GTright) val et = tagIn END_TAG in - if #1 tag = et then + if #1 (#1 tag) = et then if et = "form" then (EApp ((EVar (["Basis"], "form", Infer), pos), xml), pos) + else if et = "subform" then + (EApp ((EDisjointApp (#2 (#1 tag)), pos), + xml), pos) else (EApp (#2 tag, xml), pos) else @@ -1295,7 +1298,7 @@ val e = (EApp (e, (EApp (#2 tagHead, (ERecord [], pos)), pos)), pos) in - (#1 tagHead, e) + (tagHead, e) end) tagHead: BEGIN_TAG (let diff -r 58d8f877e1ee -r 8ce31c052dce tests/subform.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/subform.ur Tue Apr 28 17:26:53 2009 -0400 @@ -0,0 +1,16 @@ +fun handler r = return + {[r.A]}, {[r.Sub.A]}, {[r.Sub.B]}, {[r.Sub.Sub]}, {[r.C]} + + +fun main () = return +
+
+ +
+
+
+ +
+ + +
 diff -r 58d8f877e1ee -r 8ce31c052dce tests/subform.urp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/subform.urp Tue Apr 28 17:26:53 2009 -0400 @@ -0,0 +1,3 @@ +debug + +subform diff -r 58d8f877e1ee -r 8ce31c052dce tests/subform.urs --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/subform.urs Tue Apr 28 17:26:53 2009 -0400 @@ -0,0 +1,1 @@ +val main : unit -> transaction page