Separated out print-usage into a new support namespace.

Also new unit tests.

src/adl_support/core.clj

@@ -53,9 +53,9 @@
     (cond
      (nil? v) {}
      (= v "") {}
-     (number? vr) {k vr}
+     (number? vr) {(keyword k) vr}
      true
-     {k v})))
+     {(keyword k) v})))
 
 
 (defn massage-params
@@ -65,6 +65,8 @@
   values out of form-params - because we need the key to load the form in
   the first place, but just accepting values of other params would allow spoofing."
   [params form-params key-fields]
+  (let
+    [ks (set (map keyword key-fields))]
     (reduce
       merge
       ;; do the keyfields first, from params
@@ -74,13 +76,13 @@
         (map
           #(massage-value % params)
           (filter
-      #(key-fields (str (name %)))
+            #(ks (keyword %))
             (keys params))))
       ;; then merge in everything from form-params, potentially overriding what
       ;; we got from params.
       (map
         #(massage-value % form-params)
-    (keys form-params))))
+        (keys form-params)))))
 
 
 (defn

src/adl_support/print_usage.clj

@@ -0,0 +1,52 @@
+(ns adl-support.print-usage
+  (:require [clojure.string :refer [join]]))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;
+;;;; adl-support.print-usage: functions used by ADL-generated code.
+;;;;
+;;;; This program is free software; you can redistribute it and/or
+;;;; modify it under the terms of the MIT-style licence provided; see LICENSE.
+;;;;
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;;; License for more details.
+;;;;
+;;;; Copyright (C) 2018 Simon Brooke
+;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+(defn print-usage
+  "Print a UN*X style usage message. `project-name` should be the base name of
+  the executable jar file you generate, `parsed-options` should be options as
+  parsed by [clojure.tools.cli](https://github.com/clojure/tools.cli). If
+  `extra-args` is supplied, it should be a map of name, documentation pairs
+  for each additional argument which may be supplied."
+  ([project-name parsed-options]
+   (print-usage project-name parsed-options {}))
+  ([project-name parsed-options extra-args]
+   (println
+     (join
+       "\n"
+       (flatten
+         (list
+           (join " "
+                 (concat
+                   (list
+                     "Usage: java -jar "
+                     (str
+                       project-name
+                       "-"
+                       (or (System/getProperty (str project-name ".version")) "[VERSION]")
+                       "-standalone.jar")
+                     "-options")
+                   (map name (keys extra-args))))
+           "where options include:"
+           (:summary parsed-options)
+           (doall
+             (map
+               #(str "  " (name %) "\t\t" (extra-args %))
+               (keys extra-args)))))))))
+

src/adl_support/utils.clj

@@ -27,7 +27,7 @@
 
 (def ^:dynamic  *locale*
   "The locale for which files will be generated."
-  "en-GB")
+  "en_GB.UTF-8")
 
 (def ^:dynamic *output-path*
   "The path to which generated files will be written."
@@ -108,7 +108,7 @@
                 (-> % :attrs :entity)
                 (-> property :attrs :entity)))))
      (s/join
-       "_" (map #(:name (:attrs %)) (list property e1 e2)))
+       "_" (cons "ln" (map #(:name (:attrs %)) (list property e1 e2))))
      (link-table-name e1 e2))))
 
 
@@ -170,7 +170,6 @@
    (first (children-with-tag element tag predicate))))
 
 
