From 0f298a5396cf95f4e58988583f862a4b97444bec Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 28 Apr 2009 17:26:53 -0400 Subject: Subforms --- CHANGELOG | 1 + demo/form.urp | 1 + include/types.h | 1 + include/urweb.h | 6 +- lib/ur/basis.urs | 13 +++- src/c/urweb.c | 139 ++++++++++++++++++++++++++++++++++++++----- src/cjr_print.sml | 173 ++++++++++++++++++++++++++++++++++++++---------------- src/monoize.sml | 15 +++++ src/urweb.grm | 11 ++-- tests/subform.ur | 16 +++++ tests/subform.urp | 3 + tests/subform.urs | 1 + 12 files changed, 303 insertions(+), 77 deletions(-) create mode 100644 tests/subform.ur create mode 100644 tests/subform.urp create mode 100644 tests/subform.urs diff --git a/CHANGELOG b/CHANGELOG index 3a7d1de8..ebd60637 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -11,6 +11,7 @@ Next - Blobs and HTTP file upload - SQL outer joins - SQL views +- Subforms ======== 20090405 diff --git a/demo/form.urp b/demo/form.urp index 73356d49..f28331fc 100644 --- a/demo/form.urp +++ b/demo/form.urp @@ -1,2 +1,3 @@ +debug form diff --git a/include/types.h b/include/types.h index 71a5ee0f..ddf17552 100644 --- a/include/types.h +++ b/include/types.h @@ -35,6 +35,7 @@ typedef struct uw_Basis_file { 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 --git a/include/urweb.h b/include/urweb.h index 51ab9149..c5381fa8 100644 --- a/include/urweb.h +++ b/include/urweb.h @@ -41,11 +41,13 @@ void uw_memstats(uw_context); 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 --git a/lib/ur/basis.urs b/lib/ur/basis.urs index ec31e57f..1881bec3 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -555,9 +555,16 @@ val a : bodyTag [Link = transaction page, Href = url, Onclick = transaction unit 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 --git a/src/c/urweb.c b/src/c/urweb.c index 1d6b804f..fc8b82c9 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -284,14 +284,17 @@ typedef struct { } 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 @@ struct uw_context { 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 @@ uw_context uw_init() { 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 @@ void uw_free(uw_context ctx) { 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_free(uw_context ctx) { } 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_keep_request(uw_context ctx) { 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 @@ char *uw_error_message(uw_context ctx) { 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 (!strcasecmp(name, ".b")) { + size_t i; + int n = uw_input_num(value); + input *inps; - if (n < 0) - uw_error(ctx, FATAL, "Bad input name %s", name); + if (n < 0) + uw_error(ctx, FATAL, "Bad subform name %s", value); - if (n >= uw_inputs_len) - uw_error(ctx, FATAL, "For input name %s, index %d is out of range", name, n); + 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); - ctx->inputs[n].kind = NORMAL; - ctx->inputs[n].data.normal = value; + 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 @@ char *uw_get_input(uw_context ctx, int n) { 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 @@ char *uw_get_optional_input(uw_context ctx, int n) { 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 @@ uw_Basis_file uw_get_file_input(uw_context ctx, int n) { 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 @@ uw_Basis_file uw_get_file_input(uw_context ctx, int n) { 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 --git a/src/cjr_print.sml b/src/cjr_print.sml index a09dd7f6..7928ec5e 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -2340,31 +2340,50 @@ fun p_file env (ds, ps) = 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 @@ fun p_file env (ds, ps) = 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 @@ fun p_file env (ds, ps) = 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 --git a/src/monoize.sml b/src/monoize.sml index a2048a7d..ea191802 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -2686,6 +2686,21 @@ fun monoExp (env, st, fm) (all as (e, loc)) = 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 --git a/src/urweb.grm b/src/urweb.grm index da817ab3..55a38c57 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -280,7 +280,7 @@ datatype attr = Class of exp | Normal of con * exp | 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 @@ xmlOne : NOTAGS (EApp ((EVar (["Basis"], "cdata", Infer) 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 @@ xmlOne : NOTAGS (EApp ((EVar (["Basis"], "cdata", Infer) 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 @@ tag : tagHead attrs (let val e = (EApp (e, (EApp (#2 tagHead, (ERecord [], pos)), pos)), pos) in - (#1 tagHead, e) + (tagHead, e) end) tagHead: BEGIN_TAG (let diff --git a/tests/subform.ur b/tests/subform.ur new file mode 100644 index 00000000..2ab1f1a3 --- /dev/null +++ b/tests/subform.ur @@ -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 --git a/tests/subform.urp b/tests/subform.urp new file mode 100644 index 00000000..52f6a752 --- /dev/null +++ b/tests/subform.urp @@ -0,0 +1,3 @@ +debug + +subform diff --git a/tests/subform.urs b/tests/subform.urs new file mode 100644 index 00000000..6ac44e0b --- /dev/null +++ b/tests/subform.urs @@ -0,0 +1 @@ +val main : unit -> transaction page -- cgit v1.2.3