# HG changeset patch
# User Adam Chlipala <adamc@hcoop.net>
# Date 1220375394 14400
# Node ID 09c66a30ef326a87912dfa4ad6c8ba28720135b9
# Parent  4d80d6122df1dae4b98c2ee133f3e73b9847bba7
Table declarations pushed to Cjr

diff -r 4d80d6122df1 -r 09c66a30ef32 src/cjr.sml
--- a/src/cjr.sml	Tue Sep 02 11:57:25 2008 -0400
+++ b/src/cjr.sml	Tue Sep 02 13:09:54 2008 -0400
@@ -87,6 +87,8 @@
        | DVal of string * int * typ * exp
        | DFun of string * int * (string * typ) list * typ * exp
        | DFunRec of (string * int * (string * typ) list * typ * exp) list
+
+       | DTable of string * (string * typ) list
        | DDatabase of string
 
 withtype decl = decl' located
diff -r 4d80d6122df1 -r 09c66a30ef32 src/cjr_env.sml
--- a/src/cjr_env.sml	Tue Sep 02 11:57:25 2008 -0400
+++ b/src/cjr_env.sml	Tue Sep 02 13:09:54 2008 -0400
@@ -162,6 +162,7 @@
                   in
                       pushENamed env fx n t
                   end) env vis
+      | DTable _ => env
       | DDatabase _ => env
 
 
diff -r 4d80d6122df1 -r 09c66a30ef32 src/cjr_print.sml
--- a/src/cjr_print.sml	Tue Sep 02 11:57:25 2008 -0400
+++ b/src/cjr_print.sml	Tue Sep 02 13:09:54 2008 -0400
@@ -688,8 +688,14 @@
                  p_list_sep newline (p_fun env) vis,
                  newline]
         end
