Mercurial > urweb

comparison src/monoize.sml @ 683:9a2c18dab11d

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Expunging non-nullable rows
author Adam Chlipala <adamc@hcoop.net>
date Sun, 29 Mar 2009 13:30:01 -0400
parents 5bbb542243e8
children f0224c7f12bb
comparison
equal deleted inserted replaced
682:5bbb542243e8 683:9a2c18dab11d
163 | L.CFfi ("Basis", "sql_offset") => 163 | L.CFfi ("Basis", "sql_offset") =>
164 (L'.TFfi ("Basis", "string"), loc) 164 (L'.TFfi ("Basis", "string"), loc)
165 165
166 | L.CApp ((L.CFfi ("Basis", "sql_injectable_prim"), _), t) => 166 | L.CApp ((L.CFfi ("Basis", "sql_injectable_prim"), _), t) =>
167 (L'.TFun (mt env dtmap t, (L'.TFfi ("Basis", "string"), loc)), loc) 167 (L'.TFun (mt env dtmap t, (L'.TFfi ("Basis", "string"), loc)), loc)
168 | L.CApp ((L.CFfi ("Basis", "sql_injectable_nullable"), _), t) =>
169 (L'.TFun (mt env dtmap t, (L'.TFfi ("Basis", "string"), loc)), loc)
170 | L.CApp ((L.CFfi ("Basis", "sql_injectable"), _), t) => 168 | L.CApp ((L.CFfi ("Basis", "sql_injectable"), _), t) =>
171 (L'.TFun (mt env dtmap t, (L'.TFfi ("Basis", "string"), loc)), loc) 169 (L'.TFun (mt env dtmap t, (L'.TFfi ("Basis", "string"), loc)), loc)
172 | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_unary"), _), _), _), _) => 170 | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_unary"), _), _), _), _) =>
173 (L'.TFfi ("Basis", "string"), loc) 171 (L'.TFfi ("Basis", "string"), loc)
174 | L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_binary"), _), _), _), _), _), _) => 172 | L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_binary"), _), _), _), _), _), _) =>
246 val empty : int -> t 244 val empty : int -> t
247 245
248 val lookup : t -> foo_kind -> int -> (int -> t -> L'.decl * t) -> t * int 246 val lookup : t -> foo_kind -> int -> (int -> t -> L'.decl * t) -> t * int
249 val enter : t -> t 247 val enter : t -> t
250 val decls : t -> L'.decl list 248 val decls : t -> L'.decl list
249
250 val freshName : t -> int * t
251 end = struct 251 end = struct
252 252
253 structure M = BinaryMapFn(struct 253 structure M = BinaryMapFn(struct
254 type ord_key = foo_kind 254 type ord_key = foo_kind
255 fun compare x = 255 fun compare x =
272 map = M.empty, 272 map = M.empty,
273 decls = [] 273 decls = []
274 } 274 }
275 275
276 fun enter ({count, map, ...} : t) = {count = count, map = map, decls = []} 276 fun enter ({count, map, ...} : t) = {count = count, map = map, decls = []}
277 fun freshName {count, map, decls} = (count, {count = count + 1, map = map, decls = decls})
277 fun decls ({decls, ...} : t) = decls 278 fun decls ({decls, ...} : t) = decls
278 279
279 fun lookup (t as {count, map, decls}) k n thunk = 280 fun lookup (t as {count, map, decls}) k n thunk =
280 let 281 let
281 val im = Option.getOpt (M.find (map, k), IM.empty) 282 val im = Option.getOpt (M.find (map, k), IM.empty)
1453 (L'.EApp ((L'.ERel 2, loc), (L'.ERel 0, loc)), loc))], 1454 (L'.EApp ((L'.ERel 2, loc), (L'.ERel 0, loc)), loc))],
1454 {disc = (L'.TOption t, loc), 1455 {disc = (L'.TOption t, loc),
1455 result = s}), loc)), loc)), loc), 1456 result = s}), loc)), loc)), loc),
1456 fm) 1457 fm)
1457 end 1458 end
1458 | L.ECApp ((L.EFfi ("Basis", "sql_nullable"), _), t) =>
1459 let
1460 val t = monoType env t
1461 val s = (L'.TFfi ("Basis", "string"), loc)
1462 in
1463 ((L'.EAbs ("f",
1464 (L'.TFun (t, s), loc),
1465 (L'.TFun ((L'.TOption t, loc), s), loc),
1466 (L'.EAbs ("x",
1467 (L'.TOption t, loc),
1468 s,
1469 (L'.ECase ((L'.ERel 0, loc),
1470 [((L'.PNone t, loc),
1471 (L'.EPrim (Prim.String "NULL"), loc)),
1472 ((L'.PSome (t, (L'.PVar ("y", t), loc)), loc),
1473 (L'.EApp ((L'.ERel 2, loc), (L'.ERel 0, loc)), loc))],
1474 {disc = (L'.TOption t, loc),
1475 result = s}), loc)), loc)), loc),
1476 fm)
1477 end
1478 1459
1479 | L.ECApp ((L.EFfi ("Basis", "sql_subset"), _), _) => 1460 | L.ECApp ((L.EFfi ("Basis", "sql_subset"), _), _) =>
1480 ((L'.ERecord [], loc), fm) 1461 ((L'.ERecord [], loc), fm)
1481 | L.ECApp ((L.EFfi ("Basis", "sql_subset_all"), _), _) => 1462 | L.ECApp ((L.EFfi ("Basis", "sql_subset_all"), _), _) =>
1482 ((L'.ERecord [], loc), fm) 1463 ((L'.ERecord [], loc), fm)
2462 SOME (Env.pushENamed env x n t NONE s, 2443 SOME (Env.pushENamed env x n t NONE s,
2463 fm, 2444 fm,
2464 [(L'.DSequence s, loc), 2445 [(L'.DSequence s, loc),
2465 (L'.DVal (x, n, t', e, s), loc)]) 2446 (L'.DVal (x, n, t', e, s), loc)])
2466 end 2447 end
2467 | L.DDatabase s => SOME (env, fm, [(L'.DDatabase s, loc)]) 2448 | L.DDatabase _ => NONE
2468 | L.DCookie (x, n, t, s) => 2449 | L.DCookie (x, n, t, s) =>
2469 let 2450 let
2470 val t = (L.CFfi ("Basis", "string"), loc) 2451 val t = (L.CFfi ("Basis", "string"), loc)
2471 val t' = (L'.TFfi ("Basis", "string"), loc) 2452 val t' = (L'.TFfi ("Basis", "string"), loc)
2472 val e = (L'.EPrim (Prim.String s), loc) 2453 val e = (L'.EPrim (Prim.String s), loc)
2475 fm, 2456 fm,
2476 [(L'.DVal (x, n, t', e, s), loc)]) 2457 [(L'.DVal (x, n, t', e, s), loc)])
2477 end 2458 end
2478 end 2459 end
2479 2460
2480 fun monoize env ds = 2461 datatype expungable = Client | Channel
2462
2463 fun monoize env file =
2481 let 2464 let
2482 val p = !urlPrefix 2465 val p = !urlPrefix
2483 val () = 2466 val () =
2484 if p = "" then 2467 if p = "" then
2485 urlPrefix := "/" 2468 urlPrefix := "/"
2486 else if String.sub (p, size p - 1) <> #"/" then 2469 else if String.sub (p, size p - 1) <> #"/" then
2487 urlPrefix := p ^ "/" 2470 urlPrefix := p ^ "/"
2488 else 2471 else
2489 () 2472 ()
2490 2473
2474 val loc = E.dummySpan
2475 val client = (L'.TFfi ("Basis", "client"), loc)
2476 val unit = (L'.TRecord [], loc)
2477 fun expunger () =
2478 let
2479 val target = (L'.EFfiApp ("Basis", "sqlifyClient", [(L'.ERel 0, loc)]), loc)
2480
2481 fun doTable (tab, xts, e) =
2482 case xts of
2483 L.CRecord (_, xts) =>
2484 let
2485 val (nullable, notNullable) =
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
2503 val e =
2504 case notNullable of
2505 [] => e
2506 | eb :: ebs =>
2507 let
2508 fun cond (x, v) =
2509 (L'.EStrcat ((L'.EPrim (Prim.String ("uw_" ^ x
2510 ^ (case v of
2511 Client => ""
2512 | Channel => " >> 32")
2513 ^ " = ")), loc),
2514 target), loc)
2515 in
2516 (L'.ESeq (
2517 (L'.EDml (foldl
2518 (fn (eb, s) =>
2519 (L'.EStrcat (s,
2520 (L'.EStrcat ((L'.EPrim (Prim.String " AND "),
2521 loc),
2522 cond eb), loc)), loc))
2523 (L'.EStrcat ((L'.EPrim (Prim.String ("DELETE FROM uw_"
2524 ^ tab
2525 ^ " WHERE ")), loc),
2526 cond eb), loc)
2527 ebs), loc),
2528 e), loc)
2529 end
2530 in
2531 e
2532 end
2533 | _ => e
2534
2535 val e = (L'.ERecord [], loc)
2536 in
2537 foldl (fn ((d, _), e) =>
2538 case d of
2539 L.DTable (_, _, xts, tab) => doTable (tab, #1 xts, e)
2540 | _ => e) e file
2541 end
2542
2491 val (_, _, ds) = List.foldl (fn (d, (env, fm, ds)) => 2543 val (_, _, ds) = List.foldl (fn (d, (env, fm, ds)) =>
2492 case monoDecl (env, fm) d of 2544 case #1 d of
2493 NONE => (env, fm, ds) 2545 L.DDatabase s =>
2494 | SOME (env, fm, ds') => 2546 let
2495 (env, 2547 val (n, fm) = Fm.freshName fm
2496 Fm.enter fm, 2548
2497 ds' @ Fm.decls fm @ ds)) 2549
2498 (env, Fm.empty (CoreUtil.File.maxName ds + 1), []) ds 2550 val d = L'.DVal ("expunger",
2551 n,
2552 (L'.TFun (client, unit), loc),
2553 (L'.EAbs ("cli", client, unit, expunger ()), loc),
2554 "expunger")
2555 in
2556 (env, Fm.enter fm, (L'.DDatabase (s, n), loc)
2557 :: (d, loc)
2558 :: ds)
2559 end
2560 | _ =>
2561 case monoDecl (env, fm) d of
2562 NONE => (env, fm, ds)
2563 | SOME (env, fm, ds') =>
2564 (env,
2565 Fm.enter fm,
2566 ds' @ Fm.decls fm @ ds))
2567 (env, Fm.empty (CoreUtil.File.maxName file + 1), []) file
2499 in 2568 in
2500 rev ds 2569 rev ds
2501 end 2570 end
2502 2571
2503 end 2572 end