Lots of work on trying to get all validator tests to pass.

Three still fail, but substantial progress. The to-husql-queries
tests are failing much worse, but are not a current target (nor is
the validator, frankly, but it irks me that it is so broken)

project.clj

@@ -5,14 +5,14 @@
   :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.6"]
+  :dependencies [[adl-support "0.1.8-SNAPSHOT"]
                  [bouncer "1.0.1"]
                  [clojure-saxon "0.9.4"]
-                 [environ "1.1.0"]
+                 [environ "1.2.0"]
                  [hiccup "1.0.5"]
-                 [org.clojure/clojure "1.8.0"]
+                 [org.clojure/clojure "1.12.0"]
-                 [org.clojure/math.combinatorics "0.1.4"]
+                 [org.clojure/math.combinatorics "0.3.0"]
-                 [org.clojure/tools.cli "0.3.7"]]
+                 [org.clojure/tools.cli "1.1.230"]]
 
   :aot  [adl.main]
 

src/adl/to_hugsql_queries.clj

@@ -3,12 +3,10 @@
   adl.to-hugsql-queries
    (:require [adl-support.core :refer :all]
              [adl-support.utils :refer :all]
-            [clojure.java.io :refer [file make-parents]]
+             [clojure.java.io :refer [make-parents]]
              [clojure.math.combinatorics :refer [combinations]]
              [clojure.string :as s]
-            [clojure.xml :as x]
+             [clj-time.core :as t]))
-            [clj-time.core :as t]
-            [clj-time.format :as f]))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;;
@@ -33,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."
@@ -46,7 +44,7 @@
     (let
      [entity-name (safe-name entity :sql)
       property-names (map #(:name (:attrs %)) properties)]
-     (if-not (empty? property-names)
+      (when-not (empty? property-names)
         (str
          "WHERE "
          (s/join
@@ -56,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))
@@ -89,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."
@@ -128,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)
@@ -158,13 +156,19 @@
             (where-clause entity))})))
 
 
-(defn search-query [entity application]
+ (defn search-query
-  "Generate an appropriate search query for string fields of this `entity`"
+   "Generate an appropriate search query for string fields of this `entity`.
+    
+    Unused second argument was `application`, and is retained for backward 
+    compatibility."
+   ([entity _]
+   (search-query entity))
+ ([entity]
   (let [entity-name (safe-name entity :sql)
         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
@@ -215,11 +219,10 @@
              properties))))
          (order-by-clause entity "lv_" true)
          "--~ (if (:offset params) \"OFFSET :offset \")"
-             "--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")")))})))
+         "--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")")))}))))
 
 ;; (search-query e a)
 
-
 (defn select-query
   "Generate an appropriate `select` query for this `entity`"
   ([entity properties]
@@ -229,7 +232,9 @@
            pretty-name (singularise entity-name)
            query-name (if (= properties (key-properties entity))
                         (str "get-" pretty-name)
-                        (str "get-" pretty-name "-by-" (s/join "=" (map #(:name (:attrs %)) properties))))
+                        (str "get-" pretty-name "-by-" 
+                             (s/join "=" 
+                                     (map #(:name (:attrs %)) properties))))
            signature ":? :1"]
        (hash-map
         (keyword query-name)
@@ -350,8 +355,7 @@
                        (str "SELECT DISTINCT lv_" safe-far ".* \nFROM lv_" safe-far)
                        (str "WHERE lv_" safe-far "." (safe-name (first (key-names far-entity)) :sql) " = :id")
                        (order-by-clause far-entity "lv_" false))
-                    (list (str "ERROR: unexpected type " link-type " of property " %)))))
+               (list (str "ERROR: unexpected type " link-type " of property " %)))))}))
-              }))
       links))))
 
 
@@ -446,7 +450,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

@@ -3,10 +3,9 @@
   adl.to-psql
   (:require [adl-support.core :refer :all]
             [adl-support.utils :refer :all]
-            [adl.to-hugsql-queries :refer [queries]]
+           ;;  [adl.to-hugsql-queries :refer [queries]]
-            [clojure.java.io :refer [file make-parents writer]]
+            [clojure.java.io :refer [make-parents]]
             [clojure.string :as s]
-            [clojure.xml :as x]
             [clj-time.core :as t]
             [clj-time.format :as f]))
 