+      | DTable (x, _) => box [string "/* SQL table ",
+                              string x,
+                              string " */",
+                              newline]
       | DDatabase s => box [string "void lw_db_init(lw_context ctx) {",
                             newline,
+                            string "PGresult *res;",
+                            newline,
                             string "PGconn *conn = PQconnectdb(\"",
                             string (String.toString s),
                             string "\");",
diff -r 4d80d6122df1 -r 09c66a30ef32 src/cjrize.sml
--- a/src/cjrize.sml	Tue Sep 02 11:57:25 2008 -0400
+++ b/src/cjrize.sml	Tue Sep 02 13:09:54 2008 -0400
@@ -423,6 +423,17 @@
             (NONE, SOME (ek, "/" ^ s, n, ts), sm)
         end
 
+      | L.DTable (s, xts) =>
+        let
+            val (xts, sm) = ListUtil.foldlMap (fn ((x, t), sm) =>
+                                                  let
+                                                      val (t, sm) = cifyTyp (t, sm)
+                                                  in
+                                                      ((x, t), sm)
+                                                  end) sm xts
+        in
+            (SOME (L'.DTable (s, xts), loc), NONE, sm)
+        end
       | L.DDatabase s => (SOME (L'.DDatabase s, loc), NONE, sm)
 
 fun cjrize ds =
diff -r 4d80d6122df1 -r 09c66a30ef32 src/mono.sml
--- a/src/mono.sml	Tue Sep 02 11:57:25 2008 -0400
+++ b/src/mono.sml	Tue Sep 02 13:09:54 2008 -0400
@@ -90,6 +90,8 @@
        | DVal of string * int * typ * exp * string
        | DValRec of (string * int * typ * exp * string) list
        | DExport of Core.export_kind * string * int * typ list
+
+       | DTable of string * (string * typ) list
        | DDatabase of string
 
 withtype decl = decl' located
diff -r 4d80d6122df1 -r 09c66a30ef32 src/mono_env.sml
--- a/src/mono_env.sml	Tue Sep 02 11:57:25 2008 -0400
+++ b/src/mono_env.sml	Tue Sep 02 13:09:54 2008 -0400
@@ -107,6 +107,7 @@
       | DVal (x, n, t, e, s) => pushENamed env x n t (SOME e) s
       | DValRec vis => foldl (fn ((x, n, t, e, s), env) => pushENamed env x n t NONE s) env vis
       | DExport _ => env
+      | DTable _ => env
       | DDatabase _ => env
 
 fun patBinds env (p, loc) =
diff -r 4d80d6122df1 -r 09c66a30ef32 src/mono_print.sml
--- a/src/mono_print.sml	Tue Sep 02 11:57:25 2008 -0400
+++ b/src/mono_print.sml	Tue Sep 02 13:09:54 2008 -0400
@@ -313,6 +313,18 @@
                                                                             p_typ env t,
                                                                             string ")"]) ts]
 
+      | DTable (s, xts) => box [string "(* SQL table ",
+                                string s,
+                                space,
+                                string ":",
+                                space,
+                                p_list (fn (x, t) => box [string x,
+                                                          space,
+                                                          string ":",
+                                                          space,
+                                                          p_typ env t]) xts,
+                                space,
+                                string "*)"]
       | DDatabase s => box [string "database",
                             space,
                             string s]
diff -r 4d80d6122df1 -r 09c66a30ef32 src/mono_shake.sml
--- a/src/mono_shake.sml	Tue Sep 02 11:57:25 2008 -0400
+++ b/src/mono_shake.sml	Tue Sep 02 13:09:54 2008 -0400
@@ -54,6 +54,7 @@
                                    | ((DValRec vis, _), (cdef, edef)) =>
                                      (cdef, foldl (fn ((_, n, t, e, _), edef) => IM.insert (edef, n, (t, e))) edef vis)
                                    | ((DExport _, _), acc) => acc
+                                   | ((DTable _, _), acc) => acc
                                    | ((DDatabase _, _), acc) => acc)
                                  (IM.empty, IM.empty) file
 
@@ -108,6 +109,7 @@
                       | (DVal (_, n, _, _, _), _) => IS.member (#exp s, n)
                       | (DValRec vis, _) => List.exists (fn (_, n, _, _, _) => IS.member (#exp s, n)) vis
                       | (DExport _, _) => true
+                      | (DTable _, _) => true
                       | (DDatabase _, _) => true) file
     end
 
diff -r 4d80d6122df1 -r 09c66a30ef32 src/mono_util.sml
--- a/src/mono_util.sml	Tue Sep 02 11:57:25 2008 -0400
+++ b/src/mono_util.sml	Tue Sep 02 13:09:54 2008 -0400
@@ -342,6 +342,7 @@
                 S.map2 (ListUtil.mapfold mft ts,
                         fn ts' =>
                            (DExport (ek, s, n, ts'), loc))
+              | DTable _ => S.return2 dAll
               | DDatabase _ => S.return2 dAll
 
         and mfvi ctx (x, n, t, e, s) =
@@ -405,6 +406,7 @@
                                       | DValRec vis => foldl (fn ((x, n, t, e, s), ctx) =>
                                                                  bind (ctx, NamedE (x, n, t, NONE, s))) ctx vis
                                       | DExport _ => ctx
+                                      | DTable _ => ctx
                                       | DDatabase _ => ctx
                             in
                                 S.map2 (mff ctx' ds',
diff -r 4d80d6122df1 -r 09c66a30ef32 src/monoize.sml
--- a/src/monoize.sml	Tue Sep 02 11:57:25 2008 -0400
+++ b/src/monoize.sml	Tue Sep 02 13:09:54 2008 -0400
@@ -1372,7 +1372,7 @@
                 val env' = Env.declBinds env all
                 val d = (L'.DDatatype (x, n, map (fn (x, n, to) => (x, n, Option.map (monoType env') to)) xncs), loc)
             in
-                SOME (env', fm, d)
+                SOME (env', fm, [d])
             end
           | L.DDatatype _ => poly ()
           | L.DVal (x, n, t, e, s) =>
@@ -1381,7 +1381,7 @@
             in
                 SOME (Env.pushENamed env x n t NONE s,
                       fm,
-                      (L'.DVal (x, n, monoType env t, e, s), loc))
+                      [(L'.DVal (x, n, monoType env t, e, s), loc)])
             end
           | L.DValRec vis =>
             let
@@ -1398,7 +1398,7 @@
             in
                 SOME (env,
                       fm,
-                      (L'.DValRec vis, loc))
+                      [(L'.DValRec vis, loc)])
             end
           | L.DExport (ek, n) =>
             let
@@ -1411,19 +1411,23 @@
 
                 val ts = map (monoType env) (unwind t)
             in
-                SOME (env, fm, (L'.DExport (ek, s, n, ts), loc))
+                SOME (env, fm, [(L'.DExport (ek, s, n, ts), loc)])
             end
-          | L.DTable (x, n, _, s) =>
+          | L.DTable (x, n, (L.CRecord (_, xts), _), s) =>
             let
                 val t = (L.CFfi ("Basis", "string"), loc)
                 val t' = (L'.TFfi ("Basis", "string"), loc)
                 val e = (L'.EPrim (Prim.String s), loc)
+
+                val xts = map (fn (x, t) => (monoName env x, monoType env t)) xts
             in
                 SOME (Env.pushENamed env x n t NONE s,
                       fm,
-                      (L'.DVal (x, n, t', e, s), loc))
+                      [(L'.DTable (s, xts), loc),
+                       (L'.DVal (x, n, t', e, s), loc)])
             end
-          | L.DDatabase s => SOME (env, fm, (L'.DDatabase s, loc))
+          | L.DTable _ => poly ()
+          | L.DDatabase s => SOME (env, fm, [(L'.DDatabase s, loc)])
     end
 
 fun monoize env ds =
@@ -1431,10 +1435,10 @@
         val (_, _, ds) = List.foldl (fn (d, (env, fm, ds)) =>
                                      case monoDecl (env, fm) d of
                                          NONE => (env, fm, ds)
-                                       | SOME (env, fm, d) =>
+                                       | SOME (env, fm, ds') =>
                                          (env,
                                           Fm.enter fm,
-                                          d :: Fm.decls fm @ ds))
+                                          ds' @ Fm.decls fm @ ds))
                                     (env, Fm.empty (CoreUtil.File.maxName ds + 1), []) ds
     in
         rev ds