Work on ADL issue #3, auxlists.

src/adl_support/core.clj

@@ -101,6 +101,43 @@
 (def resolve-template (memoize raw-resolve-template))
 
 
+(defmacro compose-exception-reason
+  "Compose and return a sensible reason message for this `exception`."
+  ([exception intro]
+   `(str
+     ~intro
+     (if ~intro ": ")
+     (join
+      "\n\tcaused by: "
+      (reverse
+       (loop [ex# ~exception result# ()]
+         (if-not (nil? ex#)
+           (recur
+            (.getCause ex#)
+            (cons (str
+                   (.getName (.getClass ex#))
+                   ": "
+                   (.getMessage ex#)) result#))
+           result#))))))
+  ([exception]
+   `(compose-exception-reason ~exception nil)))
+
+
+(defmacro compose-reason-and-log
+  "Compose a reason message for this `exception`, log it (with its
+  stacktrace), and return the reason message."
+  ([exception intro]
+   `(let [reason# (compose-exception-reason ~exception ~intro)]
+      (clojure.tools.logging/error
+       reason#
+       "\n"
+       (with-out-str
+         (-> ~exception .printStackTrace)))
+      reason#))
+  ([exception]
+   `(compose-reason-and-log ~exception nil)))
+
+
 (defmacro do-or-log-error
   "Evaluate the supplied `form` in a try/catch block. If the
   keyword param `:message` is supplied, the value will be used
@@ -112,54 +149,23 @@
   `(try
      ~form
      (catch Exception any#
-       (clojure.tools.logging/error
+       (compose-reason-and-log any# ~message)
-        (str ~message
-             (with-out-str
-               (-> any# .printStackTrace))))
        ~error-return)))
 
 
-(defmacro compose-exception-reason
-  "Compose and return a sensible reason message for this `exception`."
-  [exception]
-  `(join
-    "\n\tcaused by: "
-    (reverse
-     (loop [ex# ~exception result# ()]
-       (if-not (nil? ex#)
-         (recur
-          (.getCause ex#)
-          (cons (str
-                 (.getName (.getClass ex#))
-                 ": "
-                 (.getMessage ex#)) result#))
-         result#)))))
-
-
-(defmacro compose-reason-and-log
-  "Compose a reason message for this `exception`, log it (with its
-  stacktrace), and return the reason message."
-  [exception]
-  `(let [reason# (compose-exception-reason ~exception)]
-     (clojure.tools.logging/error
-      (str reason#
-           "\n"
-           (with-out-str
-             (-> ~exception .printStackTrace))))
-     reason#))
-
-
 (defmacro do-or-return-reason
   "Clojure stacktraces are unreadable. We have to do better; evaluate
   this `form` in a try-catch block; return a map. If the evaluation
   succeeds, the map will have a key `:result` whose value is the result;
   otherwise it will have a key `:error` which will be bound to the most
   sensible error message we can construct."
-  [form]
+  ([form intro]
   `(try
      {:result ~form}
      (catch Exception any#
-       {:error (compose-exception-reason any#)})))
+       {:error (compose-exception-reason any# ~intro)})))
+  ([form]
+   `(do-or-return-reason ~form nil)))
 
 
 (defmacro do-or-log-and-return-reason
@@ -205,6 +211,6 @@
    `(try
       ~form
       (catch Exception any#
-        (*warn* (str ~intro ":\n\t" (compose-reason-and-log any#)))
+        (*warn* (compose-reason-and-log any# ~intro ))
         nil))))
 

src/adl_support/forms_support.clj

@@ -57,13 +57,9 @@
       :message message#
       :error-return {:warnings [message#]})))
 
-;; (macroexpand '(get-current-value str {:foo "bar" :ban 2} "addresses"))
-
 
 (defmacro get-menu-options
-  ;; TODO: constructing these query-method names at runtime is madness.
+  [entity-name get-q list-q fk value]
-  ;; we definitely need to construct them at compile time.
-  [entity-name fk value]
   `(remove
     nil?
     (flatten
@@ -72,45 +68,25 @@
         ~value
         (do-or-log-error
          (apply
-          (symbol (str "db/" (query-name ~entity-name :get)))
+          ~get-q
           (list db/*db* {~fk ~value}))
          :message
          (str "Error while fetching " ~entity-name " record '" ~value "'")))
       (do-or-log-error
        (apply
-        (symbol (str "db/" (query-name ~entity-name :list)))
+        ~list-q
-        (list db/*db*))
+        (list db/*db*)
+        {})
        :message
        (str "Error while fetching " ~entity-name " list"))))))
 
 
-;; (macroexpand '(get-menu-options "addresses" :address-id 7))
+(defmacro auxlist-data-name
+  "The name to which data for this `auxlist` will be bound in the
+  Selmer params."
+ [auxlist]
+ `(safe-name (str "auxlist-" (-> ~auxlist :attrs :property)) :clojure))
 
-;; (clojure.core/remove
-;;  clojure.core/nil?
-;;  (clojure.core/flatten
-;;   (clojure.core/list
-;;    (if
-;;      7
-;;      (adl-support.core/do-or-log-error
-;;       (clojure.core/apply
-;;        (clojure.core/symbol
-;;         (clojure.core/str
-;;          "db/"
-;;          (adl-support.forms-support/query-name "addresses" :get)))
-;;        (clojure.core/list
-;;         db/*db*
-;;         {:address-id 7}))
-;;       :message
-;;       (clojure.core/str "Error while fetching " "addresses" " record '" 7 "'")))
-;;    (adl-support.core/do-or-log-error
-;;     (clojure.core/apply
-;;      (clojure.core/symbol
-;;       (clojure.core/str "db/"
-;;                         (adl-support.forms-support/query-name "addresses" :list)))
-;;      (clojure.core/list db/*db*))
-;;     :message
-;;     (clojure.core/str "Error while fetching " "addresses" " list")))))
 
 (defmacro all-keys-present?
   "Return true if all the keys in `keys` are present in the map `m`."

src/adl_support/utils.clj

@@ -1,7 +1,8 @@
 (ns ^{:doc "Application Description Language support library - utility functions."
       :author "Simon Brooke"}
   adl-support.utils
-  (:require [clojure.math.numeric-tower :refer [expt]]
+  (:require [adl-support.core :refer [*warn*]]
+            [clojure.math.numeric-tower :refer [expt]]
             [clojure.pprint :as p]
             [clojure.string :as s]))
 
@@ -42,6 +43,12 @@
   (and (map? o) (:tag o) (:attrs o)))
 
 
+(defmacro entity?
+  "True if `o` is a Clojure representation of an ADL entity."
+  [o]
+  `(= (:tag ~o) :entity))
+
+
 (defn wrap-lines
   "Wrap lines in this `text` to this `width`; return a list of lines."
   ;; Shamelessly adapted from https://www.rosettacode.org/wiki/Word_wrap#Clojure
@@ -294,22 +301,45 @@
   "Return a safe name for the object `o`, given the specified `convention`.
   `o` is expected to be either a string or an element."
   ([o]
-   (if
+   (cond
-     (element? o)
+    (element? o)
-     (safe-name (:name (:attrs o)))
+    (safe-name (:name (:attrs o)))
-     (s/replace (str o) #"[^a-zA-Z0-9-]" "")))
+    true
+    (s/replace (str o) #"[^a-zA-Z0-9-]" "")))
   ([o convention]
-   (if
+   (cond
-     (element? o)
+    (and (entity? o) (= convention :sql))
-     (safe-name (:name (:attrs o)) convention)
+    ;; if it's an entity, it's permitted to have a different table name
-     (let [string (str o)]
+    ;; from its entity name. This isn't actually likely, but...
-       (case convention
+    (safe-name (or (-> o :attrs :table) (-> o :attrs :name)) :sql)
-         (:sql :c) (s/replace string #"[^a-zA-Z0-9_]" "_")
+    (element? o)
-         :c-sharp (s/replace (capitalise string) #"[^a-zA-Z0-9]" "")
+    (safe-name (:name (:attrs o)))
-         :java (let
+    true
-                 [camel (s/replace (capitalise string) #"[^a-zA-Z0-9]" "")]
+    (let [string (str o)]
-                 (apply str (cons (Character/toLowerCase (first camel)) (rest camel))))
+      (case convention
-         (safe-name string))))))
+        (:sql :c) (s/replace string #"[^a-zA-Z0-9_]" "_")
+        :c-sharp (s/replace (capitalise string) #"[^a-zA-Z0-9]" "")
+        :java (let
+                [camel (s/replace (capitalise string) #"[^a-zA-Z0-9]" "")]
+                (apply str (cons (Character/toLowerCase (first camel)) (rest camel))))
+        (safe-name string))))))
+
+
+(defmacro list-related-query-name
+  "Return the canonical name of the HugSQL query to return all records on
+  `farside` which match a given record on `nearside`, where `nearide` and
+  `farside` are both entities."
+  [nearside farside]
+  `(if
+     (and (entity? ~nearside) (entity? ~farside))
+     (str
+      "list-"
+      (safe-name ~farside :sql)
+      "-by-"
+      (singularise (safe-name ~nearside :sql)))
+     (do
+       (*warn* "Argument passed to `list-related-query-name` was a non-entity")
+       nil)))
 
 
 (defn property-for-field

test/adl_support/core_test.clj

@@ -52,7 +52,10 @@
       (is (= expected actual) "No exception thrown"))
     (let [expected {:error "java.lang.ArithmeticException: Divide by zero"}
           actual (do-or-return-reason (/ 1 0))]
-      (is (= expected actual) "Exception thrown"))))
+      (is (= expected actual) "Exception thrown"))
+    (let [expected {:error "Hello: java.lang.ArithmeticException: Divide by zero"}
+          actual (do-or-return-reason (/ 1 0) "Hello")]
+      (is (= expected actual) "Exception thrown, with intro"))))
 
 
 ;; These work in REPL, but break in tests. Why?

test/adl_support/forms_support_test.clj

@@ -0,0 +1,16 @@
+
+(ns adl-support.forms-support-test
+  (:require [clojure.test :refer :all]
+            [adl-support.forms-support :refer :all]))
+
+
+(deftest auxlist-data-name-test
+  (testing "auxlist-data-name"
+    (let [auxlist {:tag :auxlist,
+                   :attrs {:property "dwellings"},
+                   :content [{:tag :field,
+                              :attrs {:name "sub-address"},
+                              :content nil}]}
+          expected "auxlist-dwellings"
+          actual (auxlist-data-name auxlist)]
+      (is (= expected actual) "Just checking..."))))

test/adl_support/rest_support_test.clj

@@ -1,6 +1,6 @@
-(ns adl-support.core-test
+(ns adl-support.rest-support-test
   (:require [clojure.test :refer :all]
-            [adl-support.rest_support :refer :all]))
+            [adl-support.rest-support :refer :all]))
 
 
 (deftest if-valid-user-tests
@@ -19,7 +19,7 @@
           actual (valid-user-or-forbid "hello" {:session {:user {:id 4}}})]
       (is (= expected actual) "User in session"))
     (let [expected 403
-          actual (:status (valid-user-or-forbid "hello" {:session {:user {:id 4}}}))]
+          actual (:status (valid-user-or-forbid "hello" {:session {}}))]
       (is (= expected actual) "No user in session"))))
 
 

test/adl_support/utils_test.clj

@@ -1,5 +1,6 @@
 (ns adl-support.utils-test
   (:require [clojure.test :refer :all]
+            [adl-support.core :refer [*warn*]]
             [adl-support.utils :refer :all]))
 
 ;; Yes, there's MASSES in utils which ought to be tested. I'll add more tests over time.
@@ -304,3 +305,69 @@
           with appropriate property with prompt in current locale"))
     ))
 
+
+(deftest list-related-query-name-tests
+  (testing "list-related-query-name"
+    (let [e1 {:tag :entity,
+              :attrs {:volatility "6", :magnitude "1", :name "genders", :table "genders"},
+              :content [{:tag :documentation,
+                         :content ["All genders which may be assigned to\n    electors."]}
+                        {:tag :key, :attrs nil,
+                         :content [{:tag :property,
+                                    :attrs {:distinct "all", :size "32", :type "string", :name "id"},
+                                    :content [{:tag :prompt,
+                                               :attrs {:locale "en_GB.UTF-8",
+                                                       :prompt "Gender"},
+                                               :content nil}]}]}
+                        {:tag :list, :attrs {:name "Genders", :properties "all"}}
+                        {:tag :form, :attrs {:name "Gender", :properties "all"}}]}
+          e2 {:tag :entity,
+              :attrs {:volatility "6", :magnitude "1", :name "electors", :table "electors"},
+              :content [{:tag :documentation,
+                         :attrs nil,
+                         :content
+                         ["All electors known to the system; electors are
+                          people believed to be entitled to vote in the current
+                          campaign."]}
+                        {:tag :key,
+                         :attrs nil,
+                         :content
+                         [{:tag :property,
+                           :attrs
+                           {:distinct "system",
+                            :immutable "true",
+                            :column "id",
+                            :name "id",
+                            :type "integer",
+                            :required "true"},
+                           :content
+                           [{:tag :generator, :attrs {:action "native"}, :content nil}]}]}
+                        {:tag :property,
+                         :attrs
+                         {:distinct "user",
+                          :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
+                         {: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}]}]}
+          expected "list-electors-by-gender"
+          actual (list-related-query-name e1 e2)]
+      (is (= expected actual) "just checking..."))))
+
+