Mercurial > urweb
changeset 273:09c66a30ef32
Table declarations pushed to Cjr
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Tue, 02 Sep 2008 13:09:54 -0400 |
| parents | 4d80d6122df1 |
| children | e4baf03a3a64 |
| files | src/cjr.sml src/cjr_env.sml src/cjr_print.sml src/cjrize.sml src/mono.sml src/mono_env.sml src/mono_print.sml src/mono_shake.sml src/mono_util.sml src/monoize.sml |
| diffstat | 10 files changed, 52 insertions(+), 9 deletions(-) [+] |
line wrap: on
line diff
--- 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
--- 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
--- 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 "\");",
--- 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 =
--- 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
--- 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) =
--- 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]
--- 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
--- 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',
--- 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