summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2008-10-19 12:12:59 -0400
committerGravatar Adam Chlipala <adamc@hcoop.net>2008-10-19 12:12:59 -0400
commit8476261d4f4a9a67119abc05cb40907ad979b4de (patch)
tree8c46ce5f2896d194de0e2b1b04c9895e80efc17e
parent98651ecbb17fce5630300f0050f323d7d023cf6b (diff)
Proper generation of relation names; checking that sequences exist
-rw-r--r--src/cjr_print.sml69
-rw-r--r--src/compiler.sig2
-rw-r--r--src/compiler.sml9
-rw-r--r--src/corify.sml50
-rw-r--r--src/pathcheck.sig32
-rw-r--r--src/pathcheck.sml64
-rw-r--r--src/sources3
-rw-r--r--tests/pathcheck.ur9
-rw-r--r--tests/pathcheck.urp5
9 files changed, 222 insertions, 21 deletions
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index ee464917..ef198e2a 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -1778,6 +1778,8 @@ fun p_file env (ds, ps) =
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 @@ fun p_file env (ds, ps) =
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 @@ fun p_file env (ds, ps) =
")"]
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 @@ fun p_file env (ds, ps) =
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>",
diff --git a/src/compiler.sig b/src/compiler.sig
index 833c647f..31a940c2 100644
--- a/src/compiler.sig
+++ b/src/compiler.sig
@@ -70,6 +70,7 @@ signature COMPILER = sig
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 @@ signature COMPILER = sig
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
diff --git a/src/compiler.sml b/src/compiler.sml
index 3d2ce354..26aede96 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -463,12 +463,19 @@ val toMono_shake = transform mono_shake "mono_shake1" o toMono_reduce
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,
diff --git a/src/corify.sml b/src/corify.sml
index f72276db..8d754d87 100644
--- a/src/corify.sml
+++ b/src/corify.sml
@@ -49,6 +49,9 @@ fun doRestify (mods, s) =
!restify (String.concatWith "/" (rev (s :: mods)))
end
+val relify = CharVector.map (fn #"/" => #"_"
+ | ch => ch)
+
local
val count = ref 0
in
@@ -106,9 +109,9 @@ structure St : sig
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 @@ datatype flattening =
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 @@ type t = {
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 lookupStrByNameOpt (m, {basis, current = FNormal {strs, ...}, ...} : t) =
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 @@ fun corifyDecl mods ((d, loc : EM.span), st) =
| 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 @@ fun corifyDecl mods ((d, loc : EM.span), st) =
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 @@ fun corifyDecl mods ((d, loc : EM.span), st) =
| 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 @@ fun corifyDecl mods ((d, loc : EM.span), st) =
| 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 @@ and corifyStr mods ((str, _), st) =
| 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
diff --git a/src/pathcheck.sig b/src/pathcheck.sig
new file mode 100644
index 00000000..e4b9c7a9
--- /dev/null
+++ b/src/pathcheck.sig
@@ -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
diff --git a/src/pathcheck.sml b/src/pathcheck.sml
new file mode 100644
index 00000000..ed6a4124
--- /dev/null
+++ b/src/pathcheck.sml
@@ -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
diff --git a/src/sources b/src/sources
index 506f1767..388e0996 100644
--- a/src/sources
+++ b/src/sources
@@ -119,6 +119,9 @@ mono_reduce.sml
mono_shake.sig
mono_shake.sml
+pathcheck.sigx
+pathcheck.sml
+
cjr.sml
cjr_env.sig
diff --git a/tests/pathcheck.ur b/tests/pathcheck.ur
new file mode 100644
index 00000000..6d2359cd
--- /dev/null
+++ b/tests/pathcheck.ur
@@ -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>
diff --git a/tests/pathcheck.urp b/tests/pathcheck.urp
new file mode 100644
index 00000000..42f9af17
--- /dev/null
+++ b/tests/pathcheck.urp
@@ -0,0 +1,5 @@
+debug
+exe /tmp/webapp
+
+pathcheck
+