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,10 +31,10 @@
 ;;;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
- (def expanded-token "_expanded")
+(def expanded-token "_expanded")
 
 
- (defn where-clause
+(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."
@@ -54,7 +54,7 @@
              property-names)))))))
 
 
- (defn order-by-clause
+(defn order-by-clause
   "Generate an appropriate `order by` clause for queries on this `entity`"
   ([entity]
    (order-by-clause entity "" false))
@@ -87,7 +87,7 @@
 ;; (order-by-clause e "" true)
 
 
- (defn insert-query
+(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."
@@ -126,7 +126,7 @@
                        (key-names entity))))))})))
 
 
- (defn update-query
+(defn update-query
   "Generate an appropriate `update` query for this `entity`"
   [entity]
   (let [entity-name (safe-name entity :sql)
@@ -168,7 +168,7 @@
         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
@@ -223,6 +223,7 @@
 
 ;; (search-query e a)
 
+
 (defn select-query
   "Generate an appropriate `select` query for this `entity`"
   ([entity properties]
@@ -450,7 +451,7 @@
                (pr-str
                  (map
                    #(keyword (:name (:attrs %)))
-               (-> query :entity insertable-properties)))
+                   (-> query :entity insertable-properties )))
                "`. Returns a map containing the keys `"
                (-> query :entity key-names)
                "` identifying the record created.")

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]
+  (: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]))
+   [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,22 +306,27 @@
 
 
 (defn emit-convenience-entity-field
-  [field entity application]
+  ([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 field entity application))
+         (compose-convenience-entity-field property entity application table-alias))
        " AS "
-    (field-name field)
-    "_expanded"))
+       (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
+  (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
@@ -325,21 +345,23 @@
               "SELECT "
               (s/join
                 ",\n\t"
+                (remove
+                  nil?
                   (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) )))))
+                           (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?
+                 (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!
@@ -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
@@ -475,8 +477,7 @@
                                         option-validations
                                         prompt-validations
                                         help-validations
-                         ifmissing-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)))))