-
 (defn typedef
   "If this `property` is of type `defined`, return its type definition from
   this `application`, else nil."
@@ -246,13 +245,17 @@
   (permission-groups permissions #(#{"read" "insert" "noedit" "edit" "all"} (:permission (:attrs %)))))
 
 
-(defn writable-by
+(defn writeable-by
   "Return a list of names of groups to which are granted write access,
   given these `permissions`, else nil.
-  TODO: TOTHINKABOUT: properties are also writable by `insert` and `noedit`, but only if the
+  TODO: TOTHINKABOUT: properties are also writeable by `insert` and `noedit`, but only if the
   current value is nil."
-  [permissions]
+  ([permissions]
-  (permission-groups permissions #(#{"edit" "all"} (:permission (:attrs %)))))
+   (writeable-by permissions true))
+  ([permissions has-value?]
+  (let
+    [privileges (if has-value? #{"edit" "all"} #{"edit" "all" "insert" "noedit"})]
+  (permission-groups permissions #(privileges (:permission (:attrs %)))))))
 
 
 (defn singularise
@@ -274,11 +277,14 @@
 (defn capitalise
   "Return a string like `s` but with each token capitalised."
   [s]
+  (if
+    (string? s)
     (s/join
       " "
       (map
         #(apply str (cons (Character/toUpperCase (first %)) (rest %)))
-      (s/split s #"[ \t\r\n]+"))))
+        (s/split s #"[ \t\r\n]+")))
+    s))
 
 
 (defn pretty-name
@@ -288,7 +294,7 @@
 
 (defn safe-name
   "Return a safe name for the object `o`, given the specified `convention`.
-  `o` is expected to be either a string or an entity."
+  `o` is expected to be either a string or an element."
   ([o]
    (if
      (element? o)
@@ -308,6 +314,45 @@
          (safe-name string))))))
 
 
+(defn property-for-field
+  "Return the property within this `entity` which matches this `field`."
+  [field entity]
+  (child-with-tag
+    entity
+    :property
+    #(=
+       (-> field :attrs :property)
+       (-> % :attrs :name))))
+
+
+(defn prompt
+  "Return an appropriate prompt for the given `field-or-property` taken from this
+  `form` of this `entity` of this `application`, in the context of the current
+  binding of `*locale*`. TODO: something more sophisticated about i18n"
+  [field-or-property form entity application]
+  (let [property (case (:tag field-or-property)
+                   :property field-or-property
+                   :field (property-for-field field-or-property entity)
+                   nil)]
+    (capitalise
+      (or
+        (:prompt
+          (:attrs
+            (child-with-tag
+              field-or-property
+              :prompt
+              #(= (:locale (:attrs %)) *locale*))))
+        (:prompt
+          (:attrs
+            (child-with-tag
+              property
+              :prompt
+              #(= (:locale (:attrs %)) *locale*))))
+        (:name (:attrs property))
+        (:property (:attrs field-or-property))
+        "Missing prompt"))))
+
+
 (defmacro properties
   "Return all the properties of this `entity`."
   [entity]
@@ -315,8 +360,9 @@
 
 
 (defn descendants-with-tag
-  "Return all descendants of this `element`, recursively, which have this `tag`."
+  "Return all descendants of this `element`, recursively, which have this `tag`.
-  [element tag]
+  If `predicate` is specified, return only those also satisfying this `predicate`."
+  ([element tag]
    (flatten
      (remove
        empty?
@@ -325,6 +371,19 @@
          (map
            #(descendants-with-tag % tag)
            (children element))))))
+  ([element tag predicate]
+   (filter
+     predicate
+     (descendants-with-tag element tag))))
+
+
+(defn descendant-with-tag
+  "Return the first descendant of this `element`, recursively, which has this `tag`.
+  If `predicate` is specified, return the first also satisfying this `predicate`."
+  ([element tag]
+   (first (descendants-with-tag element tag)))
+  ([element tag predicate]
+   (first (descendants-with-tag element tag predicate))))
 
 
 (defn find-permissions
@@ -396,13 +455,20 @@
     (= (count properties) (count links))))
 
 
-(defn key-names [entity]
+(defn key-names
+  ([entity]
   (set
     (remove
       nil?
       (map
         #(:name (:attrs %))
         (key-properties entity)))))
+  ([entity as-keywords?]
+   (let [names (key-names entity)]
+     (if
+       as-keywords?
+       (set (map keyword names))
+       names))))
 
 
 (defn base-type

test/adl_support/core_test.clj

@@ -24,3 +24,21 @@
       (is (= expected actual) "Yeys with no values should not be included in the map"))
     ))
 
+(deftest massage-params-tests
+  (testing "Massaging of params"
+    (let [expected {:id 67}
+          actual (massage-params {:id 67} {} #{:id})]
+      (is (= expected actual) "numeric param"))
+    (let [expected {:id 67}
+          actual (massage-params {:id "67"} {} #{:id})]
+      (is (= expected actual) "string param"))
+    (let [expected {:id 67}
+          actual (massage-params {"id" "67"} {} #{:id})]
+      (is (= expected actual) "string keyword"))
+    (let [expected {:id 67}
+          actual (massage-params {:id 60} {:id 67} #{:id})]
+      (is (= expected actual) "params and form-params differ"))
+    (let [expected {:id 67 :offset 0 :limit 50}
+          actual (massage-params {:id 60} {:id "67" :offset "0" :limit "50"} #{:id})]
+      (is (= expected actual) "Limit and offset in form-params"))
+      ))

test/adl_support/utils_test.clj

@@ -0,0 +1,299 @@
+(ns adl-support.utils-test
+  (:require [clojure.test :refer :all]
+            [adl-support.utils :refer :all]))
+
+;; Yes, there's MASSES in utils which ought to be tested. I'll add more tests over time.
+
+(deftest child-with-tag-tests
+  (testing "child-with-tag"
+    (let [expected {:tag :prompt
+                    :attrs {:prompt "test"
+                            :locale "en_GB.UTF-8"}}
+          actual (child-with-tag {:tag :property
+                                  :attrs {:name "not test"}
+                                  :content [{:tag :prompt
+                                             :attrs {:prompt "test"
+                                                     :locale "en_GB.UTF-8"}}]}
+                                 :prompt)]
+      (is (= expected actual) "Basic search for one child which exists"))
+    (let [expected nil
+          actual (child-with-tag {:tag :property
+                                  :attrs {:name "not test"}
+                                  :content [{:tag :prompt
+                                             :attrs {:prompt "test"
+                                                     :locale "en_GB.UTF-8"}}]}
+                                 :frobox)]
+      (is (= expected actual) "Basic search for one child which doesn't exist"))
+    (let [expected nil
+          actual (child-with-tag nil :frobox)]
+      (is (= expected actual) "Basic search with nil element"))
+    (let [expected {:tag :prompt
+                    :attrs {:prompt "test"
+                            :locale "en_GB.UTF-8"}}
+          actual (child-with-tag {:tag :property
+                                  :attrs {:name "not test"}
+                                  :content [{:tag :frobox}
+                                            {:tag :prompt
+                                             :attrs {:prompt "test"
+                                                     :locale "en_GB.UTF-8"}}]}
+                                 :prompt)]
+      (is (= expected actual) "Basic search for one child which exists but is not first"))
+    (let [expected {:tag :prompt
+                    :attrs {:prompt "test"
+                            :locale "en_GB.UTF-8"}}
+          actual (child-with-tag {:tag :property
+                                  :attrs {:name "not test"}
+                                  :content [{:tag :prompt
+                                             :attrs {:prompt "essai"
+                                                     :locale "fr-FR"}}
+                                            {:tag :prompt
+                                             :attrs {:prompt "test"
+                                                     :locale "en_GB.UTF-8"}}]}
+                                 :prompt
+                                 #(= (-> % :attrs :locale) "en_GB.UTF-8"))]
+      (is (= expected actual) "Conditional search for one child which exists (1)"))
+    (let [*locale* "fr-FR"
+          expected {:tag :prompt
+                    :attrs {:prompt "essai"
+                            :locale "fr-FR"}}
+          actual (child-with-tag {:tag :property
+                                  :attrs {:name "not test"}
+                                  :content [{:tag :prompt
+                                             :attrs {:prompt "essai"
+                                                     :locale "fr-FR"}}
+                                            {:tag :prompt
+                                             :attrs {:prompt "test"
+                                                     :locale "en_GB.UTF-8"}}]}
+                                 :prompt
+                                 #(= (-> % :attrs :locale) "fr-FR"))]
+      (is (= expected actual) "Conditional search for one child which exists (2)"))
+    ))
+
+
+(deftest prompt-tests
+  (testing "Prompts for fields and properties"
+    (let [*locale* "en_GB.UTF-8"
+          expected "Test"
+          actual (prompt {:tag :property
+                          :attrs {:name "not test"}
+                          :content [{:tag :prompt
+                                     :attrs {:prompt "test"
+                                             :locale "en_GB.UTF-8"}}]}
+                         {}
+                         {}
+                         {})]
+      (is (= expected actual) "Basic property with one prompt in current locale"))
+    (let [*locale* "en_GB.UTF-8"
+          expected "Test"
+          actual (prompt {:tag :field
+                          :attrs {:property "not-test"}
+                          :content [{:tag :prompt
+                                     :attrs {:prompt "test"
+                                             :locale "en_GB.UTF-8"}}]}
+                         {}
+                         {}
+                         {})]
+      (is (= expected actual) "Basic field with one prompt in current locale"))
+    (let [*locale* "en_GB.UTF-8"
+          expected "Test"
+          actual (prompt {:tag :field
+                          :attrs {:property "not-test"}}
+                         {}
+                         {:tag :entity
+                          :content [{:tag :property
+                                     :attrs {:name "not-test"}
+                                     :content [{:tag :prompt
+                                                :attrs {:prompt "test"
+                                                        :locale "en_GB.UTF-8"}}]}]}
+                         {})]
+      (is (= expected actual) "Basic field with no prompt, in context of entity
+          with appropriate property with prompt in current locale"))
+    (let [*locale* "en_GB.UTF-8"
+          expected "Home"
+          actual (prompt {:tag :field,
+                          :attrs {:property "dwelling_id"}}
+                         {}
+                         {:tag :entity,
+                          :attrs
+                          {:volatility "5",
+                           :magnitude "6",
+                           :name "electors",
+                           :table "electors"},
+                          :content
+                          [{:tag :documentation,
+                            :attrs nil,
+                            :content
+                            ["All electors known to the system; electors are\n    people believed to be entitled to vote in the current\n    campaign."]}
+                           {:tag :key,
+                            :attrs nil,
+                            :content
+                            [{:tag :property,
+                              :attrs
+                              {:distinct "system",
+                               :immutable "true",
+                               :column "id",
+                               :name "id",
+                               :type "integer",
+                               :required "true"},
+                              :content
+                              [{:tag :prompt,
+                                :attrs {:locale "en_GB.UTF-8", :prompt "id"},
+                                :content nil}]}]}
+                           {:tag :property,
+                            :attrs
+                            {:distinct "user",
+                             :column "name",
+                             :name "name",
+                             :type "string",
+                             :required "true",
+                             :size "64"},
+                            :content
+                            [{:tag :prompt,
+                              :attrs {:locale "en_GB.UTF-8", :prompt "Name"},
+                              :content nil}]}
+                           {:tag :property,
+                            :attrs
+                            {:farkey "id",
+                             :entity "dwellings",
+                             :column "dwelling_id",
+                             :name "dwelling_id",
+                             :type "entity",
+                             :required "true"},
+                            :content
+                            [{:tag :prompt,
+                              :attrs {:locale "en_GB.UTF-8", :prompt "Home"},
+                              :content nil}]}
+                           {:tag :property,
+                            :attrs {:column "phone", :name "phone", :type "string", :size "16"},
+                            :content
+                            [{:tag :prompt,
+                              :attrs {:locale "en_GB.UTF-8", :prompt "Phone"},
+                              :content nil}]}
+                           {:tag :property,
+                            :attrs
+                            {:column "email", :name "email", :type "string", :size "128"},
+                            :content
+                            [{:tag :prompt,
+                              :attrs {:locale "en_GB.UTF-8", :prompt "Email"},
+                              :content nil}]}
+                           {:tag :property,
+                            :attrs
+                            {:default "Unknown",
+                             :farkey "id",
+                             :entity "genders",
+                             :column "gender",
+                             :type "entity",
+                             :name "gender"},
+                            :content
+                            [{:tag :prompt,
+                              :attrs {:locale "en_GB.UTF-8", :prompt "Gender"},
+                              :content nil}]}
+                           {:tag :property,
+                            :attrs {:type "text", :name "signature"},
+                            :content
+                            [{:tag :documentation,
+                              :attrs nil,
+                              :content
+                              ["The signature of this elector, captured as SVG text,\n      as evidence they have consented to us holding data on them.\n      Null if they have not."]}]}
+                           {:tag :list,
+                            :attrs {:name "Electors", :properties "listed"},
+                            :content
+                            [{:tag :field,
+                              :attrs {:property "id"},
+                              :content
+                              [{:tag :prompt,
+                                :attrs {:locale "en_GB.UTF-8", :prompt "id"},
+                                :content nil}]}
+                             {:tag :field,
+                              :attrs {:property "name"},
+                              :content
+                              [{:tag :prompt,
+                                :attrs {:locale "en_GB.UTF-8", :prompt "Name"},
+                                :content nil}]}
+                             {:tag :field,
+                              :attrs {:property "dwelling_id"},
+                              :content
+                              [{:tag :prompt,
+                                :attrs {:locale "en_GB.UTF-8", :prompt "Home"},
+                                :content nil}]}
+                             {:tag :field,
+                              :attrs {:property "phone"},
+                              :content
+                              [{:tag :prompt,
+                                :attrs {:locale "en_GB.UTF-8", :prompt "Phone"},
+                                :content nil}]}
+                             {:tag :field,
+                              :attrs {:property "email"},
+                              :content
+                              [{:tag :prompt,
+                                :attrs {:locale "en_GB.UTF-8", :prompt "eMail"},
+                                :content nil}]}
+                             {:tag :field,
+                              :attrs {:property "gender"},
+                              :content
+                              [{:tag :prompt,
+                                :attrs {:locale "en_GB.UTF-8", :prompt "Gender"},
+                                :content nil}]}]}
+                           {:tag :form,
+                            :attrs {:name "Elector", :properties "listed"},
+                            :content
+                            [{:tag :field,
+                              :attrs {:property "id"},
+                              :content
+                              [{:tag :prompt,
+                                :attrs {:locale "en_GB.UTF-8", :prompt "id"},
+                                :content nil}]}
+                             {:tag :field,
+                              :attrs {:property "name"},
+                              :content
+                              [{:tag :prompt,
+                                :attrs {:locale "en_GB.UTF-8", :prompt "Name"},
+                                :content nil}]}
+                             {:tag :field,
+                              :attrs {:property "dwelling_id"},
+                              :content
+                              [{:tag :prompt,
+                                :attrs {:locale "en_GB.UTF-8", :prompt "Home"},
+                                :content nil}]}
+                             {:tag :field,
+                              :attrs {:property "phone"},
+                              :content
+                              [{:tag :prompt,
+                                :attrs {:locale "en_GB.UTF-8", :prompt "Phone"},
+                                :content nil}]}
+                             {:tag :field,
+                              :attrs {:property "email"},
+                              :content
+                              [{:tag :prompt,
+                                :attrs {:locale "en_GB.UTF-8", :prompt "eMail"},
+                                :content nil}]}
+                             {:tag :field,
+                              :attrs {:property "gender"},
+                              :content
+                              [{:tag :prompt,
+                                :attrs {:locale "en_GB.UTF-8", :prompt "Gender"},
+                                :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}]}
+
+                         {})]
+      (is (= expected actual) "With realistic clutter: field with no prompt, in context of entity
+          with appropriate property with prompt in current locale"))
+    ))
+