Mercurial > urweb

comparison src/monoize.sml @ 687:a3ddf05fb3e3

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
On start-up, delete/nullify rows mentioning clients or channels
author Adam Chlipala <adamc@hcoop.net>
date Thu, 02 Apr 2009 11:42:26 -0400
parents f0224c7f12bb
children 7ea0df9e56b6
comparison
equal deleted inserted replaced
686:3b46548f701b 687:a3ddf05fb3e3
2472 () 2472 ()
2473 2473
2474 val loc = E.dummySpan 2474 val loc = E.dummySpan
2475 val client = (L'.TFfi ("Basis", "client"), loc) 2475 val client = (L'.TFfi ("Basis", "client"), loc)
2476 val unit = (L'.TRecord [], loc) 2476 val unit = (L'.TRecord [], loc)
2477
2478 fun calcClientish xts =
2479 foldl (fn ((x : L.con, t : L.con), st as (nullable, notNullable)) =>
2480 case #1 x of
2481 L.CName x =>
2482 (case #1 t of
2483 L.CFfi ("Basis", "client") =>
2484 (nullable, (x, Client) :: notNullable)
2485 | L.CApp ((L.CFfi ("Basis", "option"), _),
2486 (L.CFfi ("Basis", "client"), _)) =>
2487 ((x, Client) :: nullable, notNullable)
2488 | L.CApp ((L.CFfi ("Basis", "channel"), _), _) =>
2489 (nullable, (x, Channel) :: notNullable)
2490 | L.CApp ((L.CFfi ("Basis", "option"), _),
2491 (L.CApp ((L.CFfi ("Basis", "channel"), _), _), _)) =>
2492 ((x, Channel) :: nullable, notNullable)
2493 | _ => st)
2494 | _ => st) ([], []) xts
2495
2477 fun expunger () = 2496 fun expunger () =
2478 let 2497 let
2479 val target = (L'.EFfiApp ("Basis", "sqlifyClient", [(L'.ERel 0, loc)]), loc) 2498 val target = (L'.EFfiApp ("Basis", "sqlifyClient", [(L'.ERel 0, loc)]), loc)
2480 2499
2481 fun doTable (tab, xts, e) = 2500 fun doTable (tab, xts, e) =
2482 case xts of 2501 case xts of
2483 L.CRecord (_, xts) => 2502 L.CRecord (_, xts) =>
2484 let 2503 let
2485 val (nullable, notNullable) = 2504 val (nullable, notNullable) = calcClientish xts
2486 foldl (fn ((x, t), st as (nullable, notNullable)) =>
2487 case #1 x of
2488 L.CName x =>
2489 (case #1 t of
2490 L.CFfi ("Basis", "client") =>
2491 (nullable, (x, Client) :: notNullable)
2492 | L.CApp ((L.CFfi ("Basis", "option"), _),
2493 (L.CFfi ("Basis", "client"), _)) =>
2494 ((x, Client) :: nullable, notNullable)
2495 | L.CApp ((L.CFfi ("Basis", "channel"), _), _) =>
2496 (nullable, (x, Channel) :: notNullable)
2497 | L.CApp ((L.CFfi ("Basis", "option"), _),
2498 (L.CApp ((L.CFfi ("Basis", "channel"), _), _), _)) =>
2499 ((x, Channel) :: nullable, notNullable)
2500 | _ => st)
2501 | _ => st) ([], []) xts
2502 2505
2503 fun cond (x, v) = 2506 fun cond (x, v) =
2504 (L'.EStrcat ((L'.EPrim (Prim.String ("uw_" ^ x 2507 (L'.EStrcat ((L'.EPrim (Prim.String ("uw_" ^ x
2505 ^ (case v of 2508 ^ (case v of
2506 Client => "" 2509 Client => ""
2527 | eb :: ebs => 2530 | eb :: ebs =>
2528 (L'.ESeq ( 2531 (L'.ESeq (
2529 (L'.EDml (foldl 2532 (L'.EDml (foldl
2530 (fn (eb, s) => 2533 (fn (eb, s) =>
2531 (L'.EStrcat (s, 2534 (L'.EStrcat (s,
2532 (L'.EStrcat ((L'.EPrim (Prim.String " AND "), 2535 (L'.EStrcat ((L'.EPrim (Prim.String " OR "),
2533 loc), 2536 loc),
2534 cond eb), loc)), loc)) 2537 cond eb), loc)), loc))
2535 (L'.EStrcat ((L'.EPrim (Prim.String ("DELETE FROM uw_" 2538 (L'.EStrcat ((L'.EPrim (Prim.String ("DELETE FROM uw_"
2536 ^ tab 2539 ^ tab
2537 ^ " WHERE ")), loc), 2540 ^ " WHERE ")), loc),
2549 case d of 2552 case d of
2550 L.DTable (_, _, xts, tab) => doTable (tab, #1 xts, e) 2553 L.DTable (_, _, xts, tab) => doTable (tab, #1 xts, e)
2551 | _ => e) e file 2554 | _ => e) e file
2552 end 2555 end
2553 2556
2557 fun initializer () =
2558 let
2559 fun doTable (tab, xts, e) =
2560 case xts of
2561 L.CRecord (_, xts) =>
2562 let
2563 val (nullable, notNullable) = calcClientish xts
2564
2565 val e =
2566 case nullable of
2567 [] => e
2568 | (x, _) :: ebs =>
2569 (L'.ESeq (
2570 (L'.EDml (L'.EPrim (Prim.String
2571 (foldl (fn ((x, _), s) =>
2572 s ^ ", uw_" ^ x ^ " = NULL")
2573 ("UPDATE uw_"
2574 ^ tab
2575 ^ " SET uw_"
2576 ^ x
2577 ^ " = NULL")
2578 ebs)), loc), loc),
2579 e), loc)
2580
2581 val e =
2582 case notNullable of
2583 [] => e
2584 | eb :: ebs =>
2585 (L'.ESeq (
2586 (L'.EDml (L'.EPrim (Prim.String ("DELETE FROM uw_"
2587 ^ tab)), loc), loc),
2588 e), loc)
2589 in
2590 e
2591 end
2592 | _ => e
2593
2594 val e = (L'.ERecord [], loc)
2595 in
2596 foldl (fn ((d, _), e) =>
2597 case d of
2598 L.DTable (_, _, xts, tab) => doTable (tab, #1 xts, e)
2599 | _ => e) e file
2600 end
2601
2554 val (_, _, ds) = List.foldl (fn (d, (env, fm, ds)) => 2602 val (_, _, ds) = List.foldl (fn (d, (env, fm, ds)) =>
2555 case #1 d of 2603 case #1 d of
2556 L.DDatabase s => 2604 L.DDatabase s =>
2557 let 2605 let
2558 val (n, fm) = Fm.freshName fm 2606 val (nExp, fm) = Fm.freshName fm
2559 2607 val (nIni, fm) = Fm.freshName fm
2560 2608
2561 val d = L'.DVal ("expunger", 2609 val dExp = L'.DVal ("expunger",
2562 n, 2610 nExp,
2563 (L'.TFun (client, unit), loc), 2611 (L'.TFun (client, unit), loc),
2564 (L'.EAbs ("cli", client, unit, expunger ()), loc), 2612 (L'.EAbs ("cli", client, unit, expunger ()), loc),
2565 "expunger") 2613 "expunger")
2614 val dIni = L'.DVal ("initializer",
2615 nIni,
2616 (L'.TFun (unit, unit), loc),
2617 (L'.EAbs ("_", unit, unit, initializer ()), loc),
2618 "initializer")
2566 in 2619 in
2567 (env, Fm.enter fm, (L'.DDatabase (s, n), loc) 2620 (env, Fm.enter fm, (L'.DDatabase {name = s,
2568 :: (d, loc) 2621 expunge = nExp,
2622 initialize = nIni}, loc)
2623 :: (dExp, loc)
2624 :: (dIni, loc)
2569 :: ds) 2625 :: ds)
2570 end 2626 end
2571 | _ => 2627 | _ =>
2572 case monoDecl (env, fm) d of 2628 case monoDecl (env, fm) d of
2573 NONE => (env, fm, ds) 2629 NONE => (env, fm, ds)