Mercurial > urweb
diff src/monoize.sml @ 707:d8217b4cb617
PRIMARY KEY
author | Adam Chlipala <adamc@hcoop.net> |
---|---|
date | Tue, 07 Apr 2009 16:14:31 -0400 |
parents | e6706a1df013 |
children | 0406e9cccb72 |
line wrap: on
line diff
--- a/src/monoize.sml Tue Apr 07 15:04:07 2009 -0400 +++ b/src/monoize.sml Tue Apr 07 16:14:31 2009 -0400 @@ -149,6 +149,8 @@ (L'.TFfi ("Basis", "string"), loc) | L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_exp"), _), _), _), _), _), _), _), _) => (L'.TFfi ("Basis", "string"), loc) + | L.CApp ((L.CApp ((L.CFfi ("Basis", "primary_key"), _), _), _), _) => + (L'.TFfi ("Basis", "string"), loc) | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_constraints"), _), _), _), _) => (L'.TFfi ("Basis", "sql_constraints"), loc) | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_constraint"), _), _), _), _) => @@ -1159,6 +1161,25 @@ fm) end + | L.ECApp ((L.EFfi ("Basis", "no_primary_key"), _), _) => + ((L'.EPrim (Prim.String ""), loc), + fm) + | L.ECApp ( + (L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "primary_key"), _), _), _), t), _), + nm), _), + (L.CRecord (_, unique), _)) => + let + val unique = (nm, t) :: unique + val witnesses = (L'.TRecord (map (fn (nm, _) => (monoName env nm, (L'.TRecord [], loc))) unique), loc) + in + ((L'.EAbs ("_", witnesses, (L'.TFfi ("Basis", "string"), loc), + (L'.EPrim (Prim.String + (String.concatWith ", " + (map (fn (x, _) => "uw_" ^ monoName env x) unique))), + loc)), loc), + fm) + end + | L.ECApp ((L.EFfi ("Basis", "no_constraint"), _), _) => ((L'.ERecord [], loc), fm) @@ -2499,7 +2520,7 @@ in SOME (env, fm, [(L'.DExport (ek, s, n, ts, ran), loc)]) end - | L.DTable (x, n, (L.CRecord (_, xts), _), s, e, _) => + | L.DTable (x, n, (L.CRecord (_, xts), _), s, pe, _, ce, _) => let val t = (L.CFfi ("Basis", "string"), loc) val t' = (L'.TFfi ("Basis", "string"), loc) @@ -2508,11 +2529,12 @@ val xts = map (fn (x, t) => (monoName env x, monoType env t)) xts - val (e, fm) = monoExp (env, St.empty, fm) e + val (pe, fm) = monoExp (env, St.empty, fm) pe + val (ce, fm) = monoExp (env, St.empty, fm) ce in SOME (Env.pushENamed env x n t NONE s, fm, - [(L'.DTable (s, xts, e), loc), + [(L'.DTable (s, xts, pe, ce), loc), (L'.DVal (x, n, t', e_name, s), loc)]) end | L.DTable _ => poly () @@ -2633,7 +2655,7 @@ in foldl (fn ((d, _), e) => case d of - L.DTable (_, _, xts, tab, _, _) => doTable (tab, #1 xts, e) + L.DTable (_, _, xts, tab, _, _, _, _) => doTable (tab, #1 xts, e) | _ => e) e file end @@ -2678,7 +2700,7 @@ in foldl (fn ((d, _), e) => case d of - L.DTable (_, _, xts, tab, _, _) => doTable (tab, #1 xts, e) + L.DTable (_, _, xts, tab, _, _, _, _) => doTable (tab, #1 xts, e) | _ => e) e file end