Merge branch 'feature/5' into develop

project.clj

@@ -5,7 +5,7 @@
   :license {:name "GNU Lesser General Public License, version 3.0 or (at your option) any later version"
             :url "https://www.gnu.org/licenses/lgpl-3.0.en.html"}
 
-  :dependencies [[adl-support "0.1.3"]
+  :dependencies [[adl-support "0.1.4-SNAPSHOT"]
                  [bouncer "1.0.1"]
                  [clojure-saxon "0.9.4"]
                  [environ "1.1.0"]
@@ -19,7 +19,10 @@
   :main adl.main
 
   :plugins [[lein-codox "0.10.3"]
-            [lein-release "1.0.5"]]
+            [lein-kibit "0.1.6"]
+            [lein-release "1.0.5"]
+            ;; [uncomplexor "0.1.0-SNAPSHOT"]
+            ]
 
 ;;   :lein-release {:scm :git
 ;;                  :deploy-via :clojars} ;; :deploy-via :clojars fails - with an scp error.

src/adl/main.clj

@@ -92,7 +92,6 @@
 (defn process
   "Process these parsed `options`."
   [options]
-  (do
   (let [p (:path (:options options))
         op (if (.endsWith p "/") p (str p "/"))]
     (binding [*output-path* op
@@ -110,7 +109,7 @@
              (s/to-selmer-routes application)
              (t/to-selmer-templates application))
            (*warn* (str "ERROR: File not found: " %)))
-            (-> options :arguments)))))))
+        (:arguments options))))))
 
 
 (defn -main
@@ -121,7 +120,7 @@
     (cond
       (empty? args)
       (usage options)
-      (not (empty? (:errors options)))
+      (seq (:errors options))
       (do
         (doall
           (map

src/adl/to_hugsql_queries.clj

@@ -1,7 +1,7 @@
 (ns ^{:doc "Application Description Language - generate HUGSQL queries file."
       :author "Simon Brooke"}
   adl.to-hugsql-queries
-  (:require [adl-support.core :refer [*warn*]]
+  (:require [adl-support.core :refer :all]
             [adl-support.utils :refer :all]
             [clojure.java.io :refer [file make-parents]]
             [clojure.math.combinatorics :refer [combinations]]
@@ -46,8 +46,7 @@
    (let
      [entity-name (:name (:attrs entity))
       property-names (map #(:name (:attrs %)) properties)]
-     (if
+     (if-not (empty? property-names)
-       (not (empty? property-names))
        (str
         "WHERE "
         (s/join
@@ -213,8 +212,8 @@
 (defn select-query
   "Generate an appropriate `select` query for this `entity`"
   ([entity properties]
-   (if
+   (if-not
-     (not (empty? properties))
+     (empty? properties)
      (let [entity-name (safe-name (:name (:attrs entity)) :sql)
            pretty-name (singularise entity-name)
            query-name (if (= properties (key-properties entity))
@@ -384,7 +383,8 @@
   [application]
   (let [filepath (str *output-path* "resources/sql/queries.auto.sql")]
     (make-parents filepath)
-    (try
+    (do-or-warn
+     (do
        (spit
         filepath
         (s/join
@@ -396,20 +396,11 @@
            (str "autogenerated by adl.to-hugsql-queries at " (t/now))
            "See [Application Description Language](https://github.com/simon-brooke/adl).")
           (map
-              #(:query %)
+           :query
            (sort
             #(compare (:name %1) (:name %2))
             (vals
              (queries application)))))))
-      (if (> *verbosity* 0)
+       (if (pos? *verbosity*)
-        (*warn* (str "\tGenerated " filepath)))
+         (*warn* (str "\tGenerated " filepath)))))))
-      (catch
-        Exception any
-        (*warn*
-          (str
-            "ERROR: Exception "
-            (.getName (.getClass any))
-            (.getMessage any)
-            " while printing "
-            filepath))))))
 

src/adl/to_json_routes.clj

@@ -1,7 +1,7 @@
 (ns ^{:doc "Application Description Language: generate RING routes for REST requests."
       :author "Simon Brooke"}
   adl.to-json-routes
-  (:require [adl-support.core :refer [*warn*]]
+  (:require [adl-support.core :refer :all]
             [adl-support.utils :refer :all]
             [adl.to-hugsql-queries :refer [queries]]
             [clj-time.core :as t]
@@ -53,7 +53,8 @@
          (f/unparse (f/formatters :basic-date-time) (t/now)))
     (list
       :require
-      '[adl-support.core :as support]
+      '[adl-support.core :refer :all]
+      '[adl-support.rest-support :refer :all]
       '[clojure.core.memoize :as memo]
       '[clojure.java.io :as io]
       '[clojure.tools.logging :as log]
@@ -72,28 +73,38 @@
 (defn generate-handler-body
   "Generate and return the function body for the handler for this `query`."
   [query]
-  (let [action (list
-                 (symbol (str "db/" (:name query)))
-                 'db/*db*
-                 (list 'support/massage-params
-                       'params
-                       'form-params
-                       (key-names (:entity query))))]
   (list
-     [{:keys ['params 'form-params]}]
+   ['request]
-     (case
-       (:type query)
-       (:delete-1 :update-1)
-       (list
-         action
-         `(log/debug (str ~(:name query) " called with params " ~'params "."))
-         '(response/found "/"))
    (list
     'let
-         (vector 'result action)
+    ['params '(massage-params request)]
-         `(log/debug (~(symbol (str "db/" (:name query) "-sqlvec")) ~'params))
+    (list
-         `(log/debug (str ~(str "'" (:name query) "' with params ") ~'params " returned " (count ~'result) " records."))
+     'valid-user-or-forbid
-         (list 'response/ok 'result))))))
+     (list
+      'with-params-or-error
+      (list
+       'do-or-server-fail
+       (list
+        (symbol (str "db/" (:name query)))
+        'db/*db*
+        'params)
+       (case (:type query)
+         :insert-1 201 ;; created
+         :delete-1 204 ;; no content
+         ;; default
+         200)) ;; OK
+      'params
+      (set
+       (map
+        #(keyword (:name (:attrs %)))
+        (case (:type query)
+          (:insert-1 :update-1)
+          (-> query :entity insertable-properties)
+          (:select-1 :delete-1)
+          (-> query :entity key-properties)
+          ;; default
+          nil))))
+     'request))))
 
 
 (defn generate-handler-src
@@ -262,7 +273,7 @@
   (let [handlers-map (make-handlers-map application)
         filepath (str *output-path* "src/clj/" (:name (:attrs application)) "/routes/auto_json.clj")]
     (make-parents filepath)
-    (try
+    (do-or-warn
       (with-open [output (writer filepath)]
         (binding [*out* output]
           (pprint (file-header application))
@@ -275,16 +286,7 @@
                 h)
               (sort (keys handlers-map))))
           (pprint (defroutes handlers-map))))
-      (if (> *verbosity* 0)
+      (if (pos? *verbosity*)
-        (*warn* (str "\tGenerated " filepath)))
+        (*warn* (str "\tGenerated " filepath))))))
-      (catch
-        Exception any
-        (*warn*
-          (str
-            "ERROR: Exception "
-            (.getName (.getClass any))
-            (.getMessage any)
-            " while printing "
-            filepath))))))
 
 

src/adl/to_psql.clj

@@ -1,7 +1,7 @@
 (ns ^{:doc "Application Description Language: generate Postgres database definition."
       :author "Simon Brooke"}
   adl.to-psql
-  (:require [adl-support.core :refer [*warn*]]
+  (:require [adl-support.core :refer :all]
             [adl-support.utils :refer :all]
             [adl.to-hugsql-queries :refer [queries]]
             [clojure.java.io :refer [file make-parents writer]]
@@ -111,7 +111,12 @@
 (defn emit-field-type
   [property entity application key?]
   (case (:type (:attrs property))
-    "integer" (if key? "SERIAL" "INTEGER")
+    "integer" (if
+                (and
+                 key?
+                 (system-generated? property))
+                "SERIAL"
+                "INTEGER")
     "real" "DOUBLE PRECISION"
     ("string" "image" "uploadable")
     (str "VARCHAR(" (:size (:attrs property)) ")")
@@ -150,8 +155,8 @@
               #(if (selector (:permission (:attrs %)))
                  (safe-name (:group (:attrs %)) :sql))
               permissions)))]
-    (if
+    (if-not
-      (not (empty? group-names))
+      (empty? group-names)
       (s/join
         " "
         (list
@@ -318,12 +323,12 @@
                          (str (safe-name entity) "." (field-name %)))
                        (str (safe-name entity) "." (field-name %)))
                     (filter
-                      #(not (= (:type (:attrs %)) "link"))
+                      #(not= (:type (:attrs %)) "link")
                       (all-properties entity) )))))
             (str
               "FROM " (s/join ", " (set (compose-convenience-view-select-list entity application true))))
-            (if
+            (if-not
-              (not (empty? entity-fields))
+              (empty? entity-fields)
               (str
                 "WHERE "
                 (s/join
@@ -408,7 +413,7 @@
              (list
                doc-comment
                (map
-                 #(:content %)
+                 :content
                  (children-with-tag entity :documentation))))
            (s/join
              " "
@@ -427,7 +432,7 @@
                      (map
                        #(emit-property % entity application false)
                        (filter
-                         #(not (= (:type (:attrs %)) "link"))
+                         #(not= (:type (:attrs %)) "link")
                          (children-with-tag entity :property)))))))
              "\n);")
            (map
@@ -532,7 +537,7 @@
     (str "(https://github.com/simon-brooke/adl) at "
          (f/unparse (f/formatters :basic-date-time) (t/now)))
     (map
-      #(:content %)
+      :content
       (children-with-tag application :documentation))))
 
 
@@ -568,18 +573,10 @@
                    (:name (:attrs application))
                    ".postgres.sql")]
     (make-parents filepath)
-    (try
+    (do-or-warn
       (spit filepath (emit-application application))
-      (if (> *verbosity* 0)
+      (if
-        (*warn* (str "\tGenerated " filepath)))
+        (pos? *verbosity*)
-      (catch
+        (*warn* (str "\tGenerated " filepath))))))
-        Exception any
-        (*warn*
-          (str
-            "ERROR: Exception "
-            (.getName (.getClass any))
-            (.getMessage any)
-            " while printing "
-            filepath))))))
 
 

src/adl/to_selmer_routes.clj

@@ -1,8 +1,9 @@
 (ns ^{:doc "Application Description Language: generate routes for user interface requests."
       :author "Simon Brooke"}
   adl.to-selmer-routes
-  (:require [adl-support.core :refer [*warn*]]
+  (:require [adl-support.core :refer :all]
             [adl-support.utils :refer :all]
+            [adl-support.forms-support :refer :all]
             [clj-time.core :as t]
             [clj-time.format :as f]
             [clojure.java.io :refer [file make-parents writer]]
@@ -34,11 +35,8 @@
 ;;;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-;;; Generally. there's one route in the generated file for each Selmer
+;;; Generally. there are two routes - one for GET, one for POST - in the
-;;; template which has been generated.
+;;; generated file for each Selmer template which has been generated.
-
-;;; TODO: there must be some more idiomatic way of generating all these
-;;; functions.
 
 (defn file-header
   [application]
@@ -51,6 +49,8 @@
    (list
     :require
     '[adl-support.core :as support]
+    '[adl-support.forms-support :refer :all]
+    '[adl-support.rest-support :refer :all]
     '[clojure.java.io :as io]
     '[clojure.set :refer [subset?]]
     '[clojure.tools.logging :as log]
@@ -65,23 +65,17 @@
     (vector (symbol (str (:name (:attrs application)) ".routes.manual")) :as 'm))))
 
 
-(defn make-form-handler-content
+(defn make-form-get-handler-content
   [f e a n]
-  (let [warning (list 'str (str "Error while fetching " (singularise (:name (:attrs e))) " record ") 'params)]
+  (let [entity-name (singularise (:name (:attrs e)))]
     ;; TODO: as yet makes no attempt to save the record
     (list 'let
           (vector
            'record (list
-                      'support/do-or-log-error
+                    'get-current-value
-                      ;;(list 'if (list 'subset? (key-names e) (list 'set (list 'keys 'params)))
+                    (symbol (str "db/get-" entity-name))
-                            (list
+                    'params
-                              (symbol
+                    entity-name))
-                                (str "db/get-" (singularise (:name (:attrs e)))))
-                              (symbol "db/*db*")
-                              'params)
-                      ;;)
-                      :message warning
-                      :error-return {:warnings [warning]}))
           (reduce
            merge
            {:error (list :warnings 'record)
@@ -99,28 +93,15 @@
                   'list
                   ;; Get the current value of the property, if it's an entity
                   (if (= (-> property :attrs :type) "entity")
-                          (list 'support/do-or-log-error
+                    (list 'get-menu-options
-                                (list
+                          (-> e :attrs :name)
-                                  (symbol
+                          (-> property :attrs :farkey)
-                                    (str "db/get-" (singularise (:entity (:attrs property)))))
+                          (list (keyword (-> property :attrs :name)) 'params))))))))
-                                  (symbol "db/*db*")
-                                  (hash-map (keyword (-> property :attrs :farkey))
-                                            (list (keyword (-> property :attrs :name)) 'record)))
-                                :message (str "Error while fetching "
-                                              (singularise (:entity (:attrs property)))
-                                              " record " (hash-map (keyword (-> property :attrs :farkey))
-                                            (list (keyword (-> property :attrs :name)) 'record)))))
-                        ;;; and the potential values of the property
-                        (list 'support/do-or-log-error
-                              (list (symbol (str "db/list-" (:entity (:attrs property)))) (symbol "db/*db*"))
-                              :message (str "Error while fetching "
-                                            (singularise (:entity (:attrs property)))
-                                            " list")))))))
              (filter #(:entity (:attrs %))
                     (descendants-with-tag e :property)))))))
 
 
-(defn make-page-handler-content
+(defn make-page-get-handler-content
   [f e a n]
   (let [warning (str "Error while fetching " (singularise (:name (:attrs e))) " record")]
     (list 'let
@@ -138,7 +119,7 @@
            :record (list 'assoc 'record :warnings nil)})))
 
 
-(defn make-list-handler-content
+(defn make-list-get-handler-content
   [f e a n]
   (list
    'let
@@ -190,57 +171,137 @@
          {:records 'records})))
 
 
-(defn make-handler
+(defn handler-name
+  "Generate the name of the appropriate handler function for form `f` of
+  entity `e` of application `a` for method `m`, where `f`, `e`, and `a`
+  are expected to be elements and `m` is expected to be one of the keywords
+  `:put` `:get`."
+  [f e a m]
+  (str (s/lower-case (name m)) "-" (path-part f e a)))
+
+
+(defn make-get-handler
   [f e a]
-  (let [n (path-part f e a)]
+  (let [n (handler-name f e a :get)]
     (list
      'defn
      (symbol n)
      (vector 'request)
      (list 'let (vector
                  'params
-                   (list 'support/massage-params
+                 (list 'support/massage-params 'request))
-                         (list 'keywordize-keys (list :params 'request))
-                         (list 'keywordize-keys (list :form-params 'request))
-                         (key-names e true)))
            (list
             'l/render
-              (list 'support/resolve-template (str n ".html"))
+            (list 'support/resolve-template (str (path-part f e a) ".html"))
             (list 'merge
                   {:title (capitalise (:name (:attrs f)))
                    :params  'params}
                   (case (:tag f)
-                      :form (make-form-handler-content f e a n)
+                    :form (make-form-get-handler-content f e a n)
-                      :page (make-page-handler-content f e a n)
+                    :page (make-page-get-handler-content f e a n)
-                      :list (make-list-handler-content f e a n))))))))
+                    :list (make-list-get-handler-content f e a n))))))))
+
+
+(defn make-form-post-handler-content
+  ;; Literally the only thing the post handler has to do is to
+  ;; generate the database store operation. Then it can hand off
+  ;; to the get handler.
+  [f e a n]
+  (let
+    [create-name (query-name e :create)
+     update-name (query-name e :update)]
+    (list
+     'let
+     (vector
+      'result
+      (list
+       'valid-user-or-forbid
+       (list
+        'with-params-or-error
+        (list
+         'do-or-server-fail
+         (list
+          'if
+          (list 'all-keys-present? 'params (key-names e true))
+          (list
+           update-name
+           'db/*db*
+           'params)
+          (list
+           create-name
+           'db/*db*
+           'params))
+         200) ;; OK
+        'params
+        (set
+         (map
+          #(keyword (:name (:attrs %)))
+          (insertable-properties e))))
+       'request))
+     (list
+      'if
+      (list
+       (set [200 400])
+       (list :status 'result))
+      (list
+       (symbol (handler-name f e a :get))
+       (list
+        'assoc
+        'request
+        :params
+        (list
+        'merge
+        'params
+        'result)))
+      'result))))
+
+
+(defn make-post-handler
+  [f e a]
+  (let [n (handler-name f e a :post)]
+    (list
+     'defn
+     (symbol n)
+     (vector 'request)
+     (case
+       (:tag f)
+       (:page :list) (list (symbol (handler-name f e a :get)) 'request)
+       :form (list
+              'let
+              (vector
+               'params
+               (list 'support/massage-params 'request))
+              (make-form-post-handler-content f e a n))))))
+
 
 ;; (def a (x/parse "../youyesyet/youyesyet.canonical.adl.xml"))
 ;; (def e (child-with-tag a :entity))
 ;; (def f (child-with-tag e :form))
-;; (def n (path-part f e a))
+;; (def n (handler-name f e a :post))
-;; (make-handler f e a)
+;; (make-post-handler f e a)
 ;; (vector
 ;;  'p
 ;;  (list 'merge
 ;;        {:offset 0 :limit 25}
 ;;        (list 'support/massage-params (list :params 'r))))
-;; (make-handler f e a)
+;; (make-get-handler f e a)
 
 
 (defn make-route
   "Make a route for method `m` to request the resource with name `n`."
   [m n]
   (list
-   m
+   (symbol (s/upper-case (name m)))
    (str "/" n)
    'request
    (list
     'route/restricted
     (list
      'apply
-     (list 'resolve-handler n)
+     (list 'resolve-handler (str (s/lower-case (name m)) "-" n))
      (list 'list 'request)))))
 
+
 (defn make-defroutes
   [application]
   (let [routes (flatten
@@ -263,10 +324,10 @@
           (apply (resolve-handler "index") (list request))))
        (interleave
         (map
-         (fn [r] (make-route 'GET r))
+         (fn [r] (make-route :get r))
          (sort routes))
         (map
-         (fn [r] (make-route 'POST r))
+         (fn [r] (make-route :post r))
          (sort routes))))))))
 
 
@@ -294,16 +355,27 @@
   (doall
    (map
     (fn [c]
-      (pprint (make-handler c e application))
+      ;; do all get handlers before post handlers, so that the post
-      (println))
+      ;; handlers can call the get handlers.
+      (pprint (make-get-handler c e application))
+      (println "\n")
+      (pprint (make-post-handler c e application))
+      (println "\n"))
     (filter (fn [c] (#{:form :list :page} (:tag c))) (children e)))))
 
 
 (defn to-selmer-routes
   [application]
-  (let [filepath (str *output-path* "src/clj/" (:name (:attrs application)) "/routes/auto.clj")]
+  (let [filepath (str
+                  *output-path*
+                  "src/clj/"
+                  (:name (:attrs application))
+                  "/routes/auto.clj")
+        entities (sort
+                  #(compare (:name (:attrs %1))(:name (:attrs %2)))
+                  (children-with-tag application :entity))]
     (make-parents filepath)
-    (try
+    (do-or-warn
      (with-open [output (writer filepath)]
        (binding [*out* output]
          (pprint (file-header application))
@@ -319,9 +391,7 @@
          (doall
           (map
            #(make-handlers % application)
-            (sort
+           entities))
-             #(compare (:name (:attrs %1))(:name (:attrs %2)))
-             (children-with-tag application :entity))))
          (pprint
           (generate-handler-resolver application))
          (println)
@@ -330,15 +400,7 @@
          (println)
          (pprint (make-defroutes application))
          (println)))
-      (if (> *verbosity* 0)
+     (if
-        (*warn* (str "\tGenerated " filepath)))
+       (pos? *verbosity*)
-      (catch
+       (*warn* (str "\tGenerated " filepath))))))
-        Exception any
-        (*warn*
-         (str
-          "ERROR: Exception "
-          (.getName (.getClass any))
-          (.getMessage any)
-          " while printing "
-          filepath))))))
 

src/adl/to_selmer_templates.clj

@@ -1,7 +1,8 @@
-(ns ^{:doc "Application Description Language - generate Selmer templates for the HTML pages implied by an ADL file."
+(ns ^{:doc "Application Description Language - generate Selmer templates for
+      the HTML pages implied by an ADL file."
       :author "Simon Brooke"}
   adl.to-selmer-templates
-  (:require [adl-support.core :refer [*warn*]]
+  (:require [adl-support.core :refer :all]
             [adl.to-hugsql-queries :refer [expanded-token]]
             [adl-support.utils :refer :all]
             [clojure.java.io :refer [file make-parents resource]]
@@ -41,7 +42,9 @@
   {:tag :div
    :attrs {:class "big-link-container"}
    :content
-   [{:tag :a :attrs {:href  (str "{{servlet-context}}/" url) :class "big-link"}
+   [{:tag :a
+     :attrs {:href  (str "{{servlet-context}}/" url)
+             :class "big-link"}
      :content (if
                 (vector? content)
                 content
@@ -62,7 +65,7 @@
 
 (defn emit-content
   ([content]
-   (try
+   (do-or-warn
      (cond
        (nil? content)
        nil
@@ -75,15 +78,7 @@
        (map emit-content (remove nil? content))
        true
        (str "<!-- don't know what to do with '" content "' -->"))
-     (catch Exception any
+    (str "Failed while writing " content)))
-       (str
-         "<!-- failed while trying to emit \n'"
-         (with-out-str (p/pprint content))
-         "';\n"
-         (-> any .getClass .getName)
-         ": "
-         (-> any .getMessage)
-         " -->"))))
   ([filename application k]
    (emit-content filename nil nil application k))
   ([filename spec entity application k]
@@ -143,7 +138,8 @@
 
 
 (defn csrf-widget
-  "For the present, just return the standard cross site scripting protection field statement"
+  "For the present, just return the standard cross site scripting protection
+  field statement"
   []
   "{% csrf-field %}")
 
@@ -179,16 +175,20 @@
 
 
 (defn save-widget
-  "Return an appropriate 'save' widget for this `form` operating on this `entity` taken
+  "Return an appropriate 'save' widget for this `form` operating on this
-  from this `application`.
+  `entity` taken from this `application`.
-  TODO: should be suppressed unless a member of a group which can insert or edit."
+  TODO: should be suppressed unless a member of a group which can insert
+  or edit."
   [form entity application]
   (wrap-in-if-member-of
     {:tag :p
      :attrs {:class "widget action-safe"}
      :content [{:tag :label
                 :attrs {:for "save-button" :class "action-safe"}
-                :content [(str "To save this " (:name (:attrs entity)) " record")]}
+                :content [(str
+                           "To save this "
+                           (:name (:attrs entity))
+                           " record")]}
                {:tag :input
                 :attrs {:id "save-button"
                         :name "save-button"
@@ -201,16 +201,20 @@
 
 
 (defn delete-widget
-  "Return an appropriate 'save' widget for this `form` operating on this `entity` taken
+  "Return an appropriate 'save' widget for this `form` operating on this
-  from this `application`.
+  `entity` taken from this `application`.
   TODO: should be suppressed unless member of a group which can delete."
   [form entity application]
   (wrap-in-if-member-of
     {:tag :p
      :attrs {:class "widget action-dangerous"}
      :content [{:tag :label
-                :attrs {:for "delete-button" :class "action-dangerous"}
+                :attrs {:for "delete-button"
-                :content [(str "To delete this " (:name (:attrs entity)) " record")]}
+                        :class "action-dangerous"}
+                :content [(str
+                           "To delete this "
+                           (:name (:attrs entity))
+                           " record")]}
                {:tag :input
                 :attrs {:id "delete-button"
                         :name "delete-button"
@@ -223,7 +227,8 @@
 
 
 (defn select-property
-  "Return the property on which we will by default do a user search on this `entity`."
+  "Return the property on which we will by default do a user search on this
+  `entity`."
   [entity]
   (descendant-with-tag
       entity
@@ -241,8 +246,8 @@
 
 
 (defn get-options
-  "Produce template code to get options for this `property` of this `entity` taken from
+  "Produce template code to get options for this `property` of this `entity`
-  this `application`."
+  taken from this `application`."
   [property form entity application]
   (let
     [type (:type (:attrs property))
@@ -258,9 +263,9 @@
               (:farkey (:attrs property))
               (first (key-names farside))
               "id")]
-    ;; Yes, I know it looks BONKERS generating this as an HTML string. But there is a
+    ;; Yes, I know it looks BONKERS generating this as an HTML string. But
-    ;; reason. We don't know whether the `selected` attribute should be present or
+    ;; there is a reason. We don't know whether the `selected` attribute
-    ;; absent until rendering.
+    ;; should be present or absent until rendering.
     [(str "{% for option in " (-> property :attrs :name)
           " %}<option value='{{option."
           farkey
@@ -281,7 +286,9 @@
              (:type (:attrs typedef))
              (:type (:attrs property)))]
      (if
-       (and (= (-> property :attrs :distinct) "system") (= (-> property :attrs :immutable) "true"))
+       (and
+        (= (-> property :attrs :distinct) "system")
+        (= (-> property :attrs :immutable) "true"))
        "hidden"
        (case t
          ("integer" "real" "money") "number"
@@ -298,8 +305,13 @@
 (defn select-widget
   [property form entity application]
   (let [farname (:entity (:attrs property))
-        farside (first (children application #(= (:name (:attrs %)) farname)))
+        farside (first
-        magnitude (try (read-string (:magnitude (:attrs farside))) (catch Exception _ 7))
+                 (children
+                  application
+                  #(= (:name (:attrs %)) farname)))
+        magnitude (try
+                    (read-string (:magnitude (:attrs farside)))
+                    (catch Exception _ 7))
         async? (and (number? magnitude) (> magnitude 1))
         widget-name (safe-name (:name (:attrs property)) :sql)]
     {:tag :select
@@ -309,7 +321,9 @@
               (if
                 (= (:type (:attrs property)) "link")
                 {:multiple "multiple"}))
-     :content (apply vector (get-options property form entity application))}))
+     :content (apply
+               vector
+               (get-options property form entity application))}))
 
 
 (defn compose-readable-or-not-authorised
@@ -326,7 +340,11 @@
      :attrs {:id w
              :name w
              :class "pseudo-widget not-authorised"}
-     :content [(str "You are not permitted to view " w " of " (:name (:attrs e)))]}
+     :content [(str
+                "You are not permitted to view "
+                w
+                " of "
+                (:name (:attrs e)))]}
     "{% endifmemberof %}"))
 
 
@@ -356,46 +374,14 @@
                   "{% endif %}")))})
 
 
-(defn widget
+(defn compose-input-widget-para
-  "Generate a widget for this `field-or-property` of this `form` for this `entity`
+  "Generate an input widget for this `field-or-property` of this `form` for
-  taken from within this `application`."
+  this `entity` taken from within this `application`, in context of a para
-  [field-or-property form entity application]
+  also containing its label."
+  [property form entity application widget-name]
   (let
-    [widget-name (safe-name
+    [typedef (typedef property application)
-                   (if (= (:tag field-or-property) :property)
+     w-type (widget-type property application typedef)]
-                     (:name (:attrs field-or-property))
-                     (:property (:attrs field-or-property))) :sql)
-     property (case
-                (:tag field-or-property)
-                :property field-or-property
-                :field (property-for-field field-or-property entity)
-                ;; default
-                nil)
-     permissions (find-permissions field-or-property property form entity application)
-     typedef (typedef property application)
-     w-type (widget-type property application typedef)
-     visible-to (visible-to permissions)
-     ;; if the form isn't actually a form, no widget is writeable.
-     writeable-by (if (= (:tag form) :form) (writeable-by permissions))]
-    (if
-      property
-      (case w-type
-        "hidden"
-        {:tag :input
-         :attrs {:id widget-name
-                 :name widget-name
-                 :type "hidden"
-                 :value (str "{{record." widget-name "}}")}}
-        "select"
-        (compose-widget-para property form entity application widget-name
-                             (select-widget property form entity application))
-        "text-area"
-        (compose-widget-para
-          property form entity application widget-name
-          {:tag :textarea
-           :attrs {:rows "8" :cols "60" :id widget-name :name widget-name}
-           :content [(str "{{record." widget-name "}}")]})
-        ;; all others
     (compose-widget-para
      property form entity application widget-name
      {:tag :input
@@ -415,18 +401,70 @@
                       "60"
                       true
                       (:size (:attrs property)))}
+              ;; TODO: should match pattern from typedef
               (if
                 (:minimum (:attrs typedef))
                 {:min (:minimum (:attrs typedef))})
               (if
                 (:maximum (:attrs typedef))
-                      {:max (:maximum (:attrs typedef))}))})))))
+                {:max (:maximum (:attrs typedef))}))})))
+
+
+(defn widget
+  "Generate a widget for this `field-or-property` of this `form` for this
+  `entity` taken from within this `application`, in context of a para also
+  containing its label."
+  [field-or-property form entity application]
+  (let
+    [widget-name (safe-name
+                   (if (= (:tag field-or-property) :property)
+                     (:name (:attrs field-or-property))
+                     (:property (:attrs field-or-property))) :sql)
+     property (case
+                (:tag field-or-property)
+                :property field-or-property
+                :field (property-for-field field-or-property entity)
+                ;; default
+                nil)
+     typedef (typedef property application)
+     w-type (widget-type property application typedef)]
+    (if
+      property
+      (case w-type
+        "hidden"
+        {:tag :input
+         :attrs {:id widget-name
+                 :name widget-name
+                 :type "hidden"
+                 :value (str "{{record." widget-name "}}")}}
+        "select"
+        (compose-widget-para
+         property
+         form
+         entity
+         application
+         widget-name
+         (select-widget property form entity application))
+        "text-area"
+        (compose-widget-para
+         property form entity application widget-name
+         {:tag :textarea
+          :attrs {:rows "8" :cols "60" :id widget-name :name widget-name}
+          :content [(str "{{record." widget-name "}}")]})
+        ;; all others
+        (compose-input-widget-para
+         property
+         form
+         entity
+         application
+         widget-name)))))
 
 
 (defn embed-script-fragment
-  "Return the content of the file at `resource-path`, with these `substitutions`
+  "Return the content of the file at `resource-path`, with these
-  made into it in order. Substitutions should be pairss [`pattern` `value`],
+  `substitutions` made into it in order. Substitutions should be pairs
-  where `pattern` is a string, a char, or a regular expression."
+  [`pattern` `value`], where `pattern` is a string, a char, or a regular
+  expression."
   ([resource-path substitutions]
    (let [v (slurp (resource resource-path))]
      (reduce
@@ -455,8 +493,8 @@
 
 
 (defn list-tbody
-  "Return a table body element for the list view for this `list-spec` of this `entity` within
+  "Return a table body element for the list view for this `list-spec` of
-  this `application`, using data from this source."
+  this `entity` within this `application`, using data from this source."
   [source list-spec entity application]
   {:tag :tbody
    :content
@@ -470,7 +508,12 @@
            (fn [field]
              {:tag :td :content
               (let
-               [p (first (filter #(= (:name (:attrs %)) (:property (:attrs field))) (all-properties entity)))
+               [p (first
+                   (filter
+                    #(=
+                      (:name (:attrs %))
+                      (:property (:attrs field)))
+                    (all-properties entity)))
                 s (safe-name (:name (:attrs p)) :sql)
                 e (first
                     (filter
@@ -480,7 +523,10 @@
                (if
                  (= (:type (:attrs p)) "entity")
                  [{:tag :a
-                   :attrs {:href (edit-link e application (list (:name (:attrs p))))}
+                   :attrs {:href (edit-link
+                                  e
+                                  application
+                                  (list (:name (:attrs p))))}
                    :content [(str "{{ record." s "_expanded }}")]}]
                  [c]))})
            (children-with-tag list-spec :field))
@@ -498,11 +544,15 @@
   (let [property (child-with-tag
                    entity
                    :property
-                   #(= (-> % :attrs :name) (-> auxlist :attrs :property)))
+                   #(=
+                     (-> % :attrs :name)
+                     (-> auxlist :attrs :property)))
         farside (child-with-tag
                   application
                   :entity
-                  #(= (-> % :attrs :name)(-> property :attrs :entity)))]
+                  #(=
+                    (-> % :attrs :name)
+                    (-> property :attrs :entity)))]
     (if
       (and property farside)
       {:tag :div
@@ -526,7 +576,11 @@
                         :content [(prompt % form entity application)])
                      (children-with-tag auxlist :field))
                    {:tag :th :content ["&nbsp;"]})))}]}
-          (list-tbody (-> property :attrs :name) auxlist farside application)]}]})))
+          (list-tbody
+           (-> property :attrs :name)
+           auxlist
+           farside
+           application)]}]})))
 
 
 (defn compose-form-auxlists
@@ -548,7 +602,9 @@
      vector
      (cons
       {:tag :form
-         :attrs {:action (str "{{servlet-context}}/" (editor-name entity application))
+       :attrs {:action (str
+                        "{{servlet-context}}/"
+                        (editor-name entity application))
                :method "POST"}
        :content (apply
                  vector
@@ -559,13 +615,18 @@
                     (csrf-widget)
                     (map
                      #(widget % form entity application)
-                            (children-with-tag (child-with-tag entity :key) :property))
+                     (children-with-tag
+                      (child-with-tag entity :key)
+                      :property))
                     (map
                      #(widget % form entity application)
                      (remove
                       #(let
-                                 [property (filter
+                         [property
-                                             (fn [p] (= (:name (:attrs p)) (:property (:attrs %))))
+                          (filter
+                           (fn
+                             [p]
+                             (= (:name (:attrs p)) (:property (:attrs %))))
                            (descendants-with-tag entity :property))]
                          (= (:distict (:attrs property)) :system))
                       (children-with-tag form :field)))
@@ -586,7 +647,9 @@
            (child-with-tag
              form
              :field
-             #(= "text-area" (widget-type (property-for-field % entity) application)))
+             #(=
+               "text-area"
+               (widget-type (property-for-field % entity) application)))
            "
            {% script \"/js/lib/node_modules/simplemde/dist/simplemde.min.js\" %}
            {% style \"/js/lib/node_modules/simplemde/dist/simplemde.min.css\" %}")
@@ -594,7 +657,9 @@
            (child-with-tag
              form
              :field
-             #(= "select" (widget-type (property-for-field % entity) application)))
+             #(=
+               "select"
+               (widget-type (property-for-field % entity) application)))
            "
            {% script \"/js/lib/node_modules/selectize/dist/js/standalone/selectize.min.js\" %}
            {% style \"/js/lib/node_modules/selectize/dist/css/selectize.css\" %}"))))})
@@ -614,29 +679,45 @@
         (map
          (fn [field]
            (let
-                  [property (child-with-tag entity :property #(=
+             [property (child-with-tag
+                        entity
+                        :property
+                        #(=
                           (-> field :attrs :property)
                           (-> % :attrs :name)))
               farname (:entity (:attrs property))
-                   farside (first (children application #(= (:name (:attrs %)) farname)))
+              farside (first
-                   magnitude (try (read-string (:magnitude (:attrs farside))) (catch Exception _ 7))]
+                       (children
+                        application
+                        #(= (:name (:attrs %)) farname)))
+              magnitude (try
+                          (read-string
+                           (:magnitude
+                            (:attrs farside)))
+                          (catch Exception _ 7))]
              (if
                (> magnitude 2)
                (embed-script-fragment
                 "js/selectize-one.js"
                 [["{{widget_id}}" (-> property :attrs :name)]
-                       ["{{widget_value}}" (str "{{record." (-> property :attrs :name) "}}")]
+                 ["{{widget_value}}"
+                  (str "{{record." (-> property :attrs :name) "}}")]
                  ["{{entity}}" farname]
                  ["{{field}}" (select-field-name farside)]
                  ["{{key}}" (first (key-names farside))]]))))
          (children-with-tag
           form :field
-                #(= "select" (widget-type (property-for-field % entity) application))))
+          #(=
+            "select"
+            (widget-type (property-for-field % entity) application))))
         (if
           (child-with-tag
            form :field
-                #(= "text-area" (widget-type (property-for-field % entity) application)))
+           #(=
-              (embed-script-fragment "js/text-area-md-support.js"
+             "text-area"
+             (widget-type (property-for-field % entity) application)))
+          (embed-script-fragment
+           "js/text-area-md-support.js"
            [["{{page}}" (-> form :attrs :name)]]))))))}})
 
 
@@ -666,7 +747,8 @@
                    (children
                      entity
                      (fn [p] (and (= (:tag p) :property)
-                                  (= (:name (:attrs p)) (:property (:attrs field)))))))
+                                  (= (:name (:attrs p))
+                                     (:property (:attrs field)))))))
         input-type (case (:type (:attrs property))
                      ("integer" "real" "money") "number"
                      ("date" "timestamp") "date"
@@ -686,8 +768,8 @@
 
 
 (defn- list-thead
-  "Return a table head element for the list view for this `list-spec` of this `entity` within
+  "Return a table head element for the list view for this `list-spec` of
-  this `application`."
+  this `entity` within this `application`."
   [list-spec entity application]
   {:tag :thead
    :content
@@ -734,7 +816,8 @@
       :content
       [{:tag :div :attrs {:class "back-link-container"}
          :content
-         [{:tag :a :attrs {:id "prev-selector" :class "back-link"}
+         [{:tag :a
+           :attrs {:id "prev-selector" :class "back-link"}
            :content ["Previous"]}]}]}
      :big-links
      {:tag :div
@@ -747,10 +830,16 @@
             (list
               {:tag :div :attrs {:class "big-link-container"}
                :content
-               [{:tag :a :attrs {:id "next-selector" :role "button" :class "big-link"}
+               [{:tag :a
+                 :attrs {:id "next-selector"
+                         :role "button"
+                         :class "big-link"}
                  :content ["Next"]}]}
               (wrap-in-if-member-of
-                (big-link (str "Add a new " (pretty-name entity)) (editor-name entity application))
+                (big-link (str
+                           "Add a new "
+                           (pretty-name entity))
+                          (editor-name entity application))
                 :writeable
                 entity
                 application)))))}
@@ -761,8 +850,12 @@
               :method "POST"}
       :content
       [(csrf-widget)
-       {:tag :input :attrs {:id "offset" :name "offset" :type "hidden" :value "{{params.offset|default:0}}"}}
+       {:tag :input
-       {:tag :input :attrs {:id "limit" :name "limit" :type "hidden" :value "{{params.limit|default:50}}"}}
+        :attrs {:id "offset" :name "offset" :type "hidden"
+                :value "{{params.offset|default:0}}"}}
+       {:tag :input
+        :attrs {:id "limit" :name "limit" :type "hidden"
+                :value "{{params.limit|default:50}}"}}
        {:tag :table
         :attrs {:caption (:name (:attrs entity))}
         :content
@@ -813,21 +906,33 @@
       (merge
        (if
          forms
-          (apply merge (map #(assoc {} (keyword (path-part % entity application))
+         (apply
+          merge
+          (map #(assoc
+                  {}
+                  (keyword (path-part % entity application))
                   (form-to-template % entity application))
                forms))
          {(keyword (str "form-" (:name (:attrs entity))))
           (form-to-template nil entity application)})
        (if
          pages
-          (apply merge (map #(assoc {} (keyword (path-part % entity application))
+         (apply
+          merge
+          (map #(assoc
+                  {}
+                  (keyword (path-part % entity application))
                   (page-to-template % entity application))
                pages))
          {(keyword (str "page-" (:name (:attrs entity))))
           (page-to-template nil entity application)})
        (if
          lists
-          (apply merge (map #(assoc {} (keyword (path-part % entity application))
+         (apply
+          merge
+          (map #(assoc
+                  {}
+                  (keyword (path-part % entity application))
                   (list-to-template % entity application))
                lists))
          {(keyword (str "list-" (:name (:attrs entity))))
@@ -840,7 +945,9 @@
    {:tag :dt
     :content
     [{:tag :a
-      :attrs {:href (str "{{servlet-context}}/" (path-part :list entity application))}
+      :attrs {:href (str
+                     "{{servlet-context}}/"
+                     (path-part :list entity application))}
       :content [(pretty-name entity)]}]}
     :readable
     entity
@@ -895,10 +1002,13 @@
 
 (defn write-template-file
   [filename template application]
-  (let [filepath (str *output-path* "resources/templates/auto/" filename)]
+  (let [filepath (str
+                  *output-path*
+                  "resources/templates/auto/"
+                  filename)]
     (if
       template
-      (try
+      (do-or-warn
        (do
          (make-parents filepath)
          (spit
@@ -917,24 +1027,10 @@
                    "{% endblock %}"))
                (keys template)))
              (file-footer filename application)))))
-          (if (> *verbosity* 0) (*warn* "\tGenerated " filepath)))
+         (if
-        (catch Exception any
+           (pos? *verbosity*)
-          (let [report (str
+           (*warn* "\tGenerated " filepath))
-                        "ERROR: Exception "
+         (str filepath))))))
-                        (.getName (.getClass any))
-                        (.getMessage any)
-                        " while printing "
-                        filepath)]
-            (try
-              (spit
-               filepath
-               (with-out-str
-                 (*warn* (str "<!-- " report "-->"))
-                 (p/pprint template)))
-              (catch Exception _ nil))
-            (*warn* report)
-            (throw any)))))
-    (str filepath)))
 
 
 ;; (def a (x/parse "../youyesyet/youyesyet.canonical.adl.xml"))
@@ -948,7 +1044,8 @@
 
 
 (defn to-selmer-templates
-  "Generate all [Selmer](https://github.com/yogthos/Selmer) templates implied by this ADL `application` spec."
+  "Generate all [Selmer](https://github.com/yogthos/Selmer) templates implied
+  by this ADL `application` spec."
   [application]
   (let
     [templates-map (reduce
@@ -962,17 +1059,11 @@
         #(if
            (templates-map %)
            (let [filename (str (name %) ".html")]
-             (try
+             (do-or-warn
-               (write-template-file filename (templates-map %) application)
+               (write-template-file
-               (catch Exception any
+                filename
-                 (*warn*
+                (templates-map %)
-                   (str
+                application))))
-                     "ERROR: Exception "
-                     (.getName (.getClass any))
-                     " "
-                     (.getMessage any)
-                     " while writing "
-                     filename))))))
         (keys templates-map)))))
 
 

test/adl/to_hugsql_queries_test.clj

@@ -19,141 +19,10 @@
     (= a b)))
 
 (deftest entity-tests
-  (let [xml {:tag :entity,
+  (let [application {:tag :application,
-             :attrs {:name "address"},
+             :attrs {:version "0.1.1", :name "test-app"},
              :content
-             [{:tag :key,
+             [{:tag :entity,
-               :attrs nil,
-               :content
-               [{:tag :property,
-                 :attrs
-                 {:immutable "true",
-                  :required "true",
-                  :distinct "system",
-                  :type "integer",
-                  :name "id"},
-                 :content
-                 [{:tag :generator, :attrs {:action "native"}, :content nil}]}]}
-              {:tag :property,
-               :attrs
-               {:distinct "user", :size "128", :type "string", :name "street"},
-               :content nil}
-              {:tag :property,
-               :attrs {:size "64", :type "string", :name "town"},
-               :content nil}
-              {:tag :property,
-               :attrs
-               {:distinct "user", :size "12", :type "string", :name "postcode"},
-               :content nil}]}]
-    (testing "user distinct properties should provide the default ordering"
-      (let [expected
-            "ORDER BY address.street,
-            address.postcode,
-            address.id"
-            actual (order-by-clause xml)]
-        (is (string-equal-ignore-whitespace? actual expected))))
-    (testing "keys name extraction"
-      (let [expected '("id")
-            actual (key-names xml)]
-        (is (string-equal-ignore-whitespace? actual expected))))
-    (testing "primary key test"
-      (let [expected true
-            actual (has-primary-key? xml)]
-        (is (string-equal-ignore-whitespace? actual expected))))
-    (testing "non-key properties test"
-      (let [expected true
-            actual (has-non-key-properties? xml)]
-        (is (string-equal-ignore-whitespace? actual expected))))
-    (testing "insert query generation"
-      (let [expected "-- :name create-addres! :! :n
-            -- :doc creates a new addres record
-            INSERT INTO address (street,
-              town,
-              postcode)
-            VALUES (':street',
-              ':town',
-              ':postcode')
-            returning id\n\n"
-            actual (:query (first (vals (insert-query xml))))]
-        (is (string-equal-ignore-whitespace? actual expected))))
-    (testing "insert query signature"
-      (let [expected ":! :n"
-            actual (:signature (first (vals (insert-query xml))))]
-        (is (string-equal-ignore-whitespace? actual expected))))
-    (testing "update query generation"
-      (let [expected "-- :name update-addres! :! :n
-            -- :doc updates an existing addres record
-            UPDATE address
-            SET street = :street,
-              town = :town,
-              postcode = :postcode
-            WHERE address.id = :id\n\n"
-            actual (:query (first (vals (update-query xml))))]
-        (is (string-equal-ignore-whitespace? actual expected))))
-    (testing "update query signature"
-      (let [expected ":! :n"
-            actual (:signature (first (vals (update-query xml))))]
-        (is (string-equal-ignore-whitespace? actual expected))))
-    (testing "search query generation"
-      (let [expected "-- :name search-strings-addres :? :1
-            -- :doc selects existing address records having any string field matching `:pattern` by substring match
-            SELECT * FROM address
-            WHERE street LIKE '%:pattern%'
-              OR town LIKE '%:pattern%'
-              OR postcode LIKE '%:pattern%'
-            ORDER BY address.street,
-              address.postcode,
-              address.id
-            --~ (if (:offset params) \"OFFSET :offset \")
-            --~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")\n\n"
-            actual (:query (first (vals (search-query xml))))]
-        (is (string-equal-ignore-whitespace? actual expected))))
-    (testing "search query signature"
-      (let [expected ":? :1"
-            actual (:signature (first (vals (search-query xml))))]
-        (is (string-equal-ignore-whitespace? actual expected))))
-    (testing "select query generation"
-      (let [expected "-- :name get-addres :? :1
-            -- :doc selects an existing addres record
-            SELECT * FROM address
-            WHERE address.id = :id\n\n"
-            actual (:query (first (vals (select-query xml))))]
-        (is (string-equal-ignore-whitespace? actual expected))))
-    (testing "select query signature"
-      (let [expected ":? :1"
-            actual (:signature (first (vals (select-query xml))))]
-        (is (string-equal-ignore-whitespace? actual expected))))
-    (testing "list query generation"
-      (let [expected "-- :name list-address :? :*
-            -- :doc lists all existing addres records
-            SELECT * FROM address
-            ORDER BY address.street,
-              address.postcode,
-              address.id
-            --~ (if (:offset params) \"OFFSET :offset \")
-            --~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")\n\n"
-            actual (:query (first (vals (list-query xml))))]
-        (is (string-equal-ignore-whitespace? actual expected))))
-    (testing "list query signature"
-      (let [expected ":? :*"
-            actual (:signature (first (vals (list-query xml))))]
-        (is (string-equal-ignore-whitespace? actual expected))))
-    (testing "delete query generation"
-      (let [expected "-- :name delete-addres! :! :n
-            -- :doc updates an existing addres record
-            DELETE FROM address
-            WHERE address.id = :id\n\n"
-            actual (:query (first (vals (delete-query xml))))]
-        (is (string-equal-ignore-whitespace? actual expected))))
-    (testing "delete query signature"
-      (let [expected ":! :n"
-            actual (:signature (first (vals (delete-query xml))))]
-        (is (string-equal-ignore-whitespace? actual expected))))
-
-  ))
-
-(deftest complex-key-tests
-  (let [xml {:tag :entity,
                :attrs {:name "address"},
                :content
                [{:tag :key,
@@ -187,20 +56,168 @@
                 {:tag :property,
                  :attrs {:size "64", :type "string", :name "town"},
                  :content nil}
-              ]}]
+                ]}]}
+        entity (child-with-tag application :entity)]
+    (testing "user distinct properties should provide the default ordering"
+      (let [expected
+            "ORDER BY address.street,
+            address.postcode,
+            address.id"
+            actual (order-by-clause entity)]
+        (is (string-equal-ignore-whitespace? actual expected))))
+    (testing "keys name extraction"
+      (let [expected #{"id"}
+            actual (key-names entity)]
+        (is (string-equal-ignore-whitespace? actual expected))))
+    (testing "primary key test"
+      (let [expected true
+            actual (has-primary-key? entity)]
+        (is (string-equal-ignore-whitespace? actual expected))))
+    (testing "non-key properties test"
+      (let [expected true
+            actual (has-non-key-properties? entity)]
+        (is (string-equal-ignore-whitespace? actual expected))))
+    (testing "insert query generation"
+      (let [expected "-- :name create-address! :! :n
+            -- :doc creates a new address record
+            INSERT INTO address (street,
+              town,
+              postcode)
+            VALUES (':street',
+              ':town',
+              ':postcode')
+            returning id\n\n"
+            actual (:query (first (vals (insert-query entity))))]
+        (is (string-equal-ignore-whitespace? actual expected))))
+    (testing "insert query signature"
+      (let [expected ":! :n"
+            actual (:signature (first (vals (insert-query entity))))]
+        (is (string-equal-ignore-whitespace? actual expected))))
+    (testing "update query generation"
+      (let [expected "-- :name update-address! :! :n
+            -- :doc updates an existing address record
+            UPDATE address
+            SET street = :street,
+              town = :town,
+              postcode = :postcode
+            WHERE address.id = :id\n\n"
+            actual (:query (first (vals (update-query entity))))]
+        (is (string-equal-ignore-whitespace? actual expected))))
+    (testing "update query signature"
+      (let [expected ":! :n"
+            actual (:signature (first (vals (update-query entity))))]
+        (is (string-equal-ignore-whitespace? actual expected))))
+    (testing "search query generation"
+      (let [expected "-- :name search-strings-addres :? :1
+            -- :doc selects existing address records having any string field matching `:pattern` by substring match
+            SELECT * FROM address
+            WHERE street LIKE '%:pattern%'
+              OR town LIKE '%:pattern%'
+              OR postcode LIKE '%:pattern%'
+            ORDER BY address.street,
+              address.postcode,
+              address.id
+            --~ (if (:offset params) \"OFFSET :offset \")
+            --~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")\n\n"
+            actual (:query (first (vals (search-query entity application))))]
+        (is (string-equal-ignore-whitespace? actual expected))))
+    (testing "search query signature"
+      (let [expected ":? :1"
+            actual (:signature (first (vals (search-query entity))))]
+        (is (string-equal-ignore-whitespace? actual expected))))
+    (testing "select query generation"
+      (let [expected "-- :name get-addres :? :1
+            -- :doc selects an existing addres record
+            SELECT * FROM address
+            WHERE address.id = :id\n\n"
+            actual (:query (first (vals (select-query entity))))]
+        (is (string-equal-ignore-whitespace? actual expected))))
+    (testing "select query signature"
+      (let [expected ":? :1"
+            actual (:signature (first (vals (select-query entity))))]
+        (is (string-equal-ignore-whitespace? actual expected))))
+    (testing "list query generation"
+      (let [expected "-- :name list-address :? :*
+            -- :doc lists all existing addres records
+            SELECT * FROM address
+            ORDER BY address.street,
+              address.postcode,
+              address.id
+            --~ (if (:offset params) \"OFFSET :offset \")
+            --~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")\n\n"
+            actual (:query (first (vals (list-query entity))))]
+        (is (string-equal-ignore-whitespace? actual expected))))
+    (testing "list query signature"
+      (let [expected ":? :*"
+            actual (:signature (first (vals (list-query entity))))]
+        (is (string-equal-ignore-whitespace? actual expected))))
+    (testing "delete query generation"
+      (let [expected "-- :name delete-addres! :! :n
+            -- :doc updates an existing addres record
+            DELETE FROM address
+            WHERE address.id = :id\n\n"
+            actual (:query (first (vals (delete-query entity))))]
+        (is (string-equal-ignore-whitespace? actual expected))))
+    (testing "delete query signature"
+      (let [expected ":! :n"
+            actual (:signature (first (vals (delete-query entity))))]
+        (is (string-equal-ignore-whitespace? actual expected))))
+
+  ))
+
+(deftest complex-key-tests
+  (let [application {:tag :application,
+             :attrs {:version "0.1.1", :name "test-app"},
+             :content
+             [{:tag :entity,
+               :attrs {:name "address"},
+               :content
+               [{:tag :key,
+                 :attrs nil,
+                 :content
+                 [{:tag :property,
+                   :attrs
+                   {:immutable "true",
+                    :required "true",
+                    :distinct "system",
+                    :type "integer",
+                    :name "id"},
+                   :content
+                   [{:tag :generator, :attrs {:action "native"}, :content nil}]}
+                  {:tag :property,
+                   :attrs
+                   {:immutable "true",
+                    :required "true",
+                    :distinct "all",
+                    :generator "assigned"
+                    :type "string",
+                    :size "12"
+                    :name "postcode"},
+                   :content
+                   [{:tag :generator, :attrs {:action "native"}, :content nil}]}
+                  ]}
+                {:tag :property,
+                 :attrs
+                 {:distinct "user", :size "128", :type "string", :name "street"},
+                 :content nil}
+                {:tag :property,
+                 :attrs {:size "64", :type "string", :name "town"},
+                 :content nil}
+                ]}]}
+        entity (child-with-tag application :entity)]
     (testing "user distinct properties should provide the default ordering"
       (let [expected "ORDER BY address.street,
             address.postcode,
             address.id"
-            actual (order-by-clause xml)]
+            actual (order-by-clause entity)]
         (is (string-equal-ignore-whitespace? actual expected))))
     (testing "keys name extraction"
-      (let [expected '("id" "postcode")
+      (let [expected #{"id" "postcode"}
-            actual (key-names xml)]
+            actual (key-names entity)]
         (is (string-equal-ignore-whitespace? actual expected))))
     (testing "insert query generation - compound key, non system generated field in key"
-      (let [expected "-- :name create-addres! :! :n
+      (let [expected "-- :name create-address! :! :n
-            -- :doc creates a new addres record
+            -- :doc creates a new address record
             INSERT INTO address (street,
               town,
               postcode)
@@ -209,17 +226,17 @@
               ':postcode')
             returning id,
             postcode\n\n"
-            actual (:query (first (vals (insert-query xml))))]
+            actual (:query (first (vals (insert-query entity))))]
         (is (string-equal-ignore-whitespace? actual expected))))
     (testing "update query generation - compound key"
-      (let [expected "-- :name update-addres! :! :n
+      (let [expected "-- :name update-address! :! :n
-            -- :doc updates an existing addres record
+            -- :doc updates an existing address record
             UPDATE address
             SET street = :street,
               town = :town
             WHERE address.id = :id
               AND address.postcode = ':postcode'\n\n"
-            actual (:query (first (vals (update-query xml))))]
+            actual (:query (first (vals (update-query entity))))]
         (is (string-equal-ignore-whitespace? actual expected))))
     (testing "search query generation - user-distinct field in key"
       (let [expected  "-- :name search-strings-addres :? :1
@@ -233,7 +250,7 @@
               address.id
             --~ (if (:offset params) \"OFFSET :offset \")
             --~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")\n\n"
-            actual (:query (first (vals (search-query xml))))]
+            actual (:query (first (vals (search-query entity application))))]
         (is (string-equal-ignore-whitespace? actual expected))))
     (testing "delete query generation - compound key"
       (let [expected "-- :name delete-addres! :! :n
@@ -241,6 +258,6 @@
             DELETE FROM address
             WHERE address.id = :id
               AND address.postcode = ':postcode'\n\n"
-            actual (:query (first (vals (delete-query xml))))]
+            actual (:query (first (vals (delete-query entity))))]
         (is (string-equal-ignore-whitespace? actual expected))))))