summaryrefslogtreecommitdiff
path: root/src/cjr_print.sml
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2009-04-28 17:26:53 -0400
committerGravatar Adam Chlipala <adamc@hcoop.net>2009-04-28 17:26:53 -0400
commit0264695e9a76f87e6164c489c34af63fa893889d (patch)
treecfce730aeca8d6832d9ec09d1e4d3450f85a444d /src/cjr_print.sml
parent243ec1bee9539195d85bfa8928c84ead412f2413 (diff)
Subforms
Diffstat (limited to 'src/cjr_print.sml')
-rw-r--r--src/cjr_print.sml173
1 files changed, 121 insertions, 52 deletions
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,