@@ -220,7 +219,7 @@
                (if
                  key?
                  "NOT NULL PRIMARY KEY"
-                 (if (= (:required (:attrs property)) "true") "NOT NULL"))))))))))
+                 (when (= (:required (:attrs property)) "true") "NOT NULL"))))))))))
 
 
 (defn compose-convenience-entity-field
@@ -259,6 +258,7 @@
             (all-properties entity)
             (user-distinct-properties entity)))))))
 
+(declare compose-convenience-where-clause)
 
 (defn compose-convenience-where-clause
   "Compose an SQL `WHERE` clause for a convenience view of this

src/adl/validator.clj

@@ -2,11 +2,11 @@
       TODO: this is at present largely a failed experiment."
       :author "Simon Brooke"}
  adl.validator
-  (:require [adl-support.utils :refer :all]
+  (:require [adl-support.utils :refer []]
             [clojure.set :refer [union]]
             [clojure.xml :refer [parse]]
             [bouncer.core :as b]
-            [bouncer.validators :as v]))
+            [bouncer.validators :as v :refer [every member required string]]))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;;
@@ -43,11 +43,11 @@
    (symbol? validation)
     (try
       (b/validate o validation)
-      (catch java.lang.ClassCastException c
+      (catch java.lang.ClassCastException _
         ;; 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!
-        (if (string? o) [nil o]))
+        (when (string? o) [nil o]))
       (catch Exception e
         [{:error (.getName (.getClass e))
           :message (.getMessage e)
@@ -55,27 +55,26 @@
           :context o} o]))
     [(str "Error: not a symbol" validation) o]))
 
-(defmacro disjunct-valid?
+(defn disjunct-valid?
   "Yes, this is a horrible hack. I should be returning the error structure
    not printing it. But I can't see how to make that work with `bouncer`.
    OK, so: most of the validators will (usually) fail, and that's OK. How
    do we identify the one which ought not to have failed?"
   [o & validations]
-  `(println
+  (println
    (str
-    (if (:tag ~o) (str "Tag: " (:tag ~o) "; "))
+    (when (:tag o) (str "Tag: " (:tag o) "; "))
-    (if (:name (:attrs ~o)) (str "Name: " (:name (:attrs ~o)) ";"))
+    (when (:name (:attrs o)) (str "Name: " (:name (:attrs o)) ";"))
-    (if-not (or (:tag ~o) (:name (:attrs ~o))) (str "Context: " ~o))))
+    (when-not (or (:tag o) (:name (:attrs o))) (str "Context: " o))))
 
-  `(empty?
+  (empty?
    (remove :tag (remove nil? (map first (map
-         #(try-validate ~o '%)
+                                         #(try-validate o '%)
-         ~validations))))))
+                                         validations))))))
 
 ;;; the remainder of this file is a fairly straight translation of the ADL 1.4 DTD into Clojure
 
