Mercurial > urweb

comparison src/monoize.sml @ 704:70cbdcf5989b

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
UNIQUE constraints
author Adam Chlipala <adamc@hcoop.net>
date Tue, 07 Apr 2009 12:24:31 -0400
parents 755a71c99be5
children e6706a1df013
comparison
equal deleted inserted replaced
703:a5d8b470d7ca 704:70cbdcf5989b
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", "sql_constraints"), _), _), _), _) =>
153 (L'.TFfi ("Basis", "sql_constraints"), loc)
154 | L.CApp ((L.CFfi ("Basis", "sql_constraint"), _), _) =>
151 (L'.TFfi ("Basis", "string"), loc) 155 (L'.TFfi ("Basis", "string"), loc)
152 156
153 | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_subset"), _), _), _), _) => 157 | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_subset"), _), _), _), _) =>
154 (L'.TRecord [], loc) 158 (L'.TRecord [], loc)
155 | L.CFfi ("Basis", "sql_relop") => 159 | L.CFfi ("Basis", "sql_relop") =>
1152 [(L'.ERel 2, loc), 1156 [(L'.ERel 2, loc),
1153 e]), 1157 e]),
1154 loc)), loc)), loc)), loc), 1158 loc)), loc)), loc)), loc),
1155 fm) 1159 fm)
1156 end 1160 end
1161
1162 | L.ECApp ((L.EFfi ("Basis", "no_constraint"), _), _) =>
1163 ((L'.ERecord [], loc),
1164 fm)
1165 | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "one_constraint"), _), _), _), (L.CName name, _)) =>
1166 ((L'.EAbs ("c",
1167 (L'.TFfi ("Basis", "string"), loc),
1168 (L'.TFfi ("Basis", "sql_constraints"), loc),
1169 (L'.ERecord [(name, (L'.ERel 0, loc), (L'.TFfi ("Basis", "string"), loc))], loc)), loc),
1170 fm)
1171 | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "join_constraints"), _), _), _), _), _), _) =>
1172 let
1173 val constraints = (L'.TFfi ("Basis", "sql_constraints"), loc)
1174 in
1175 ((L'.EAbs ("cs1", constraints, (L'.TFun (constraints, constraints), loc),
1176 (L'.EAbs ("cs2", constraints, constraints,
1177 (L'.EStrcat ((L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc),
1178 fm)
1179 end
1180
1181 | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "unique"), _), _), _),
1182 (L.CRecord (_, unique), _)) =>
1183 ((L'.EPrim (Prim.String ("UNIQUE ("
1184 ^ String.concatWith ", " (map (fn (x, _) => "uw_" ^ monoName env x) unique)
1185 ^ ")")), loc),
1186 fm)
1157 1187
1158 | L.EFfiApp ("Basis", "dml", [e]) => 1188 | L.EFfiApp ("Basis", "dml", [e]) =>
1159 let 1189 let
1160 val (e, fm) = monoExp (env, st, fm) e 1190 val (e, fm) = monoExp (env, st, fm) e
1161 in 1191 in
2449 val ts = map (monoType env) ts 2479 val ts = map (monoType env) ts
2450 val ran = monoType env ran 2480 val ran = monoType env ran
2451 in 2481 in
2452 SOME (env, fm, [(L'.DExport (ek, s, n, ts, ran), loc)]) 2482 SOME (env, fm, [(L'.DExport (ek, s, n, ts, ran), loc)])
2453 end 2483 end
2454 | L.DTable (x, n, (L.CRecord (_, xts), _), s) => 2484 | L.DTable (x, n, (L.CRecord (_, xts), _), s, e) =>
2455 let 2485 let
2456 val t = (L.CFfi ("Basis", "string"), loc) 2486 val t = (L.CFfi ("Basis", "string"), loc)
2457 val t' = (L'.TFfi ("Basis", "string"), loc) 2487 val t' = (L'.TFfi ("Basis", "string"), loc)
2458 val s = "uw_" ^ s 2488 val s = "uw_" ^ s
2459 val e = (L'.EPrim (Prim.String s), loc) 2489 val e_name = (L'.EPrim (Prim.String s), loc)
2460 2490
2461 val xts = map (fn (x, t) => (monoName env x, monoType env t)) xts 2491 val xts = map (fn (x, t) => (monoName env x, monoType env t)) xts
2492
2493 val (e, fm) = monoExp (env, St.empty, fm) e
2462 in 2494 in
2463 SOME (Env.pushENamed env x n t NONE s, 2495 SOME (Env.pushENamed env x n t NONE s,
2464 fm, 2496 fm,
2465 [(L'.DTable (s, xts), loc), 2497 [(L'.DTable (s, xts, e), loc),
2466 (L'.DVal (x, n, t', e, s), loc)]) 2498 (L'.DVal (x, n, t', e_name, s), loc)])
2467 end 2499 end
2468 | L.DTable _ => poly () 2500 | L.DTable _ => poly ()
2469 | L.DSequence (x, n, s) => 2501 | L.DSequence (x, n, s) =>
2470 let 2502 let
2471 val t = (L.CFfi ("Basis", "string"), loc) 2503 val t = (L.CFfi ("Basis", "string"), loc)
2581 2613
2582 val e = (L'.ERecord [], loc) 2614 val e = (L'.ERecord [], loc)
2583 in 2615 in
2584 foldl (fn ((d, _), e) => 2616 foldl (fn ((d, _), e) =>
2585 case d of 2617 case d of
2586 L.DTable (_, _, xts, tab) => doTable (tab, #1 xts, e) 2618 L.DTable (_, _, xts, tab, _) => doTable (tab, #1 xts, e)
2587 | _ => e) e file 2619 | _ => e) e file
2588 end 2620 end
2589 2621
2590 fun initializer () = 2622 fun initializer () =
2591 let 2623 let
2626 2658
2627 val e = (L'.ERecord [], loc) 2659 val e = (L'.ERecord [], loc)
2628 in 2660 in
2629 foldl (fn ((d, _), e) => 2661 foldl (fn ((d, _), e) =>
2630 case d of 2662 case d of
2631 L.DTable (_, _, xts, tab) => doTable (tab, #1 xts, e) 2663 L.DTable (_, _, xts, tab, _) => doTable (tab, #1 xts, e)
2632 | _ => e) e file 2664 | _ => e) e file
2633 end 2665 end
2634 2666
2635 val (_, _, ds) = List.foldl (fn (d, (env, fm, ds)) => 2667 val (_, _, ds) = List.foldl (fn (d, (env, fm, ds)) =>
2636 case #1 d of 2668 case #1 d of