Further work on Postgres transform, still not perfect.

Current unit tests are almost worthless; need new tests.

.gitignore

@@ -27,3 +27,7 @@ node_modules/
 generated/
 
 
+
+*.orig
+
+*.out

project.clj

@@ -8,7 +8,7 @@
   :dependencies [[adl-support "0.1.8-SNAPSHOT"]
                  [bouncer "1.0.1"]
                  [clojure-saxon "0.9.4"]
-                 [environ "1.2.0"]
+                 [environ "1.1.0"]
                  [hiccup "1.0.5"]
                  [org.clojure/clojure "1.12.0"]
                  [org.clojure/math.combinatorics "0.3.0"]

src/adl/to_hugsql_queries.clj

@@ -31,78 +31,78 @@
 ;;;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
- (def expanded-token "_expanded")
+(def expanded-token "_expanded")
 
 
- (defn where-clause
-   "Generate an appropriate `where` clause for queries on this `entity`;
+(defn where-clause
+  "Generate an appropriate `where` clause for queries on this `entity`;
   if `properties` are passed, filter on those properties, otherwise the key
   properties."
-   ([entity]
-    (where-clause entity (key-properties entity)))
-   ([entity properties]
-    (let
+  ([entity]
+   (where-clause entity (key-properties entity)))
+  ([entity properties]
+   (let
      [entity-name (safe-name entity :sql)
       property-names (map #(:name (:attrs %)) properties)]
       (when-not (empty? property-names)
         (str
          "WHERE "
          (s/join
-          "\n\tAND "
-          (map
-           #(str entity-name "." (safe-name % :sql) " = :" %)
-           property-names)))))))
+           "\n\tAND "
+           (map
+             #(str entity-name "." (safe-name % :sql) " = :" %)
+             property-names)))))))
 
 
- (defn order-by-clause
-   "Generate an appropriate `order by` clause for queries on this `entity`"
-   ([entity]
-    (order-by-clause entity "" false))
-   ([entity prefix]
-    (order-by-clause entity prefix false))
-   ([entity prefix expanded?]
-    (let
+(defn order-by-clause
+  "Generate an appropriate `order by` clause for queries on this `entity`"
+  ([entity]
+   (order-by-clause entity "" false))
+  ([entity prefix]
+   (order-by-clause entity prefix false))
+  ([entity prefix expanded?]
+   (let
      [entity-name (safe-name entity :sql)
       preferred (filter #(#{"user" "all"} (-> % :attrs :distinct))
                         (descendants-with-tag entity :property))]
-      (if
+     (if
        (empty? preferred)
-        ""
-        (str
+       ""
+       (str
          "ORDER BY " prefix entity-name "."
          (s/join
-          (str ",\n\t" prefix entity-name ".")
-          (map
-           #(if
-             (and expanded? (= "entity" (-> % :attrs :type)))
-              (str (safe-name % :sql) expanded-token)
-              (safe-name % :sql))
-           (order-preserving-set
-            (concat
-             preferred
-             (key-properties entity))))))))))
+           (str ",\n\t" prefix entity-name ".")
+           (map
+             #(if
+                (and expanded? (= "entity" (-> % :attrs :type)))
+                (str (safe-name % :sql) expanded-token)
+                (safe-name % :sql))
+             (order-preserving-set
+               (concat
+                 preferred
+                 (key-properties entity))))))))))
 
 ;; (def a (x/parse "../youyesyet/youyesyet.adl.xml"))
 ;; (def e (child-with-tag a :entity #(= "dwellings" (-> % :attrs :name))))
 ;; (order-by-clause e "" true)
 
 
- (defn insert-query
-   "Generate an appropriate `insert` query for this `entity`.
+(defn insert-query
+  "Generate an appropriate `insert` query for this `entity`.
   TODO: this depends on the idea that system-unique properties
   are not insertable, which is... dodgy."
-   [entity]
-   (let [entity-name (safe-name entity :sql)
-         pretty-name (singularise entity-name)
-         insertable-property-names (map
+  [entity]
+  (let [entity-name (safe-name entity :sql)
+        pretty-name (singularise entity-name)
+        insertable-property-names (map
                                     #(safe-name % :sql)
                                     (insertable-properties entity))
          query-name (str "create-" pretty-name "!")
          signature (if (has-primary-key? entity)
                      ":? :1" ;; bizarrely, if you want to return the keys,
                     ;; you have to use a query signature.
-                     ":! :n")]
-     (hash-map
+                    ":! :n")]
+    (hash-map
       (keyword query-name)
       {:name query-name
        :signature signature
@@ -117,26 +117,26 @@
             (s/join ",\n\t" (map keyword insertable-property-names))
             ")"
             (if
-             (has-primary-key? entity)
+              (has-primary-key? entity)
               (str "\nreturning "
                    (s/join
-                    ",\n\t"
-                    (map
-                     #(safe-name % :sql)
-                     (key-names entity))))))})))
+                     ",\n\t"
+                     (map
+                       #(safe-name % :sql)
+                       (key-names entity))))))})))
 
 
- (defn update-query
-   "Generate an appropriate `update` query for this `entity`"
-   [entity]
-   (let [entity-name (safe-name entity :sql)
-         pretty-name (singularise entity-name)
-         property-names (map
+(defn update-query
+  "Generate an appropriate `update` query for this `entity`"
+  [entity]
+  (let [entity-name (safe-name entity :sql)
+        pretty-name (singularise entity-name)
+        property-names (map
                          #(-> % :attrs :name)
                          (insertable-properties entity))
-         query-name (str "update-" pretty-name "!")
-         signature ":! :n"]
-     (hash-map
+        query-name (str "update-" pretty-name "!")
+        signature ":! :n"]
+    (hash-map
       (keyword query-name)
       {:name query-name
        :signature signature
@@ -148,10 +148,10 @@
             "UPDATE " entity-name "\n"
             "SET "
             (s/join
-             ",\n\t"
-             (map
-              #(str (safe-name % :sql) " = " (keyword %))
-              property-names))
+              ",\n\t"
+              (map
+                #(str (safe-name % :sql) " = " (keyword %))
+                property-names))
             "\n"
             (where-clause entity))})))
 
@@ -168,66 +168,67 @@
         pretty-name (singularise entity-name)
         query-name (str "search-strings-" entity-name)
         signature ":? :*"
-        properties (remove #(#{"(safe-name entity :sql)"} (:type (:attrs %))) (all-properties entity))]
+        properties (remove #(#{"(safe-name entity :sql)"}(:type (:attrs %))) (all-properties entity))]
     (hash-map
-     (keyword query-name)
-     {:name query-name
-      :signature signature
-      :entity entity
-      :type :text-search
-      :query
-      (s/join
-       "\n"
-       (remove
-        empty?
-        (list
-         (str "-- :name " query-name " " signature)
-         (str
-          "-- :doc selects existing "
-          pretty-name
-          " records having any string field matching the parameter of the same name by substring match")
-         (str "SELECT DISTINCT * FROM lv_" entity-name)
-         (s/join
-          "\n\t--~ "
-          (cons
-           "WHERE true"
-           (filter
-            string?
-            (map
-             #(let
-               [sn (safe-name % :sql)]
-                (str
-                 "(if (:" (-> % :attrs :name) " params) (str \"AND "
-                 (case (-> % :attrs :type)
-                   ("string" "text")
-                   (str
-                    sn
-                    " LIKE '%\" (:" (-> % :attrs :name) " params) \"%' ")
-                   ("date" "time" "timestamp")
-                   (str
-                    sn
-                    " = ':" (-> % :attrs :name) "'")
-                   "entity"
-                   (str
-                    sn
-                    "_expanded LIKE '%\" (:" (-> % :attrs :name) " params) \"%'")
-                   (str
-                    sn
-                    " = :"
-                    (-> % :attrs :name)))
-                 "\"))"))
-             properties))))
-         (order-by-clause entity "lv_" true)
-         "--~ (if (:offset params) \"OFFSET :offset \")"
-         "--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")")))}))))
+      (keyword query-name)
+      {:name query-name
+       :signature signature
+       :entity entity
+       :type :text-search
+       :query
+       (s/join
+         "\n"
+         (remove
+           empty?
+           (list
+             (str "-- :name " query-name " " signature)
+             (str
+               "-- :doc selects existing "
+               pretty-name
+               " records having any string field matching the parameter of the same name by substring match")
+             (str "SELECT DISTINCT * FROM lv_" entity-name)
+             (s/join
+               "\n\t--~ "
+               (cons
+                 "WHERE true"
+                 (filter
+                   string?
+                   (map
+                     #(let
+                        [sn (safe-name % :sql)]
+                        (str
+                          "(if (:" (-> % :attrs :name) " params) (str \"AND "
+                          (case (-> % :attrs :type)
+                            ("string" "text")
+                            (str
+                              sn
+                              " LIKE '%\" (:" (-> % :attrs :name) " params) \"%' ")
+                            ("date" "time" "timestamp")
+                            (str
+                              sn
+                              " = ':" (-> % :attrs :name) "'")
+                            "entity"
+                            (str
+                              sn
+                              "_expanded LIKE '%\" (:" (-> % :attrs :name) " params) \"%'")
+                            (str
+                              sn
+                              " = :"
+                              (-> % :attrs :name)))
+                          "\"))"))
+                     properties))))
+             (order-by-clause entity "lv_" true)
+             "--~ (if (:offset params) \"OFFSET :offset \")"
+             "--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")")))}))))
 
 ;; (search-query e a)
 
+
 (defn select-query
   "Generate an appropriate `select` query for this `entity`"
   ([entity properties]
    (if-not
-    (empty? properties)
+     (empty? properties)
      (let [entity-name (safe-name entity :sql)
            pretty-name (singularise entity-name)
            query-name (if (= properties (key-properties entity))
@@ -237,32 +238,32 @@
                                      (map #(:name (:attrs %)) properties))))
            signature ":? :1"]
        (hash-map
-        (keyword query-name)
-        {:name query-name
-         :signature signature
-         :entity entity
-         :type :select-1
-         :query
-         (s/join
-          "\n"
-          (remove
-           empty?
-           (list
-            (str "-- :name " query-name " " signature)
-            (str "-- :doc selects an existing " pretty-name " record")
-            (str "SELECT * FROM " entity-name)
-            (where-clause entity properties)
-            (order-by-clause entity))))}))
+         (keyword query-name)
+         {:name query-name
+          :signature signature
+          :entity entity
+          :type :select-1
+          :query
+          (s/join
+            "\n"
+            (remove
+              empty?
+              (list
+                (str "-- :name " query-name " " signature)
+                (str "-- :doc selects an existing " pretty-name " record")
+                (str "SELECT * FROM " entity-name)
+                (where-clause entity properties)
+                (order-by-clause entity))))}))
      {}))
   ([entity]
    (let [distinct-fields (distinct-properties entity)]
      (apply
-      merge
-      (cons
-       (select-query entity (key-properties entity))
-       (map
-        #(select-query entity %)
-        (combinations distinct-fields (count distinct-fields))))))))
+       merge
+       (cons
+         (select-query entity (key-properties entity))
+         (map
+           #(select-query entity %)
+           (combinations distinct-fields (count distinct-fields))))))))
 
 
 (defn list-query
@@ -275,23 +276,23 @@
         query-name (str "list-" entity-name)
         signature ":? :*"]
     (hash-map
-     (keyword query-name)
-     {:name query-name
-      :signature signature
-      :entity entity
-      :type :select-many
-      :query
-      (s/join
-       "\n"
-       (remove
-        empty?
-        (list
-         (str "-- :name " query-name " " signature)
-         (str "-- :doc lists all existing " pretty-name " records")
-         (str "SELECT DISTINCT lv_" entity-name ".* FROM lv_" entity-name)
-         (order-by-clause entity "lv_" false)
-         "--~ (if (:offset params) \"OFFSET :offset \")"
-         "--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")")))})))
+      (keyword query-name)
+      {:name query-name
+       :signature signature
+       :entity entity
+       :type :select-many
+       :query
+       (s/join
+         "\n"
+         (remove
+           empty?
+           (list
+             (str "-- :name " query-name " " signature)
+             (str "-- :doc lists all existing " pretty-name " records")
+             (str "SELECT DISTINCT lv_" entity-name ".* FROM lv_" entity-name)
+             (order-by-clause entity "lv_" false)
+             "--~ (if (:offset params) \"OFFSET :offset \")"
+             "--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")")))})))
 
 
 (defn foreign-queries
@@ -363,22 +364,22 @@
   "Generate an appropriate `delete` query for this `entity`"
   [entity]
   (if
-   (has-primary-key? entity)
+    (has-primary-key? entity)
     (let [entity-name (safe-name entity :sql)
           pretty-name (singularise entity-name)
           query-name (str "delete-" pretty-name "!")
           signature ":! :n"]
       (hash-map
-       (keyword query-name)
-       {:name query-name
-        :signature signature
-        :entity entity
-        :type :delete-1
-        :query
-        (str "-- :name " query-name " " signature "\n"
-             "-- :doc deletes an existing " pretty-name " record\n"
-             "DELETE FROM " entity-name "\n"
-             (where-clause entity))}))))
+        (keyword query-name)
+        {:name query-name
+         :signature signature
+         :entity entity
+         :type :delete-1
+         :query
+         (str "-- :name " query-name " " signature "\n"
+              "-- :doc deletes an existing " pretty-name " record\n"
+              "DELETE FROM " entity-name "\n"
+              (where-clause entity))}))))
 
 
 (defn queries
@@ -387,18 +388,18 @@
   ([application entity]
    (merge
      ;; TODO: queries that look through link tables
-    (insert-query entity)
-    (update-query entity)
-    (delete-query entity)
-    (select-query entity)
-    (list-query entity)
-    (search-query entity application)
-    (foreign-queries entity application)))
+     (insert-query entity)
+     (update-query entity)
+     (delete-query entity)
+     (select-query entity)
+     (list-query entity)
+     (search-query entity application)
+     (foreign-queries entity application)))
   ([application]
    (apply
-    merge
-    (map #(queries application %)
-         (children-with-tag application :entity)))))
+     merge
+     (map #(queries application %)
+          (children-with-tag application :entity)))))
 
 
 (defn to-hugsql-queries
@@ -407,25 +408,25 @@
   (let [filepath (str *output-path* "resources/sql/queries.auto.sql")]
     (make-parents filepath)
     (do-or-warn
-     (do
-       (spit
-        filepath
-        (s/join
-         "\n\n"
-         (cons
-          (emit-header
-           "--"
-           "File queries.sql"
-           (str "autogenerated by adl.to-hugsql-queries at " (t/now))
-           "See [Application Description Language](https://github.com/simon-brooke/adl).")
-          (map
-           :query
-           (sort
-            #(compare (:name %1) (:name %2))
-            (vals
-             (queries application)))))))
-       (if (pos? *verbosity*)
-         (*warn* (str "\tGenerated " filepath)))))))
+      (do
+        (spit
+          filepath
+          (s/join
+            "\n\n"
+            (cons
+              (emit-header
+                "--"
+                "File queries.sql"
+                (str "autogenerated by adl.to-hugsql-queries at " (t/now))
+                "See [Application Description Language](https://github.com/simon-brooke/adl).")
+              (map
+                :query
+                (sort
+                  #(compare (:name %1) (:name %2))
+                  (vals
+                    (queries application)))))))
+        (if (pos? *verbosity*)
+          (*warn* (str "\tGenerated " filepath)))))))
 
 
 (defn generate-documentation
@@ -433,68 +434,68 @@
   [query]
   (let [v (volatility (:entity query))]
     (s/join
-     " "
-     (list
-      (case
-       (:type query)
-        :delete-1
-        (str "delete one record from the `"
-             (-> query :entity :attrs :name)
-             "` table. Expects the following key(s) to be present in `params`: `"
-             (-> query :entity key-names)
-             "`.")
-        :insert-1
-        (str "insert one record to the `"
-             (-> query :entity :attrs :name)
-             "` table. Expects the following key(s) to be present in `params`: `"
-             (pr-str
-              (map
-               #(keyword (:name (:attrs %)))
-               (-> query :entity insertable-properties)))
-             "`. Returns a map containing the keys `"
-             (-> query :entity key-names)
-             "` identifying the record created.")
-        :select-1
-        (str "select one record from the `"
-             (-> query :entity :attrs :name)
-             "` table. Expects the following key(s) to be present in `params`: `"
-             (-> query :entity key-names)
-             "`. Returns a map containing the following keys: `"
-             (map #(keyword (:name (:attrs %))) (-> query :entity all-properties))
-             "`.")
-        :select-many
-        (str "select all records from the `"
-             (-> query :entity :attrs :name)
-             "` table. If the keys `(:limit :offset)` are present in the request then they will be used to page through the data. Returns a sequence of maps each containing the following keys: `"
-             (pr-str
-              (map
-               #(keyword (:name (:attrs %)))
-               (-> query :entity all-properties)))
-             "`.")
-        :text-search
-        (str "select all records from the `"
-             (-> query :entity :attrs :name)
+      " "
+      (list
+        (case
+          (:type query)
+          :delete-1
+          (str "delete one record from the `"
+               (-> query :entity :attrs :name)
+               "` table. Expects the following key(s) to be present in `params`: `"
+               (-> query :entity key-names)
+               "`.")
+          :insert-1
+          (str "insert one record to the `"
+               (-> query :entity :attrs :name)
+               "` table. Expects the following key(s) to be present in `params`: `"
+               (pr-str
+                 (map
+                   #(keyword (:name (:attrs %)))
+                   (-> query :entity insertable-properties )))
+               "`. Returns a map containing the keys `"
+               (-> query :entity key-names)
+               "` identifying the record created.")
+          :select-1
+          (str "select one record from the `"
+               (-> query :entity :attrs :name)
+               "` table. Expects the following key(s) to be present in `params`: `"
+               (-> query :entity key-names)
+               "`. Returns a map containing the following keys: `"
+               (map #(keyword (:name (:attrs %))) (-> query :entity all-properties))
+               "`.")
+          :select-many
+          (str "select all records from the `"
+               (-> query :entity :attrs :name)
+               "` table. If the keys `(:limit :offset)` are present in the request then they will be used to page through the data. Returns a sequence of maps each containing the following keys: `"
+               (pr-str
+                 (map
+                   #(keyword (:name (:attrs %)))
+                   (-> query :entity all-properties)))
+               "`.")
+          :text-search
+          (str "select all records from the `"
+               (-> query :entity :attrs :name)
                ;; TODO: this doc-string is out of date
-             "` table with any text field matching the value of the key `:pattern` which should be in the request. If the keys `(:limit :offset)` are present in the request then they will be used to page through the data. Returns a sequence of maps each containing the following keys: `"
-             (pr-str
-              (map
-               #(keyword (:name (:attrs %)))
-               (-> query :entity all-properties)))
-             "`.")
-        :update-1
-        (str "update one record in the `"
-             (-> query :entity :attrs :name)
-             "` table. Expects the following key(s) to be present in `params`: `"
-             (pr-str
-              (distinct
-               (sort
-                (map
-                 #(keyword (:name (:attrs %)))
-                 (flatten
-                  (cons
-                   (-> query :entity key-properties)
-                   (-> query :entity insertable-properties)))))))
-             "`."))
-      (if-not
-       (zero? v)
-        (str "Results will be held in cache for " v " seconds."))))))
+               "` table with any text field matching the value of the key `:pattern` which should be in the request. If the keys `(:limit :offset)` are present in the request then they will be used to page through the data. Returns a sequence of maps each containing the following keys: `"
+               (pr-str
+                 (map
+                   #(keyword (:name (:attrs %)))
+                   (-> query :entity all-properties)))
+               "`.")
+          :update-1
+          (str "update one record in the `"
+               (-> query :entity :attrs :name)
+               "` table. Expects the following key(s) to be present in `params`: `"
+               (pr-str
+                 (distinct
+                   (sort
+                     (map
+                       #(keyword (:name (:attrs %)))
+                       (flatten
+                         (cons
+                           (-> query :entity key-properties)
+                           (-> query :entity insertable-properties)))))))
+               "`."))
+        (if-not
+          (zero? v)
+          (str "Results will be held in cache for " v " seconds."))))))

