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