Mercurial > urweb

comparison src/cjr_print.sml @ 756:8ce31c052dce

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Subforms
author Adam Chlipala <adamc@hcoop.net>
date Tue, 28 Apr 2009 17:26:53 -0400
parents 8688e01ae469
children fa2019a63ea4
comparison
equal deleted inserted replaced
755:58d8f877e1ee 756:8ce31c052dce
2338 val (pds, env) = ListUtil.foldlMap (fn (d, env) => 2338 val (pds, env) = ListUtil.foldlMap (fn (d, env) =>
2339 (p_decl env d, 2339 (p_decl env d,
2340 E.declBinds env d)) 2340 E.declBinds env d))
2341 env ds 2341 env ds
2342 2342
2343 fun flatFields (t : typ) =
2344 case #1 t of
2345 TRecord i =>
2346 let
2347 val xts = E.lookupStruct env i
2348 in
2349 SOME (map #1 xts :: List.concat (List.mapPartial (flatFields o #2) xts))
2350 end
2351 | _ => NONE
2352
2343 val fields = foldl (fn ((ek, _, _, ts, _, _), fields) => 2353 val fields = foldl (fn ((ek, _, _, ts, _, _), fields) =>
2344 case ek of 2354 case ek of
2345 Link => fields 2355 Link => fields
2346 | Rpc _ => fields 2356 | Rpc _ => fields
2347 | Action eff => 2357 | Action eff =>
2348 case List.nth (ts, length ts - 2) of 2358 case List.nth (ts, length ts - 2) of
2349 (TRecord i, _) => 2359 (TRecord i, loc) =>
2350 let 2360 let
2351 val xts = E.lookupStruct env i 2361 val xts = E.lookupStruct env i
2352 val xts = case eff of 2362 val xts = case eff of
2353 ReadCookieWrite => 2363 ReadCookieWrite =>
2354 (sigName xts, (TRecord 0, ErrorMsg.dummySpan)) :: xts 2364 (sigName xts, (TRecord 0, ErrorMsg.dummySpan)) :: xts
2355 | _ => xts 2365 | _ => xts
2356 val xtsSet = SS.addList (SS.empty, map #1 xts)
2357 in 2366 in
2358 foldl (fn ((x, _), fields) => 2367 case flatFields (TRecord i, loc) of
2359 let 2368 NONE => raise Fail "CjrPrint: flatFields impossible"
2360 val xtsSet' = Option.getOpt (SM.find (fields, x), SS.empty) 2369 | SOME fields' => List.revAppend (fields', fields)
2361 in
2362 SM.insert (fields, x, SS.union (SS.delete (xtsSet, x),
2363 xtsSet'))
2364 end) fields xts
2365 end 2370 end
2366 | _ => raise Fail "CjrPrint: Last argument of action isn't record") 2371 | _ => raise Fail "CjrPrint: Last argument of action isn't record")
2367 SM.empty ps 2372 [] ps
2373
2374 val fields = foldl (fn (xts, fields) =>
2375 let
2376 val xtsSet = SS.addList (SS.empty, xts)
2377 in
2378 foldl (fn (x, fields) =>
2379 let
2380 val xtsSet' = Option.getOpt (SM.find (fields, x), SS.empty)
2381 in
2382 SM.insert (fields, x, SS.union (SS.delete (xtsSet, x),
2383 xtsSet'))
2384 end) fields xts
2385 end)
2386 SM.empty fields
2368 2387
2369 val fnums = SM.foldli (fn (x, xs, fnums) => 2388 val fnums = SM.foldli (fn (x, xs, fnums) =>
2370 let 2389 let
2371 val unusable = SS.foldl (fn (x', unusable) => 2390 val unusable = SS.foldl (fn (x', unusable) =>
2372 case SM.find (fnums, x') of 2391 case SM.find (fnums, x') of
2465 string "-1;", 2484 string "-1;",
2466 newline, 2485 newline,
2467 string "}"] 2486 string "}"]
2468 end 2487 end
2469 2488
2489 fun getInput (x, t) =
2490 let
2491 val n = case SM.find (fnums, x) of
2492 NONE => raise Fail "CjrPrint: Can't find in fnums"
2493 | SOME n => n
2494
2495 val f = case t of
2496 (TFfi ("Basis", "bool"), _) => "optional_"
2497 | _ => ""
2498 in
2499 if isFile t then
2500 box [string "uw_input_",
2501 p_ident x,
2502 space,
2503 string "=",
2504 space,
2505 string "uw_get_file_input(ctx, ",
2506 string (Int.toString n),
2507 string ");",
2508 newline]
2509 else case #1 t of
2510 TRecord i =>
2511 let
2512 val xts = E.lookupStruct env i
2513 in
2514 box [string "uw_enter_subform(ctx, ",
2515 string (Int.toString n),
2516 string ");",
2517 newline,
2518 string "uw_input_",
2519 p_ident x,
2520 space,
2521 string "=",
2522 space,
2523 string "({",
2524 box [p_typ env t,
2525 space,
2526 string "result;",
2527 newline,
2528 p_list_sep (box [])
2529 (fn (x, t) =>
2530 box [p_typ env t,
2531 space,
2532 string "uw_input_",
2533 string x,
2534 string ";",
2535 newline])
2536 xts,
2537 newline,
2538 p_list_sep (box []) (fn (x, t) =>
2539 box [getInput (x, t),
2540 string "result.__uwf_",
2541 string x,
2542 space,
2543 string "=",
2544 space,
2545 string "uw_input_",
2546 string x,
2547 string ";",
2548 newline])
2549 xts,
2550 newline,
2551 string "result;",
2552 newline],
2553 string "});",
2554 newline,
2555 string "uw_leave_subform(ctx);"]
2556 end
2557 | _ =>
2558 box [string "request = uw_get_",
2559 string f,
2560 string "input(ctx, ",
2561 string (Int.toString n),
2562 string ");",
2563 newline,
2564 string "if (request == NULL)",
2565 newline,
2566 box [string "uw_error(ctx, FATAL, \"Missing input ",
2567 string x,
2568 string "\");"],
2569 newline,
2570 string "uw_input_",
2571 p_ident x,
2572 space,
2573 string "=",
2574 space,
2575 unurlify env t,
2576 string ";",
2577 newline]
2578 end
2579
2470 fun p_page (ek, s, n, ts, ran, side) = 2580 fun p_page (ek, s, n, ts, ran, side) =
2471 let 2581 let
2472 val (ts, defInputs, inputsVar, fields) = 2582 val (ts, defInputs, inputsVar, fields) =
2473 case ek of 2583 case ek of
2474 Core.Link => (List.take (ts, length ts - 1), string "", string "", NONE) 2584 Core.Link => (List.take (ts, length ts - 1), string "", string "", NONE)
2485 string "uw_input_", 2595 string "uw_input_",
2486 p_ident x, 2596 p_ident x,
2487 string ";", 2597 string ";",
2488 newline]) xts), 2598 newline]) xts),
2489 newline, 2599 newline,
2490 box (map (fn (x, t) => 2600 box (map getInput xts),
2491 let
2492 val n = case SM.find (fnums, x) of
2493 NONE => raise Fail "CjrPrint: Can't find in fnums"
2494 | SOME n => n
2495
2496 val f = case t of
2497 (TFfi ("Basis", "bool"), _) => "optional_"
2498 | _ => ""
2499 in
2500 if isFile t then
2501 box [string "uw_input_",
2502 p_ident x,
2503 space,
2504 string "=",
2505 space,
2506 string "uw_get_file_input(ctx, ",
2507 string (Int.toString n),
2508 string ");",
2509 newline]
2510 else
2511 box [string "request = uw_get_",
2512 string f,
2513 string "input(ctx, ",
2514 string (Int.toString n),
2515 string ");",
2516 newline,
2517 string "if (request == NULL)",
2518 newline,
2519 box [string "uw_error(ctx, FATAL, \"Missing input ",
2520 string x,
2521 string "\");"],
2522 newline,
2523 string "uw_input_",
2524 p_ident x,
2525 space,
2526 string "=",
2527 space,
2528 unurlify env t,
2529 string ";",
2530 newline]
2531 end) xts),
2532 string "struct __uws_", 2601 string "struct __uws_",
2533 string (Int.toString i), 2602 string (Int.toString i),
2534 space, 2603 space,
2535 string "uw_inputs", 2604 string "uw_inputs",
2536 space, 2605 space,