src/adl/to_psql.clj

@@ -1,13 +1,20 @@
 (ns ^{:doc "Application Description Language: generate Postgres database definition."
       :author "Simon Brooke"}
   adl.to-psql
-  (:require [adl-support.core :refer :all]
-            [adl-support.utils :refer :all]
-           ;;  [adl.to-hugsql-queries :refer [queries]]
-            [clojure.java.io :refer [make-parents]]
-            [clojure.string :as s]
-            [clj-time.core :as t]
-            [clj-time.format :as f]))
+  (:require
+   [adl-support.core :refer [*warn* do-or-warn]]
+   [adl-support.utils :refer [*output-path* *verbosity* all-properties child
+                              child-with-tag children-with-tag emit-header
+                              entity-for-property entity? find-permissions
+                              is-quotable-type? key-names key-properties
+                              link-table-name properties property-for-field
+                              safe-name singularise sort-by-name
+                              system-generated? typedef unique-link?
+                              user-distinct-properties]] ;;  [adl.to-hugsql-queries :refer [queries]]
+   [clj-time.core :as t]
+   [clj-time.format :as f]
+   [clojure.java.io :refer [make-parents]]
+   [clojure.string :as s]))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;;
@@ -161,7 +168,7 @@
               #(if (selector (:permission (:attrs %)))
                  (safe-name (:group (:attrs %)) :sql))
               permissions)))]
