Mercurial > urweb
changeset 377:78358e5df273
Proper generation of relation names; checking that sequences exist
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Sun, 19 Oct 2008 12:12:59 -0400 |
| parents | 6fd102fa28f9 |
| children | 168667cdaa95 |
| files | src/cjr_print.sml src/compiler.sig src/compiler.sml src/corify.sml src/pathcheck.sig src/pathcheck.sml src/sources tests/pathcheck.ur tests/pathcheck.urp |
| diffstat | 9 files changed, 222 insertions(+), 21 deletions(-) [+] |
line wrap: on
line diff
--- a/src/cjr_print.sml Sun Oct 19 11:11:49 2008 -0400 +++ b/src/cjr_print.sml Sun Oct 19 12:12:59 2008 -0400 @@ -1778,6 +1778,8 @@ val tables = List.mapPartial (fn (DTable (s, xts), _) => SOME (s, xts) | _ => NONE) ds + val sequences = List.mapPartial (fn (DSequence s, _) => SOME s + | _ => NONE) ds val validate = box [string "static void uw_db_validate(uw_context ctx) {", @@ -1790,11 +1792,13 @@ p_list_sep newline (fn (s, xts) => let + val sl = CharVector.map Char.toLower s + val q = "SELECT COUNT(*) FROM pg_class WHERE relname = '" - ^ s ^ "'" + ^ sl ^ "'" val q' = String.concat ["SELECT COUNT(*) FROM pg_attribute WHERE attrelid = (SELECT oid FROM pg_class WHERE relname = '", - s, + sl, "') AND (", String.concatWith " OR " (map (fn (x, t) => @@ -1808,7 +1812,7 @@ ")"] val q'' = String.concat ["SELECT COUNT(*) FROM pg_attribute WHERE attrelid = (SELECT oid FROM pg_class WHERE relname = '", - s, + sl, "') AND attname LIKE 'uw_%'"] in box [string "res = PQexec(conn, \"", @@ -1963,6 +1967,65 @@ string "PQclear(res);", newline] end) tables, + + p_list_sep newline + (fn s => + let + val sl = CharVector.map Char.toLower s + + val q = "SELECT COUNT(*) FROM pg_class WHERE relname = '" + ^ sl ^ "' AND relkind = 'S'" + in + box [string "res = PQexec(conn, \"", + string q, + string "\");", + newline, + newline, + string "if (res == NULL) {", + newline, + box [string "PQfinish(conn);", + newline, + string "uw_error(ctx, FATAL, \"Out of memory allocating query result.\");", + newline], + string "}", + newline, + newline, + string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {", + newline, + box [string "char msg[1024];", + newline, + string "strncpy(msg, PQerrorMessage(conn), 1024);", + newline, + string "msg[1023] = 0;", + newline, + string "PQclear(res);", + newline, + string "PQfinish(conn);", + newline, + string "uw_error(ctx, FATAL, \"Query failed:\\n", + string q, + string "\\n%s\", msg);", + newline], + string "}", + newline, + newline, + string "if (strcmp(PQgetvalue(res, 0, 0), \"1\")) {", + newline, + box [string "PQclear(res);", + newline, + string "PQfinish(conn);", + newline, + string "uw_error(ctx, FATAL, \"Sequence '", + string s, + string "' does not exist.\");", + newline], + string "}", + newline, + newline, + string "PQclear(res);", + newline] + end) sequences, + string "}"] in box [string "#include <stdio.h>",
--- a/src/compiler.sig Sun Oct 19 11:11:49 2008 -0400 +++ b/src/compiler.sig Sun Oct 19 12:12:59 2008 -0400 @@ -70,6 +70,7 @@ val untangle : (Mono.file, Mono.file) phase val mono_reduce : (Mono.file, Mono.file) phase val mono_shake : (Mono.file, Mono.file) phase + val pathcheck : (Mono.file, Mono.file) phase val cjrize : (Mono.file, Cjr.file) phase val prepare : (Cjr.file, Cjr.file) phase val sqlify : (Mono.file, Cjr.file) phase @@ -92,6 +93,7 @@ val toMono_reduce : (string, Mono.file) transform val toMono_shake : (string, Mono.file) transform val toMono_opt2 : (string, Mono.file) transform + val toPathcheck : (string, Mono.file) transform val toCjrize : (string, Cjr.file) transform val toPrepare : (string, Cjr.file) transform val toSqlify : (string, Cjr.file) transform
--- a/src/compiler.sml Sun Oct 19 11:11:49 2008 -0400 +++ b/src/compiler.sml Sun Oct 19 12:12:59 2008 -0400 @@ -463,12 +463,19 @@ val toMono_opt2 = transform mono_opt "mono_opt2" o toMono_shake +val pathcheck = { + func = (fn file => (PathCheck.check file; file)), + print = MonoPrint.p_file MonoEnv.empty +} + +val toPathcheck = transform pathcheck "pathcheck" o toMono_opt2 + val cjrize = { func = Cjrize.cjrize, print = CjrPrint.p_file CjrEnv.empty } -val toCjrize = transform cjrize "cjrize" o toMono_opt2 +val toCjrize = transform cjrize "cjrize" o toPathcheck val prepare = { func = Prepare.prepare,
--- a/src/corify.sml Sun Oct 19 11:11:49 2008 -0400 +++ b/src/corify.sml Sun Oct 19 12:12:59 2008 -0400 @@ -49,6 +49,9 @@ !restify (String.concatWith "/" (rev (s :: mods))) end +val relify = CharVector.map (fn #"/" => #"_" + | ch => ch) + local val count = ref 0 in @@ -106,9 +109,9 @@ val lookupStrByName : string * t -> t val lookupStrByNameOpt : string * t -> t option - val bindFunctor : t -> string -> int -> string -> int -> L.str -> t - val lookupFunctorById : t -> int -> string * int * L.str - val lookupFunctorByName : string * t -> string * int * L.str + val bindFunctor : t -> string list -> string -> int -> string -> int -> L.str -> t + val lookupFunctorById : t -> int -> string list * string * int * L.str + val lookupFunctorByName : string * t -> string list * string * int * L.str end = struct datatype flattening = @@ -117,7 +120,7 @@ constructors : L'.patCon SM.map, vals : int SM.map, strs : flattening SM.map, - funs : (string * int * L.str) SM.map} + funs : (string list * string * int * L.str) SM.map} | FFfi of {mod : string, vals : L'.con SM.map, constructors : (string * string list * L'.con option * L'.datatype_kind) SM.map} @@ -128,7 +131,7 @@ constructors : L'.patCon IM.map, vals : int IM.map, strs : flattening IM.map, - funs : (string * int * L.str) IM.map, + funs : (string list * string * int * L.str) IM.map, current : flattening, nested : flattening list } @@ -402,21 +405,21 @@ fun bindFunctor ({basis, cons, constructors, vals, strs, funs, current = FNormal {name, cons = mcons, constructors = mconstructors, vals = mvals, strs = mstrs, funs = mfuns}, nested} : t) - x n xa na str = + mods x n xa na str = {basis = basis, cons = cons, constructors = constructors, vals = vals, strs = strs, - funs = IM.insert (funs, n, (xa, na, str)), + funs = IM.insert (funs, n, (mods, xa, na, str)), current = FNormal {name = name, cons = mcons, constructors = mconstructors, vals = mvals, strs = mstrs, - funs = SM.insert (mfuns, x, (xa, na, str))}, + funs = SM.insert (mfuns, x, (mods, xa, na, str))}, nested = nested} - | bindFunctor _ _ _ _ _ _ = raise Fail "Corify.St.bindFunctor" + | bindFunctor _ _ _ _ _ _ _ = raise Fail "Corify.St.bindFunctor" fun lookupFunctorById ({funs, ...} : t) n = case IM.find (funs, n) of @@ -693,7 +696,7 @@ | L.DSgn _ => ([], st) | L.DStr (x, n, _, (L.StrFun (xa, na, _, _, str), _)) => - ([], St.bindFunctor st x n xa na str) + ([], St.bindFunctor st mods x n xa na str) | L.DStr (x, n, _, (L.StrProj (str, x'), _)) => let @@ -703,9 +706,9 @@ SOME st' => St.bindStr st x n st' | NONE => let - val (x', n', str') = St.lookupFunctorByName (x', inner) + val (mods', x', n', str') = St.lookupFunctorByName (x', inner) in - St.bindFunctor st x n x' n' str' + St.bindFunctor st mods' x n x' n' str' end in ([], st) @@ -713,7 +716,13 @@ | L.DStr (x, n, _, str) => let - val (ds, {inner, outer}) = corifyStr (x :: mods) (str, st) + val mods' = + if x = "anon" then + mods + else + x :: mods + + val (ds, {inner, outer}) = corifyStr mods' (str, st) val st = St.bindStr outer x n inner in (ds, st) @@ -903,14 +912,14 @@ | L.DTable (_, x, n, c) => let val (st, n) = St.bindVal st x n - val s = doRestify (mods, x) + val s = relify (doRestify (mods, x)) in ([(L'.DTable (x, n, corifyCon st c, s), loc)], st) end | L.DSequence (_, x, n) => let val (st, n) = St.bindVal st x n - val s = doRestify (mods, x) + val s = relify (doRestify (mods, x)) in ([(L'.DSequence (x, n, s), loc)], st) end @@ -948,11 +957,18 @@ | L.StrProj (str, x) => St.lookupFunctorByName (x, unwind' str) | _ => raise Fail "Corify of fancy functor application [2]" - val (xa, na, body) = unwind str1 + val (fmods, xa, na, body) = unwind str1 val (ds1, {inner = inner', outer}) = corifyStr mods (str2, st) - val mods' = mods + val mods' = case #1 str2 of + L.StrConst _ => fmods @ mods + | _ => + let + val ast = unwind' str2 + in + fmods @ St.name ast + end val (ds2, {inner, outer}) = corifyStr mods' (body, St.bindStr outer xa na inner') in
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/pathcheck.sig Sun Oct 19 12:12:59 2008 -0400 @@ -0,0 +1,32 @@ +(* Copyright (c) 2008, Adam Chlipala + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * - Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * - Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * - The names of contributors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + *) + +signature PATH_CHECK = sig + + val check : Mono.file -> unit + +end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/pathcheck.sml Sun Oct 19 12:12:59 2008 -0400 @@ -0,0 +1,64 @@ +(* Copyright (c) 2008, Adam Chlipala + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * - Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * - Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * - The names of contributors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + *) + +structure PathCheck :> PATH_CHECK = struct + +open Mono + +structure E = ErrorMsg + +structure SS = BinarySetFn(struct + type ord_key = string + val compare = String.compare + end) + +fun checkDecl ((d, loc), (funcs, rels)) = + let + fun doRel s = + (if SS.member (rels, s) then + E.errorAt loc ("Duplicate table/sequence path " ^ s) + else + (); + (funcs, SS.add (rels, s))) + in + case d of + DExport (_, s, _, _) => + (if SS.member (funcs, s) then + E.errorAt loc ("Duplicate function path " ^ s) + else + (); + (SS.add (funcs, s), rels)) + + | DTable (s, _) => doRel s + | DSequence s => doRel s + + | _ => (funcs, rels) + end + +fun check ds = ignore (foldl checkDecl (SS.empty, SS.empty) ds) + +end
--- a/src/sources Sun Oct 19 11:11:49 2008 -0400 +++ b/src/sources Sun Oct 19 12:12:59 2008 -0400 @@ -119,6 +119,9 @@ mono_shake.sig mono_shake.sml +pathcheck.sigx +pathcheck.sml + cjr.sml cjr_env.sig
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/pathcheck.ur Sun Oct 19 12:12:59 2008 -0400 @@ -0,0 +1,9 @@ +fun ancillary () : transaction page = return <xml/> + +fun ancillary () = return <xml> + Welcome to the ancillary page! +</xml> + +fun main () : transaction page = return <xml><body> + <a link={ancillary ()}>Enter the unknown!</a> +</body></xml>