-
+(declare documentation-validations fieldgroup-validations)
-(declare documentation-validations fieldgroup-validations )
 
 (def permissions
   "permissions a group may have on an entity, list, page, form or field
@@ -170,7 +169,7 @@
 (def sequences #{"canonical", "reverse-canonical"})
 
 (def reference-validations
-"The 'specification' and 'reference' elements are for documentation only,
+  "The 'specification' and 'reference' elements are for documentation only,
 	and do not contribute to the engineering of the application described.
 
 	A reference element is a reference to a specifying document.
@@ -191,6 +190,15 @@
    [:attrs :property] v/string ;; and should be the name of a property in that entity
    :content [[v/every documentation-validations]]})
 
+;; (def sample-reference {:tag :reference
+;;                        :attrs {:abbr "foo"
+;;                                :section "bar"
+;;                                :entity "animal"
+;;                                :property "breed"}
+;;                        :content [{:tag :documentation
+;;                                   :content ["Every animal should have a breed."]}]})
+
+;; (b/validate sample-reference reference-validations)
 
 (def specification-validations
   "The 'specification' and 'reference' elements are for documentation only,
@@ -208,20 +216,27 @@
    [:attrs :name] [v/string v/required]
    [:attrs :abbr] [v/string v/required]
    :content [[v/every #(disjunct-valid?
+                        %
                         documentation-validations
                         reference-validations)]]})
 
 
 (def documentation-validations
-  "contains documentation on the element which immediately contains it. TODO:
+  "contains documentation on the element which immediately contains it. For 
-  should HTML markup within a documentation element be allowed? If so, are
+   the time being, HTML markup is not permitted within documentation, but 
-  there restrictions?"
+   Markdown (which may include a string representation of HTML markup) should
+   be."
   {:tag [v/required [#(= % :documentation)]]
     :content [[v/every  #(disjunct-valid?
                           %
                         v/string
-                        reference-validations)]]
+                        reference-validations)]]})
-                        })
+
+;; (def sample-documentation {:tag :documentation
+;;                            :content ["Every animal should have a breed."
+;;                                      sample-reference]})
+;; (b/validate sample-documentation documentation-validations)
+;; (b/valid? sample-documentation documentation-validations)
 
 (def content-validations
   {:tag [v/required [#(= % :content)]]})
@@ -293,6 +308,17 @@
                         (b/valid? % documentation-validations)
                         (b/valid? % prompt-validations))]]})
 