-    (if-not
+    (when-not
       (empty? group-names)
       (s/join
         " "
@@ -193,11 +200,12 @@
   ([property entity application]
    (emit-property property entity application false))
   ([property entity application key?]
-   (let [default (:default (:attrs property))]
-     (if
+   (let [default (:default (:attrs property))
+         type (-> property :attrs :type)]
+     (when
        (and
          (= (:tag property) :property)
-         (not (#{"link"} (:type (:attrs property)))))
+         (not (#{"link" "list"} type)))
        (s/join
          " "
          (remove
@@ -207,14 +215,14 @@
                "\t"
                (field-name property)
                (emit-field-type property entity application key?)
-               (if
+               (when
                  default
                  (list
                    "DEFAULT"
                    (if
                      (is-quotable-type? property application)
                      (str "'" default "'") ;; TODO: but if the default value seems to be a function invocation, should it be quoted?
-                     ;; it's quite common for 'now()' to be the default for a date, time or timestamp field.
+                     ;; it's quite common for `now()` to be the default for a date, time or timestamp field.
                      default)))
                (if
                  key?
@@ -223,20 +231,25 @@
 
 
 (defn compose-convenience-entity-field
-  [field entity application]
-  (let [farside (entity-for-property (property-for-field field entity) application)]
+  ([field entity application]
+   (compose-convenience-entity-field field entity application nil))
+  ([field entity application table-alias]
+  (let [property (case (:tag field)
+                   :field (property-for-field field entity)
+                   :property field)
+        farside (entity-for-property property application)]
     (flatten
       (map
-        (fn [f]
+        (fn [p]
           (if
-            (= (:type (:attrs f)) "entity")
-            (compose-convenience-entity-field f farside application)
-            (str (safe-name (:table (:attrs farside))) "." (field-name f))))
-        (user-distinct-properties farside)))))
+            (= (:type (:attrs p)) "entity")
+            (compose-convenience-entity-field p farside application (field-name property))
+            (str (or table-alias (safe-name farside :sql)) "." (field-name  p))))
+        (user-distinct-properties farside))))))
 
 
-(defn compose-convenience-view-select-list
-  "Compose the body of an SQL `SELECT` statement for a convenience view of this
+(defn compose-convenience-view-from-list
+  "Compose the FROM list of an SQL `SELECT` statement for a convenience view of this
   `entity` within this `application`, recursively. `top-level?` should be set
   only on first invocation."
   [entity application top-level?]
@@ -244,15 +257,17 @@
     nil?
     (flatten
       (cons
-        (safe-name (:table (:attrs entity)) :sql)
+        (safe-name entity :sql)
         (map
           (fn [f]
-            (if
+            (when
               (= (:type (:attrs f)) "entity")
-              (compose-convenience-view-select-list
-                (child application #(and (entity? %) (= (:name (:attrs %))(:entity (:attrs f)))))
-                application
-                false)))
+              (let [farside (child application #(and (entity? %) (= (:name (:attrs %))(:entity (:attrs f)))))
+                     tablename (safe-name farside :sql)
+                    fieldname (field-name f)]
+                (if (= tablename fieldname)
+                  tablename
+                  (str tablename " AS " fieldname)))))
           (if
             top-level?
             (all-properties entity)
@@ -271,19 +286,19 @@
     (flatten
       (map
         (fn [f]
-          (if
+          (when
             (= (:type (:attrs f)) "entity")
             (let [farside (entity-for-property f application)]
               (cons
                 (str
-                  (safe-name (:table (:attrs entity)) :sql)
+                  (safe-name entity :sql)
                   "."
                   (field-name f)
                   " = "
-                  (safe-name (:table (:attrs farside)) :sql)
+                  (safe-name farside :sql)
                   "."
                   (safe-name (first (key-names farside)) :sql))
-                #(compose-convenience-where-clause farside application false)))))
+                (compose-convenience-where-clause farside application false)))))
         (if
           top-level?
           (all-properties entity)
@@ -291,24 +306,29 @@
 
 
 (defn emit-convenience-entity-field
-  [field entity application]
-  (str
-    (s/join
-      " ||', '|| "
-      (compose-convenience-entity-field field entity application))
-    " AS "
-    (field-name field)
-    "_expanded"))
+  ([property entity application]
+   (emit-convenience-entity-field property entity application (field-name property)))
+  ([property entity application table-alias]
+   (when
+     (= "entity" (-> property :attrs :type))
+     (str
+       (s/join
+         " ||', '|| "
+         (compose-convenience-entity-field property entity application table-alias))
+       " AS "
+       (field-name property)
+       "_expanded"))))
 
 
 (defn emit-convenience-view
   "Emit a convenience view of this `entity` of this `application` for use in generating lists,
   menus, et cetera."
   [entity application]
-  (let [view-name (safe-name (str "lv_" (:table (:attrs entity))) :sql)
-        entity-fields (filter
-                        #(= (:type (:attrs %)) "entity")
-                        (properties entity))]
+  (let [table-name (safe-name entity :sql)
+        view-name (safe-name (str "lv_" table-name) :sql)
+        entity-properties (filter
+                            #(= (:type (:attrs %)) "entity")
+                            (properties entity))]
     (s/join
       "\n"
       (remove
@@ -325,21 +345,23 @@
               "SELECT "
               (s/join
                 ",\n\t"
-                (flatten
-                  (map
-                    #(if
-                       (= (:type (:attrs %)) "entity")
-                       (list
-                         (emit-convenience-entity-field % entity application)
-                         (str (safe-name entity) "." (field-name %)))
-                       (str (safe-name entity) "." (field-name %)))
-                    (filter
-                      #(not= (:type (:attrs %)) "link")
-                      (all-properties entity) )))))
+                (remove
+                  nil?
+                  (flatten
+                    (map
+                      #(if
+                         (= (:type (:attrs %)) "entity")
+                         (list
+                           (emit-convenience-entity-field % entity application (field-name %))
+                           (str table-name "." (field-name %)))
+                         (str table-name "." (field-name %)))
+                      (remove
+                        #(#{"link" "list"} (:type (:attrs %)))
+                        (all-properties entity) ))))))
             (str
-              "FROM " (s/join ", " (set (compose-convenience-view-select-list entity application true))))
-            (if-not
-              (empty? entity-fields)
+              "FROM " (s/join ", " (set (compose-convenience-view-from-list entity application true))))
+            (when-not
+              (empty? entity-properties)
               (str
                 "WHERE "
                 (s/join
@@ -349,14 +371,14 @@
                       (let
                         [farside (entity-for-property f application)]
                         (str
-                          (safe-name (:table (:attrs entity)) :sql)
+                          (safe-name entity :sql)
                           "."
                           (field-name f)
                           " = "
-                          (safe-name (:table (:attrs farside)) :sql)
+                          (safe-name farside :sql)
                           "."
                           (safe-name (first (key-names farside)) :sql))))
-                    entity-fields))))
+                    entity-properties))))
             ";"
             (emit-permissions-grant view-name :SELECT (find-permissions entity application))))))))
 
@@ -378,8 +400,8 @@
         (field-name property)
         ") \n\tREFERENCES"
         (str
-          (safe-name (:table (:attrs farside)) :sql)
-          "(" (field-name (first (key-properties farside))) ")")
+          (safe-name farside :sql)
+          "( " (field-name (first (key-properties farside))) " )")
         ;; TODO: ought to handle the `cascade` attribute, even though it's rarely used
         "\n\tON DELETE"
         (case
@@ -415,7 +437,7 @@
   "Emit a table declaration for this `entity` of this `application`,
   documented with this `doc-comment` if specified."
   ([entity application doc-comment]
-   (let [table-name (safe-name (:table (:attrs entity)) :sql)
+   (let [table-name (safe-name entity :sql)
          permissions (children-with-tag entity :permission)]
      (s/join
        "\n"
@@ -435,9 +457,9 @@
            (str
              (s/join
                ",\n"
-               (flatten
-                 (remove
-                   nil?
+               (remove
+                 nil?
+                 (flatten
                    (list
                      (map
                        #(emit-property % entity application true)
@@ -457,7 +479,7 @@
      application
      (str
        "primary table "
-       (:table (:attrs entity))
+       (safe-name entity :sql)
        " for entity "
        (:name (:attrs entity))))))
 
@@ -488,7 +510,7 @@
                 (= (:name (:attrs %)) (:entity (:attrs property)))))
         unique? (unique-link? e1 e2)
         link-table-name (link-table-name property e1 e2)]
-    (if
+    (when
       ;; we haven't already emitted this one...
       (not (@emitted-link-tables link-table-name))
       (let [permissions (flatten
@@ -506,7 +528,7 @@
                                     [(construct-link-property e1)
                                      (construct-link-property e2)]
                                     permissions)))}]
-        (if-not unique?
+        (when-not unique?
           (*warn*
            (str "WARNING: Manually check link tables between "
                 (-> e1 :attrs :name)
@@ -547,8 +569,8 @@
 
 
 (defn emit-group-declaration
-  "Emit a declaration for this authorisation `group` within this `application`."
-  [group application]
+  "Emit a declaration for this authorisation `group`."
+  [group]
   (list
     (emit-header
       "--"
@@ -585,7 +607,7 @@
         (list
           (emit-file-header application)
           (map
-            #(emit-group-declaration % application)
+            #(emit-group-declaration %)
             (sort-by-name
               (children-with-tag application :group)))
           (map
@@ -611,7 +633,7 @@
     (make-parents filepath)
     (do-or-warn
       (spit filepath (emit-application application))
-      (if
+      (when
         (pos? *verbosity*)
         (*warn* (str "\tGenerated " filepath))))))
 

src/adl/to_selmer_routes.clj

@@ -176,7 +176,7 @@
           (*warn*
            (str
             "Entity '"
-            (-> entity :attrs :name)
+            (or (-> entity :attrs :name) entity)
             "' passed to compose-fetch-auxlist-data is a non-entity")))
         (if-not
           (entity? farside)

src/adl/to_swagger.clj

@@ -2,7 +2,7 @@
       :author "Simon Brooke"}
   adl.to-swagger
   (:require [adl-support.utils :refer :all]
-            [adl.to-hugsql-queries :refer [queries]]
+            [adl.to-hugsql-queries :refer [generate-documentation queries]]
             [clj-time.core :as t]
             [clj-time.format :as f]
             [clojure.java.io :refer [file make-parents writer]]
@@ -43,21 +43,98 @@
   (list
     'ns
     (symbol (str (safe-name (:name (:attrs application))) ".routes.auto-api"))
-    (str "API routes for " (:name (:attrs application))
+    (str "Swagger routes for " (:name (:attrs application))
          " auto-generated by [Application Description Language framework](https://github.com/simon-brooke/adl) at "
          (f/unparse (f/formatters :basic-date-time) (t/now)))
     (list
       :require
-      '[adl-support.core :as support]
-      '[clj-http.client :as client]
-      '[clojure.tools.logging :as log]
-      '[compojure.api.sweet :refer :all]
-      '[hugsql.core :as hugsql]
+      '[reitit.swagger :as swagger]
+      '[reitit.swagger-ui :as swagger-ui]
+      '[reitit.ring.coercion :as coercion]
+      '[reitit.coercion.spec :as spec-coercion]
+      '[reitit.ring.middleware.muuntaja :as muuntaja]
+      '[reitit.ring.middleware.multipart :as multipart]
+      '[reitit.ring.middleware.parameters :as parameters]
+      '[placenames.middleware.formats :as formats]
+      '[placenames.middleware.exception :as exception]
+      '[placenames.routes.auto-jason :as aj]
       '[ring.util.http-response :refer :all]
-      '[noir.response :as nresponse]
-      '[noir.util.route :as route]
-      '[ring.util.http-response :as response]
-      '[schema.core :as s]
-      (vector (symbol (str (safe-name (:name (:attrs application))) ".db.core")) :as 'db))))
+      '[clojure.java.io :as io])))
 
 
+
+(defn def-routes
+  "Generate Swagger routes for all queries implied by this ADL `application` spec."
+  ;; THIS ISN'T NEARLY FINISHED!
+  ([application]
+   (list 'defn 'auto-api-routes []
+  ["/api"
+   {:coercion spec-coercion/coercion
+    :muuntaja formats/instance
+    :swagger {:id ::api}
+    :middleware [;; query-params & form-params
+                 parameters/parameters-middleware
+                 ;; content-negotiation
+                 muuntaja/format-negotiate-middleware
+                 ;; encoding response body
+                 muuntaja/format-response-middleware
+                 ;; exception handling
+                 exception/exception-middleware
+                 ;; decoding request body
+                 muuntaja/format-request-middleware
+                 ;; coercing response bodys
+                 coercion/coerce-response-middleware
+                 ;; coercing request parameters
+                 coercion/coerce-request-middleware
+                 ;; multipart
+                 multipart/multipart-middleware]}]
+     (map #(def-routes application %)
+          (children-with-tag application :entity)))
+  ([application entity]
+   [(str "/" (safe-name entity))
+    {:get (make-get-route entity)
+  (cons
+    'defroutes
+    (cons
+      'auto-rest-routes
+      (map
+        #(let [handler (handlers-map %)]
+           (list
+             (symbol (s/upper-case (name (:method handler))))
+             (str "/json/auto/" (safe-name (:name handler)))
+             'request
+             (list
+               'route/restricted
+               (list (:name handler) 'request))))
+        (sort
+          (keys handlers-map)))))}])))
+
+
+(defn to-swagger
+  "Generate a Swagger API for all queries implied by this ADL `application` spec."
+  [application]
+  (let [filepath (str
+                   *output-path*
+                   "src/"
+                   (safe-name (:name (:attrs application)))
+                   "/routes/auto_api.clj")]
+    (make-parents filepath)
+    (do-or-warn
+      (do
+        (spit
+          filepath
+          (s/join
+            "\n\n"
+            (cons
+              (file-header application)
+              (map
+                (fn [q]
+                  (str
+                    ;; THIS ISN'T NEARLY FINISHED!
+                    ))
+                (sort
+                  #(compare (:name %1) (:name %2))
+                  (vals
+                    (queries application)))))))
+        (if (pos? *verbosity*)
+          (*warn* (str "\tGenerated " filepath)))))))

src/adl/validator.clj

@@ -43,7 +43,7 @@
    (symbol? validation)
     (try
       (b/validate o validation)
-      (catch java.lang.ClassCastException _
+      (catch java.lang.ClassCastException c
         ;; The validator regularly barfs on strings, which are perfectly
         ;; valid content of some elements. I need a way to validate
         ;; elements where they're not tolerated!
@@ -227,10 +227,10 @@
    Markdown (which may include a string representation of HTML markup) should
    be."
   {:tag [v/required [#(= % :documentation)]]
-    :content [[v/every  #(disjunct-valid?
-                          %
-                        v/string
-                        reference-validations)]]})
+   :content [[v/every  #(disjunct-valid?
+                         %
+                         v/string
+                         reference-validations)]]})
 
 ;; (def sample-documentation {:tag :documentation
 ;;                            :content ["Every animal should have a breed."
@@ -328,6 +328,8 @@
    [:attrs :name] [v/string v/required]
    [:attrs :value] [v/string v/required]})
 
+
+
 (def generator-validations
   "marks a property which is auto-generated by some part of the system.
   This is based on the Hibernate construct, except that the Hibernate
@@ -469,14 +471,13 @@
    [:attrs :column] v/string
    [:attrs :concrete] [[v/member #{"true", "false"}]]
    :content [[v/every #(disjunct-valid? %
-                         documentation-validations
-                         generator-validations
-                         permission-validations
-                         option-validations
-                         prompt-validations
-                         help-validations
-                         ifmissing-validations)]]
-   })
+                                        documentation-validations
+                                        generator-validations
+                                        permission-validations
+                                        option-validations
+                                        prompt-validations
+                                        help-validations
+                                        ifmissing-validations)]]})
 
 ;; (disjunct-valid? sample-option documentation-validations
 ;;                                generator-validations

test/adl/to_hugsql_queries_test.clj

@@ -62,6 +62,7 @@
             actual (order-by-clause entity)]
         (is (string-equal-ignore-whitespace? actual expected))))))
 
+
 (deftest keys-name-extraction-tests
   (let [application {:tag :application,
                      :attrs {:version "0.1.1", :name "test-app"},
@@ -241,7 +242,9 @@
     (testing "delete query signature"
       (let [expected ":! :n"
             actual (:signature (first (vals (delete-query entity))))]
-        (is (string-equal-ignore-whitespace? actual expected))))))
+        (is (string-equal-ignore-whitespace? actual expected))))
+
+  ))
 
 (deftest complex-key-tests
   (let [application {:tag :application,

test/adl/to_psql_test.clj

@@ -0,0 +1,549 @@
+(ns adl.to-psql-test
+  (:require
+   [adl-support.utils :refer [child child-with-tag]]
+   [adl.to-psql :refer [emit-convenience-entity-field emit-convenience-view
+                        emit-property emit-table]]
+   [clojure.test :refer [deftest is testing]]))
+
+;; (deftest link-property-test
+;;   (testing "No field generated for link property"
+
+
+(deftest to-psql-tests
+  (let [application {:tag :application,
+                     :attrs {:version "0.1.1",
+                             :name "youyesyet",
+                             :xmlns:adl "http://www.journeyman.cc/adl/1.4.7/",
+                             :xmlns:html "http://www.w3.org/1999/xhtml",
+                             :xmlns "http://www.journeyman.cc/adl/1.4.7/"}
+                     :content
+                     [{:tag :typedef,
+                       :attrs
+                       {:size "16",
+                        :pattern
+                        "^([Gg][Ii][Rr] 0[Aa]{2})|((([A-Za-z][0-9]{1,2})|(([A-Za-z][A-Ha-hJ-Yj-y][0-9]{1,2})|(([AZa-z][0-9][A-Za-z])|([A-Za-z][A-Ha-hJ-Yj-y][0-9]?[A-Za-z]))))[0-9][A-Za-z]{2})$",
+                        :type "string",
+                        :name "postcode"},
+                       :content
+                       [{:tag :documentation,
+                         :attrs nil,
+                         :content
+                         ["See\n    https://assets.publishing.service.gov.uk/government/uploads/system/uploads/attachment_data/file/488478/Bulk_Data_Transfer_-_additional_validation_valid_from_12_November_2015.pdf,\n    section 3"]}
+                        {:tag :help,
+                         :attrs {:locale "en_GB.UTF-8"},
+                         :content ["A valid postcode."]}]}
+                      {:tag :entity,
+                       :attrs
+                       {:volatility "6",
+                        :magnitude "6",
+                        :name "addresses",
+                        :table "addresses"},
+                       :content
+                       [{:tag :documentation,
+                         :attrs nil,
+                         :content
+                         ["Addresses of all buildings which contain\n    dwellings."]}
+                        {:tag :key,
+                         :attrs nil,
+                         :content
+                         [{:tag :property,
+                           :attrs
+                           {:distinct "system",
+                            :immutable "true",
+                            :column "id",
+                            :name "id",
+                            :type "integer",
+                            :required "true"},
+                           :content
+                           [{:tag :generator, :attrs {:action "native"}, :content nil}]}]}
+                        {:tag :property,
+                         :attrs
+                         {:distinct "user",
+                          :size "256",
+                          :column "address",
+                          :name "address",
+                          :type "string",
+                          :required "true"},
+                         :content
+                         [{:tag :prompt,
+                           :attrs {:locale "en_GB.UTF-8", :prompt "Address"},
+                           :content nil}]}
+                        {:tag :property,
+                         :attrs
+                         {:distinct "user",
+                          :size "16",
+                          :column "postcode",
+                          :name "postcode",
+                          :typedef "postcode",
+                          :type "defined"},
+                         :content
+                         [{:tag :prompt,
+                           :attrs {:locale "en_GB.UTF-8", :prompt "Postcode"},
+                           :content nil}]}
+                        {:tag :property,
+                         :attrs
+                         {:farkey "id",
+                          :entity "districts",
+                          :column "district_id",
+                          :name "district_id",
+                          :type "entity"},
+                         :content
+                         [{:tag :prompt,
+                           :attrs {:locale "en_GB.UTF-8", :prompt "District"},
+                           :content nil}]}
+                        {:tag :property,
+                         :attrs {:column "latitude", :name "latitude", :type "real"},
+                         :content
+                         [{:tag :prompt,
+                           :attrs {:locale "en_GB.UTF-8", :prompt "Latitude"},
+                           :content nil}]}
+                        {:tag :property,
+                         :attrs {:column "longitude", :name "longitude", :type "real"},
+                         :content
+                         [{:tag :prompt,
+                           :attrs {:locale "en_GB.UTF-8", :prompt "Longitude"},
+                           :content nil}]}
+                        {:tag :property,
+                         :attrs
+                         {:farkey "address_id",
+                          :entity "dwellings",
+                          :name "dwellings",
+                          :type "list"},
+                         :content nil}
+                        {:tag :property,
+                         :attrs {:column "locality", :name "locality", :type "integer"},
+                         :content
+                         [{:tag :documentation,
+                           :attrs nil,
+                           :content
+                           ["Locality indexing; see issue #44. Note that\n      this property should be generated automatically from the\n      latitude and longitude: (+ (* 10000 ;; left-shift the\n      latitude component four digits (integer (* latitude 1000)))\n      (- ;; invert the sign of the longitude component, since ;;\n      we're interested in localities West of Greenwich. (integer (*\n      longitude 1000)))) We'll use a trigger to insert this. I\n      don't think it will ever appear in the user interface; it's\n      an implementation detail, not of interest to\n      users."]}
+                          {:tag :generator, :attrs {:action "native"}, :content nil}]}
+                        {:tag :list,
+                         :attrs {:name "Addresses", :properties "listed"},
+                         :content
+                         [{:tag :field,
+                           :attrs {:property "address"},
+                           :content
+                           [{:tag :prompt,
+                             :attrs {:locale "en_GB.UTF-8", :prompt "Address"},
+                             :content nil}]}
+                          {:tag :field,
+                           :attrs {:property "postcode"},
+                           :content
+                           [{:tag :prompt,
+                             :attrs {:locale "en_GB.UTF-8", :prompt "Postcode"},
+                             :content nil}]}
+                          {:tag :field,
+                           :attrs {:property "district_id"},
+                           :content
+                           [{:tag :prompt,
+                             :attrs {:locale "en_GB.UTF-8", :prompt "District"},
+                             :content nil}]}]}
+                        {:tag :form,
+                         :attrs {:name "Address", :properties "listed"},
+                         :content
+                         [{:tag :field,
+                           :attrs {:property "address"},
+                           :content
+                           [{:tag :prompt,
+                             :attrs {:locale "en_GB.UTF-8", :prompt "Address"},
+                             :content nil}]}
+                          {:tag :field,
+                           :attrs {:property "postcode"},
+                           :content
+                           [{:tag :prompt,
+                             :attrs {:locale "en_GB.UTF-8", :prompt "Postcode"},
+                             :content nil}]}
+                          {:tag :field,
+                           :attrs {:property "district_id"},
+                           :content
+                           [{:tag :prompt,
+                             :attrs {:locale "en_GB.UTF-8", :prompt "District"},
+                             :content nil}]}
+                          {:tag :field,
+                           :attrs {:property "latitude"},
+                           :content
+                           [{:tag :prompt,
+                             :attrs {:locale "en_GB.UTF-8", :prompt "Latitude"},
+                             :content nil}]}
+                          {:tag :field,
+                           :attrs {:property "longitude"},
+                           :content
+                           [{:tag :prompt,
+                             :attrs {:locale "en_GB.UTF-8", :prompt "Longitude"},
+                             :content nil}]}
+                          {:tag :auxlist,
+                           :attrs
+                           {:canadd "true",
+                            :onselect "form-dwellings-Dwelling",
+                            :property "dwellings"},
+                           :content
+                           [{:tag :field,
+                             :attrs {:property "sub-address"},
+                             :content
+                             [{:tag :prompt,
+                               :attrs {:locale "en_GB.UTF-8", :prompt "Sub-address"},
+                               :content nil}]}]}]}
+                        {:tag :permission,
+                         :attrs {:permission "read", :group "canvassers"},
+                         :content nil}
+                        {:tag :permission,
+                         :attrs {:permission "read", :group "teamorganisers"},
+                         :content nil}
+                        {:tag :permission,
+                         :attrs {:permission "read", :group "issueexperts"},
+                         :content nil}
+                        {:tag :permission,
+                         :attrs {:permission "read", :group "analysts"},
+                         :content nil}
+                        {:tag :permission,
+                         :attrs {:permission "read", :group "issueeditors"},
+                         :content nil}
+                        {:tag :permission,
+                         :attrs {:permission "all", :group "admin"},
+                         :content nil}]}
+
+                      {:tag :entity,
+                       :attrs
+                       {:volatility "6",
+                        :magnitude "6",
+                        :name "dwellings",
+                        :table "dwellings"},
+                       :content
+                       [{:tag :documentation,
+                         :attrs nil,
+                         :content
+                         ["All dwellings within addresses in the system; a\n    dwelling is a house, flat or appartment in which electors live.\n    Every address should have at least one dwelling; essentially,\n    an address maps onto a street door and dwellings map onto\n    what's behind that door. So a tenement or a block of flats\n    would be one address with many dwellings."]}
+                        {:tag :key,
+                         :attrs nil,
+                         :content
+                         [{:tag :property,
+                           :attrs
+                           {:distinct "system",
+                            :immutable "true",
+                            :column "id",
+                            :name "id",
+                            :type "integer",
+                            :required "true"},
+                           :content
+                           [{:tag :generator, :attrs {:action "native"}, :content nil}]}]}
+                        {:tag :property,
+                         :attrs
+                         {:distinct "user",
+                          :farkey "id",
+                          :entity "addresses",
+                          :column "address_id",
+                          :name "address_id",
+                          :type "entity",
+                          :required "true"},
+                         :content
+                         [{:tag :prompt,
+                           :attrs {:locale "en_GB.UTF-8", :prompt "Building Address"},
+                           :content nil}]}
+                        {:tag :property,
+                         :attrs
+                         {:distinct "user",
+                          :name "sub-address",
+                          :size "32",
+                          :type "string",
+                          :required "false"},
+                         :content
+                         [{:tag :documentation,
+                           :attrs nil,
+                           :content
+                           ["\n        The part of the address which identifies the flat or\n        apartment within the building, if in a multiple occupancy\n        building.\n      "]}]}
+                        {:tag :property,
+                         :attrs {:entity "electors", :name "electors", :type "list"},
+                         :content nil}
+                        {:tag :list,
+                         :attrs {:name "Dwellings", :properties "listed"},
+                         :content
+                         [{:tag :field,
+                           :attrs {:property "address_id"},
+                           :content
+                           [{:tag :prompt,
+                             :attrs {:locale "en_GB.UTF-8", :prompt "Building Address"},
+                             :content nil}]}
+                          {:tag :field,
+                           :attrs {:property "sub-address"},
+                           :content
+                           [{:tag :prompt,
+                             :attrs {:locale "en_GB.UTF-8", :prompt "Sub address"},
+                             :content nil}]}]}
+                        {:tag :form,
+                         :attrs {:name "Dwelling", :properties "listed"},
+                         :content
+                         [{:tag :field,
+                           :attrs {:property "address_id"},
+                           :content
+                           [{:tag :prompt,
+                             :attrs {:locale "en_GB.UTF-8", :prompt "Building Address"},
+                             :content nil}]}
+                          {:tag :field,
+                           :attrs {:property "sub-address"},
+                           :content
+                           [{:tag :prompt,
+                             :attrs
+                             {:locale "en_GB.UTF-8",
+                              :prompt "Sub address (e.g. flat number)"},
+                             :content nil}]}]}
+                        {:tag :permission,
+                         :attrs {:permission "read", :group "canvassers"},
+                         :content nil}
+                        {:tag :permission,
+                         :attrs {:permission "read", :group "teamorganisers"},
+                         :content nil}
+                        {:tag :permission,
+                         :attrs {:permission "read", :group "issueexperts"},
+                         :content nil}
+                        {:tag :permission,
+                         :attrs {:permission "read", :group "analysts"},
+                         :content nil}
+                        {:tag :permission,
+                         :attrs {:permission "read", :group "issueeditors"},
+                         :content nil}
+                        {:tag :permission,
+                         :attrs {:permission "all", :group "admin"},
+                         :content nil}]}
+                      {:tag :entity,
+                       :attrs
+                       {:volatility "7",
+                        :magnitude "4",
+                        :name "districts",
+                        :table "districts"},
+                       :content
+                       [{:tag :documentation,
+                         :attrs nil,
+                         :content
+                         ["Electoral districts: TODO: Shape (polygon)\n    information will need to be added, for use in\n    maps."]}
+                        {:tag :key,
+                         :attrs nil,
+                         :content
+                         [{:tag :property,
+                           :attrs
+                           {:distinct "system",
+                            :immutable "true",
+                            :column "id",
+                            :name "id",
+                            :type "integer",
+                            :required "true"},
+                           :content
+                           [{:tag :generator, :attrs {:action "native"}, :content nil}]}]}
+                        {:tag :property,
+                         :attrs
+                         {:distinct "user",
+                          :size "64",
+                          :column "name",
+                          :name "name",
+                          :type "string",
+                          :required "true"},
+                         :content
+                         [{:tag :prompt,
+                           :attrs {:locale "en_GB.UTF-8", :prompt "name"},
+                           :content nil}]}
+                        {:tag :permission,
+                         :attrs {:permission "read", :group "public"},
+                         :content nil}
+                        {:tag :permission,
+                         :attrs {:permission "all", :group "admin"},
+                         :content nil}
+                        {:tag :list,
+                         :attrs {:name "Districts", :properties "listed"},
+                         :content
+                         [{:tag :field,
+                           :attrs {:property "name"},
+                           :content
+                           [{:tag :prompt,
+                             :attrs {:locale "en_GB.UTF-8", :prompt "name"},
+                             :content nil}]}]}
+                        {:tag :form,
+                         :attrs {:name "District", :properties "listed"},
+                         :content
+                         [{:tag :field,
+                           :attrs {:property "name"},
+                           :content
+                           [{:tag :prompt,
+                             :attrs {:locale "en_GB.UTF-8", :prompt "name"},
+                             :content nil}]}]}
+                        {:tag :permission,
+                         :attrs {:permission "read", :group "canvassers"},
+                         :content nil}
+                        {:tag :permission,
+                         :attrs {:permission "read", :group "teamorganisers"},
+                         :content nil}
+                        {:tag :permission,
+                         :attrs {:permission "read", :group "issueexperts"},
+                         :content nil}
+                        {:tag :permission,
+                         :attrs {:permission "read", :group "analysts"},
+                         :content nil}
+                        {:tag :permission,
+                         :attrs {:permission "read", :group "issueeditors"},
+                         :content nil}
+                        {:tag :permission,
+                         :attrs {:permission "all", :group "admin"},
+                         :content nil}]}
+                      ]}
+        address-entity (child-with-tag application :entity #(= (-> % :attrs :name) "addresses"))
+        dwelling-entity (child-with-tag application :entity #(= (-> % :attrs :name) "dwellings"))]
+    (testing "varchar field"
+      (let [property (child-with-tag address-entity :property #(= (-> % :attrs :name) "address"))
+            expected "\t address VARCHAR(256) NOT NULL"
+            actual (emit-property property address-entity application false)]
+        (is (= actual expected))))
+    (testing "integer field"
+      (let [property (child-with-tag address-entity :property #(= (-> % :attrs :name) "locality"))
+            expected "\t locality INTEGER"
+            actual (emit-property property address-entity application false)]
+        (is (= actual expected))))
+    (testing "real field"
+      (let [property (child-with-tag address-entity :property #(= (-> % :attrs :name) "longitude"))
+            expected "\t longitude DOUBLE PRECISION"
+            actual (emit-property property address-entity application false)]
+        (is (= actual expected))))
+    (testing "list field"
+      (let [property (child-with-tag address-entity :property #(= (-> % :attrs :name) "dwellings"))
+            actual (emit-property property address-entity application false)]
+        (is (nil? actual))))
+    (testing "entity field"
+      (let [property (child-with-tag address-entity :property #(= (-> % :attrs :name) "district_id"))
+            expected "\t district_id INTEGER"
+            actual (emit-property property address-entity application false)]
+        (is (= actual expected))))
+
+    ;;       (testing "pattern field"
+    ;;         (let [property (child-with-tag address-entity :property #(= (-> % :attrs :name) "postcode"))
+    ;;               expected #"\t postcode VARCHAR(16) CONSTRAINT pattern_\d+ CHECK (postcode ~* '^([Gg][Ii][Rr] 0[Aa]{2})|((([A-Za-z][0-9]{1,2})|(([A-Za-z][A-Ha-hJ-Yj-y][0-9]{1,2})|(([AZa-z][0-9][A-Za-z])|([A-Za-z][A-Ha-hJ-Yj-y][0-9]?[A-Za-z]))))[0-9][A-Za-z]{2})$')"
+    ;;               actual (emit-property property address-entity application false)]
+    ;;           ;; slightly tricky because the pattern name is gensymed.
+    ;;           (is (= actual expected))
+    ;;           (is (string? (re-find expected actual)))))
+    (testing "Table creation"
+      (let [expected "------------------------------------------------------------------------\n--\tTest doc \n--\t\n--\tAll dwellings within addresses in the system; a\n--\t    dwelling is a house, flat or appartment in which electors live.\n--\t    Every address should have at least one dwelling; essentially,\n--\t    an address maps onto a street door and dwellings map onto\n--\t    what's behind that door. So a tenement or a block of flats\n--\t    would be one address with many dwellings. \n------------------------------------------------------------------------\nCREATE TABLE dwellings\n(\n\t id SERIAL NOT NULL PRIMARY KEY,\n\t address_id INTEGER NOT NULL,\n\t sub_address VARCHAR(32)\n);\nGRANT SELECT ON dwellings TO admin,\n\tanalysts,\n\tcanvassers,\n\tissueeditors,\n\tissueexperts,\n\tteamorganisers ;\nGRANT INSERT ON dwellings TO admin ;\nGRANT UPDATE ON dwellings TO admin ;\nGRANT DELETE ON dwellings TO admin ;"
+            actual (emit-table dwelling-entity application "Test doc")]
+        (is (= actual expected))))
+    (testing "Convenience entity field - is an entity field, should emit"
+      (let [property (child-with-tag address-entity :property #(= (-> % :attrs :name) "district_id"))
+            expected "district_id.name AS district_id_expanded"
+            actual (emit-convenience-entity-field property address-entity application)]
+        (is (= actual expected))))
+
+    (testing "Convenience entity field - is not an entity field, should not emit"
+      (let [farside dwelling-entity
+            property (child-with-tag address-entity :property #(= (-> % :attrs :name) "dwellings"))
+            expected nil
+            actual (emit-convenience-entity-field property address-entity application)]
+        (is (= actual expected))))
+
+    ))
+
+(deftest bug-9-test
+  (testing "Correct reference to aliased tables in convenience view select queries
+    see [bug 9](https://github.com/simon-brooke/adl/issues/9)"
+    (let [app
+          {:tag :application,
+           :attrs {:version "0.0.1",
+                   :name "pastoralist",
+                   :xmlns:adl "http://www.journeyman.cc/adl/1.4.7/",
+                   :xmlns:html "http://www.w3.org/1999/xhtml",
+                   :xmlns "http://www.journeyman.cc/adl/1.4.7/"},
+           :content [{:tag :documentation,
+                      :attrs nil,
+                      :content ["A web-app intended to be used by pastoralists in managing
+                                pastures, grazing, and animals."]}
+                     {:tag :entity,
+                      :attrs {:volatility "5", :magnitude "9", :name "animal" :table "animal"},
+                      :content
+                      [{:tag :key,
+                        :attrs nil,
+                        :content
+                        [{:tag :property,
+                          :attrs
+                          {:distinct "system",
+                           :immutable "true",
+                           :column "id",
+                           :name "id",
+                           :type "integer",
+                           :required "true"},
+                          :content
+                          [{:tag :generator, :attrs {:action "native"}, :content nil}]}]}
+                       {:tag :property,
+                        :attrs {:entity "animal", :type "entity", :name "dam"},
+                        :content nil}
+                       {:tag :property,
+                        :attrs {:entity "animal", :type "entity", :name "sire"},
+                        :content nil}
+                       {:tag :property,
+                        :attrs
+                        {:required "true",
+                         :distinct "user",
+                         :size "64",
+                         :type "string",
+                         :name "animal-identifier"},
+                        :content
+                        [{:tag :prompt,
+                          :attrs {:locale "en_GB.UTF-8", :prompt "Ear-tag Number"},
+                          :content nil}]}
+                       {:tag :property,
+                        :attrs {:distinct "user", :size "64", :type "string", :name "name"},
+                        :content nil}]}]}
+          animal (child app #(= (-> % :attrs :name) "animal"))
+          dam (child animal #(= (-> % :attrs :name) "dam"))]
+      (let [actual (emit-convenience-view animal app)
+            should-find #"dam.animal_identifier"
+            should-not-find #"animal.name AS dam_expanded"]
+        ;; (print actual) ;; see what we've got
+        (is (re-find should-find actual))
+        (is (nil? (re-find should-not-find actual)))))))
+
+(deftest bug-10-test
+  (testing "Correct table names in convenience view select queries
+    see [bug 10](https://github.com/simon-brooke/adl/issues/10)"
+    (let [app
+          {:tag :application,
+           :attrs {:version "0.0.1",
+                   :name "pastoralist",
+                   :xmlns:adl "http://www.journeyman.cc/adl/1.4.7/",
+                   :xmlns:html "http://www.w3.org/1999/xhtml",
+                   :xmlns "http://www.journeyman.cc/adl/1.4.7/"},
+           :content [{:tag :documentation,
+                      :attrs nil,
+                      :content ["A web-app intended to be used by pastoralists in managing
+                                pastures, grazing, and animals."]}
+                     {:tag :entity,
+                        :attrs
+                        {:volatility "5",
+                         :magnitude "3",
+                         :name "event-type",
+                         :table "event-type"},
+                        :content
+                        [{:tag :key,
+                          :attrs nil,
+                          :content
+                          [{:tag :property,
+                            :attrs
+                            {:distinct "system",
+                             :immutable "true",
+                             :column "id",
+                             :name "id",
+                             :type "integer",
+                             :required "true"},
+                            :content
+                            [{:tag :generator, :attrs {:action "native"}, :content nil}]}]}
+                         {:tag :property,
+                          :attrs {:size "80", :type "string", :name "summary"},
+                          :content nil}
+                         {:tag :property,
+                          :attrs {:type "text", :name "description"},
+                          :content nil}
+                         {:tag :property,
+                          :attrs {:default "1", :type "integer", :name "n-holdings"},}
+                         {:tag :property,
+                          :attrs {:default "1", :type "integer", :name "n-pastures"}}
+                         {:tag :property,
+                          :attrs {:default "1", :type "integer", :name "n-animals"}}]}]}
+          should-find #"event_type.description"
+          should-not-find #"event-type.description"
+          actual (emit-convenience-view (child app #(= (-> % :attrs :name) "event-type")) app)]
+      (is (re-find should-find actual))
+      (is (nil? (re-find should-not-find actual))))))

test/adl/validator_test.clj

@@ -125,10 +125,10 @@
     (let [xml {:tag :group,
                :attrs {:name "public"},
                :content
-               [{:tag :documentation, :attrs nil, :content ["All users"]}]}
-          expected true
+               [{:tag :documentation, :content ["All users"]}]}
+          expected nil
           actual (binding [*out* (writer "/dev/null")]
-                   (valid? xml group-validations))]
+                   (first (validate xml group-validations)))]
       (is (= actual expected)))))
 
 (deftest validator-entity
@@ -334,7 +334,7 @@
                    :content nil}]}]}
           expected true
           actual (binding [*out* (writer "/dev/null")]
-                   (valid? xml entity-validations))]
+                   (valid? xml property-validations))]
       (is (= actual expected)))))