Proper generation of relation names; checking that sequences exist

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
+