From 7d629768808903be45c426af9114e97e0c7e0201 Mon Sep 17 00:00:00 2001
From: Simon Brooke <simon@journeyman.cc>
Date: Sat, 7 Jul 2018 09:06:13 +0100
Subject: [PATCH] Allow for multiple distinct links between the same two
 entities.

---
 src/adl/to_hugsql_queries.clj   |  2 +-
 src/adl/to_json_routes.clj      | 40 ++++++++++++++++++++-------------
 src/adl/to_psql.clj             |  2 +-
 src/adl/to_selmer_templates.clj | 19 ++++++++--------
 4 files changed, 37 insertions(+), 26 deletions(-)

diff --git a/src/adl/to_hugsql_queries.clj b/src/adl/to_hugsql_queries.clj
index 0dabffd..2387610 100644
--- a/src/adl/to_hugsql_queries.clj
+++ b/src/adl/to_hugsql_queries.clj
@@ -306,7 +306,7 @@
                                     "\n\tAND " entity-name "." link-field " = :id")
                                (order-by-clause entity "lv_"))
                     "link" (let [link-table-name
-                                 (link-table-name entity far-entity)]
+                                 (link-table-name % entity far-entity)]
                              (list
                                (str "-- :name " query-name " " signature)
                                (str "-- :doc links all existing " pretty-name " records related to a given " pretty-far)
diff --git a/src/adl/to_json_routes.clj b/src/adl/to_json_routes.clj
index 87f8677..5d59257 100644
--- a/src/adl/to_json_routes.clj
+++ b/src/adl/to_json_routes.clj
@@ -37,6 +37,12 @@
 ;;; to-hugsql-queries, because essentially we need one JSON entry point to wrap
 ;;; each query.
 
+;;; TODO: memoisation of handlers probably doesn't make sense, because every request
+;;; will be different. I don't think we can memoise HugSQL, at least not without
+;;; hacking the library (might be worth doing that and contributing a patch).
+;;; So the solution may be to an intervening namespace 'cache', which has one
+;;; memoised function for each hugsql query.
+
 (defn file-header [application]
   (list
     'ns
@@ -65,21 +71,25 @@
 (defn generate-handler-body
   "Generate and return the function body for the handler for this `query`."
   [query]
-  (list
-    [{:keys ['params 'form-params]}]
-    (list 'let
-          (vector
-            'result
-            (list
-              (symbol (str "db/" (:name query)))
-              'db/*db*
-              (list 'support/massage-params
-                    'params 'form-params (key-names (:entity query)))))
-          (case
-            (:type query)
-            (:delete-1 :update-1)
-            '(response/found "/")
-            (list 'response/ok 'result)))))
+  (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]}]
+     (case
+       (:type query)
+       (:delete-1 :update-1)
+       (list
+         action
+         '(response/found "/"))
+       (list
+         'let
+         (vector 'result action)
+         (list 'response/ok 'result))))))
 
 
 (defn generate-handler-src
diff --git a/src/adl/to_psql.clj b/src/adl/to_psql.clj
index f7aea86..2734198 100644
--- a/src/adl/to_psql.clj
+++ b/src/adl/to_psql.clj
@@ -461,7 +461,7 @@
              #(and
                 (entity? %)
                 (= (:name (:attrs %)) (:entity (:attrs property)))))
-        link-table-name (link-table-name e1 e2)]
+        link-table-name (link-table-name property e1 e2)]
     (if
       ;; we haven't already emitted this one...
       (not (@emitted-link-tables link-table-name))
diff --git a/src/adl/to_selmer_templates.clj b/src/adl/to_selmer_templates.clj
index 77460f1..3e6767c 100644
--- a/src/adl/to_selmer_templates.clj
+++ b/src/adl/to_selmer_templates.clj
@@ -146,15 +146,16 @@
   ([field-or-property form entity application]
    (prompt field-or-property))
   ([field-or-property]
-   (or
-     (first
-       (children
-         field-or-property
-         #(and
-            (= (:tag %) :prompt)
-            (= (:locale :attrs %) *locale*))))
-     (:name (:attrs field-or-property))
-     (:property (:attrs field-or-property)))))
+   (capitalise
+     (or
+       (first
+         (children
+           field-or-property
+           #(and
+              (= (:tag %) :prompt)
+              (= (:locale :attrs %) *locale*))))
+       (:name (:attrs field-or-property))
+       (:property (:attrs field-or-property))))))
 
 
 (defn csrf-widget