+(def sample-option {:tag :option,
+                    :attrs {:value "Female"},
+                    :content
+                    [{:tag :prompt,
+                      :attrs {:locale "fr-FR", :prompt "Femme"},
+                      :content nil}
+                     {:tag :prompt,
+                      :attrs {:locale "en-GB", :prompt "Female"},
+                      :content nil}]})
+(b/validate sample-option option-validations)
+
 (def pragma-validations
   "pragmatic advice to generators of lists and forms, in the form of
   name/value pairs which may contain anything. Over time some pragmas
@@ -302,8 +328,6 @@
    [: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
@@ -425,34 +449,54 @@
               committed to persistent store, the value which it holds before
               it has been committed"
   {:tag [v/required [#(= % :property)]]
-   [:attrs :name] [v/required v/string]
-   [:attrs :type] [v/required [v/member all-data-types]]
-   ;; [:attrs :default] [] ;; it's allowed, but I don't have anything particular to say about it
-   [:attrs :typedef] v/string
    [:attrs :distinct] [v/string [v/member #{"none", "all", "user", "system"}]]
    [:attrs :entity] v/string
    [:attrs :farkey] v/string
-   [:attrs :required] [[v/member #{"true", "false"}]]
    [:attrs :immutable] [[v/member #{"true", "false"}]]
+   [:attrs :name] [v/required v/string]
+   [:attrs :required] [[v/member #{"true", "false"}]]
    [:attrs :size] [[#(cond
                        (empty? %) ;; it's allowed to be missing
                        true
                        (string? %)
                        (integer? (read-string %))
-                      true
+                       :else
                        (integer? %))]]
+   [:attrs :type] [v/required [v/member all-data-types]]
+   ;; [:attrs :default] [] ;; it's allowed, but I don't have anything particular to say about it
+   [:attrs :typedef] v/string
+   [:attrs :cascade] [[v/member cascade-actions]]
    [:attrs :column] v/string
    [:attrs :concrete] [[v/member #{"true", "false"}]]
-   [:attrs :cascade] [[v/member cascade-actions]]
+   :content [[v/every #(disjunct-valid? %
-;;    :content [[v/every #(disjunct-valid? %
+                         documentation-validations
-;;                          documentation-validations
+                         generator-validations
+                         permission-validations
+                         option-validations
+                         prompt-validations
+                         help-validations
+                         ifmissing-validations)]]
+   })
+
+;; (disjunct-valid? sample-option documentation-validations
 ;;                                generator-validations
 ;;                                permission-validations
 ;;                                option-validations
 ;;                                prompt-validations
 ;;                                help-validations
-;;                          ifmissing-validations)]]
+;;                                ifmissing-validations)
-   })
+
+;; (def sample-property {:tag :property,
+;;                       :attrs
+;;                       {:immutable "true",
+;;                        :required "true",
+;;                        :distinct "system",
+;;                        :type "integer",
+;;                        :name "id"},
+;;                       :content
+;;                       [{:tag :generator, :attrs {:action "native"}, :content nil}]})
+
+;; (b/validate sample-property property-validations)
 
 
 (def permission-validations

test/adl/to_hugsql_queries_test.clj

@@ -1,8 +1,8 @@
 (ns adl.to-hugsql-queries-test
   (:require [clojure.string :as s]
-            [clojure.test :refer :all]
+            [clojure.test :refer [deftest is testing]]
-            [adl.to-hugsql-queries :refer :all]
+            [adl.to-hugsql-queries :refer [delete-query insert-query list-query order-by-clause search-query select-query update-query]]
-            [adl-support.utils :refer :all]))
+            [adl-support.utils :refer [child-with-tag has-non-key-properties? has-primary-key? key-names]]))
 
 (defn string-equal-ignore-whitespace?
   "I don't want unit tests to fail just because emitted whitespace changes."
@@ -47,16 +47,14 @@
                             :size "12"
                             :name "postcode"},
                            :content
-                   [{:tag :generator, :attrs {:action "native"}, :content nil}]}
+                           [{: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}
+                         :content nil}]}]}
-                ]}]}
         entity (child-with-tag application :entity)]
     (testing "user distinct properties should provide the default ordering"
       (let [expected
@@ -64,7 +62,6 @@
             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"},
@@ -94,16 +91,14 @@
                             :size "12"
                             :name "postcode"},
                            :content
-                   [{:tag :generator, :attrs {:action "native"}, :content nil}]}
+                           [{: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}
+                         :content nil}]}]}
-                ]}]}
         entity (child-with-tag application :entity)]
     (testing "keys name extraction"
       (let [expected #{"id" "postcode"}
@@ -140,16 +135,14 @@
                             :size "12"
                             :name "postcode"},
                            :content
-                   [{:tag :generator, :attrs {:action "native"}, :content nil}]}
+                           [{: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}
+                         :content nil}]}]}
-                ]}]}
         entity (child-with-tag application :entity)]
     (testing "keys name extraction"
       (let [expected #{"id"}
@@ -248,9 +241,7 @@
     (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,
@@ -281,16 +272,14 @@
                             :size "12"
                             :name "postcode"},
                            :content
-                   [{:tag :generator, :attrs {:action "native"}, :content nil}]}
+                           [{: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}
+                         :content nil}]}]}
-                ]}]}
         entity (child-with-tag application :entity)]
     (testing "user distinct properties should provide the default ordering"
       (let [expected "ORDER BY address.street,

test/adl/validator_test.clj

@@ -1,9 +1,10 @@
 (ns adl.validator-test
-  (:require [clojure.java.io :refer [writer]]
+  (:require
-            [clojure.test :refer :all]
-            [clojure.xml :refer [parse]]
    [adl.validator :refer :all]
-            [bouncer.core :refer [valid?]]))
+   [bouncer.core :refer [valid? validate]]
+   [clojure.java.io :refer [writer]]
+   [clojure.test :refer :all]
+   [clojure.xml :refer [parse]]))
 
 ;; OK, so where we're up to: documentation breaks validation of the
 ;; element that contains it if the documentation is non-empty.
@@ -262,9 +263,9 @@
                   :name "id"},
                  :content
                  [{:tag :generator, :attrs {:action "native"}, :content nil}]}]}
-          expected true
+          expected nil
-          actual (binding [*out* (writer "/dev/null")]
+          actual (first (binding [*out* (writer "/dev/null")]
-                   (valid? xml key-validations))]
+                          (validate xml key-validations)))]
       (is (= actual expected)))))
 
 (deftest validator-property