Mercurial > urweb

comparison src/monoize.sml @ 707:d8217b4cb617

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
PRIMARY KEY
author Adam Chlipala <adamc@hcoop.net>
date Tue, 07 Apr 2009 16:14:31 -0400
parents e6706a1df013
children 0406e9cccb72
comparison
equal deleted inserted replaced
706:1fb318c17546 707:d8217b4cb617
146 | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_query"), _), _), _), _) => 146 | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_query"), _), _), _), _) =>
147 (L'.TFfi ("Basis", "string"), loc) 147 (L'.TFfi ("Basis", "string"), loc)
148 | L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_query1"), _), _), _), _), _), _) => 148 | L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_query1"), _), _), _), _), _), _) =>
149 (L'.TFfi ("Basis", "string"), loc) 149 (L'.TFfi ("Basis", "string"), loc)
150 | L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_exp"), _), _), _), _), _), _), _), _) => 150 | L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_exp"), _), _), _), _), _), _), _), _) =>
151 (L'.TFfi ("Basis", "string"), loc)
152 | L.CApp ((L.CApp ((L.CFfi ("Basis", "primary_key"), _), _), _), _) =>
151 (L'.TFfi ("Basis", "string"), loc) 153 (L'.TFfi ("Basis", "string"), loc)
152 | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_constraints"), _), _), _), _) => 154 | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_constraints"), _), _), _), _) =>
153 (L'.TFfi ("Basis", "sql_constraints"), loc) 155 (L'.TFfi ("Basis", "sql_constraints"), loc)
154 | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_constraint"), _), _), _), _) => 156 | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_constraint"), _), _), _), _) =>
155 (L'.TFfi ("Basis", "string"), loc) 157 (L'.TFfi ("Basis", "string"), loc)
1154 (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc), 1156 (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc),
1155 (L'.EFfiApp ("Basis", "send", 1157 (L'.EFfiApp ("Basis", "send",
1156 [(L'.ERel 2, loc), 1158 [(L'.ERel 2, loc),
1157 e]), 1159 e]),
1158 loc)), loc)), loc)), loc), 1160 loc)), loc)), loc)), loc),
1161 fm)
1162 end
1163
1164 | L.ECApp ((L.EFfi ("Basis", "no_primary_key"), _), _) =>
1165 ((L'.EPrim (Prim.String ""), loc),
1166 fm)
1167 | L.ECApp (
1168 (L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "primary_key"), _), _), _), t), _),
1169 nm), _),
1170 (L.CRecord (_, unique), _)) =>
1171 let
1172 val unique = (nm, t) :: unique
1173 val witnesses = (L'.TRecord (map (fn (nm, _) => (monoName env nm, (L'.TRecord [], loc))) unique), loc)
1174 in
1175 ((L'.EAbs ("_", witnesses, (L'.TFfi ("Basis", "string"), loc),
1176 (L'.EPrim (Prim.String
1177 (String.concatWith ", "
1178 (map (fn (x, _) => "uw_" ^ monoName env x) unique))),
1179 loc)), loc),
1159 fm) 1180 fm)
1160 end 1181 end
1161 1182
1162 | L.ECApp ((L.EFfi ("Basis", "no_constraint"), _), _) => 1183 | L.ECApp ((L.EFfi ("Basis", "no_constraint"), _), _) =>
1163 ((L'.ERecord [], loc), 1184 ((L'.ERecord [], loc),
2497 val ts = map (monoType env) ts 2518 val ts = map (monoType env) ts
2498 val ran = monoType env ran 2519 val ran = monoType env ran
2499 in 2520 in
2500 SOME (env, fm, [(L'.DExport (ek, s, n, ts, ran), loc)]) 2521 SOME (env, fm, [(L'.DExport (ek, s, n, ts, ran), loc)])
2501 end 2522 end
2502 | L.DTable (x, n, (L.CRecord (_, xts), _), s, e, _) => 2523 | L.DTable (x, n, (L.CRecord (_, xts), _), s, pe, _, ce, _) =>
2503 let 2524 let
2504 val t = (L.CFfi ("Basis", "string"), loc) 2525 val t = (L.CFfi ("Basis", "string"), loc)
2505 val t' = (L'.TFfi ("Basis", "string"), loc) 2526 val t' = (L'.TFfi ("Basis", "string"), loc)
2506 val s = "uw_" ^ s 2527 val s = "uw_" ^ s
2507 val e_name = (L'.EPrim (Prim.String s), loc) 2528 val e_name = (L'.EPrim (Prim.String s), loc)
2508 2529
2509 val xts = map (fn (x, t) => (monoName env x, monoType env t)) xts 2530 val xts = map (fn (x, t) => (monoName env x, monoType env t)) xts
2510 2531
2511 val (e, fm) = monoExp (env, St.empty, fm) e 2532 val (pe, fm) = monoExp (env, St.empty, fm) pe
2533 val (ce, fm) = monoExp (env, St.empty, fm) ce
2512 in 2534 in
2513 SOME (Env.pushENamed env x n t NONE s, 2535 SOME (Env.pushENamed env x n t NONE s,
2514 fm, 2536 fm,
2515 [(L'.DTable (s, xts, e), loc), 2537 [(L'.DTable (s, xts, pe, ce), loc),
2516 (L'.DVal (x, n, t', e_name, s), loc)]) 2538 (L'.DVal (x, n, t', e_name, s), loc)])
2517 end 2539 end
2518 | L.DTable _ => poly () 2540 | L.DTable _ => poly ()
2519 | L.DSequence (x, n, s) => 2541 | L.DSequence (x, n, s) =>
2520 let 2542 let
2631 2653
2632 val e = (L'.ERecord [], loc) 2654 val e = (L'.ERecord [], loc)
2633 in 2655 in
2634 foldl (fn ((d, _), e) => 2656 foldl (fn ((d, _), e) =>
2635 case d of 2657 case d of
2636 L.DTable (_, _, xts, tab, _, _) => doTable (tab, #1 xts, e) 2658 L.DTable (_, _, xts, tab, _, _, _, _) => doTable (tab, #1 xts, e)
2637 | _ => e) e file 2659 | _ => e) e file
2638 end 2660 end
2639 2661
2640 fun initializer () = 2662 fun initializer () =
2641 let 2663 let
2676 2698
2677 val e = (L'.ERecord [], loc) 2699 val e = (L'.ERecord [], loc)
2678 in 2700 in
2679 foldl (fn ((d, _), e) => 2701 foldl (fn ((d, _), e) =>
2680 case d of 2702 case d of
2681 L.DTable (_, _, xts, tab, _, _) => doTable (tab, #1 xts, e) 2703 L.DTable (_, _, xts, tab, _, _, _, _) => doTable (tab, #1 xts, e)
2682 | _ => e) e file 2704 | _ => e) e file
2683 end 2705 end
2684 2706
2685 val (_, _, ds) = List.foldl (fn (d, (env, fm, ds)) => 2707 val (_, _, ds) = List.foldl (fn (d, (env, fm, ds)) =>
2686 case #1 d of 2708 case #1 d of