From ab44e355f65e5cb90c853961f113c57dcaa0c605 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sat, 22 Sep 2018 09:22:39 +0100 Subject: [PATCH 1/8] lein-release plugin: bumped version from 0.1.5 to 0.1.6-SNAPSHOT for next development cycle --- project.clj | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/project.clj b/project.clj index 118b206..34a7dc4 100644 --- a/project.clj +++ b/project.clj @@ -1,4 +1,4 @@ -(defproject adl-support "0.1.5" +(defproject adl-support "0.1.6-SNAPSHOT" :description "A small library of functions called by generated ADL code." :url "https://github.com/simon-brooke/adl-support" :license {:name "MIT License" From 3baa7c12a503efeee9e4d19e6ad9ca0fcd6242ea Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 30 Sep 2018 14:38:57 +0100 Subject: [PATCH 2/8] Order-preserving-set --- src/adl_support/rest_support.clj | 14 +++++--------- src/adl_support/utils.clj | 14 ++++++++++++++ test/adl_support/utils_test.clj | 6 ++++++ 3 files changed, 25 insertions(+), 9 deletions(-) diff --git a/src/adl_support/rest_support.clj b/src/adl_support/rest_support.clj index 56c1ade..8f6cafa 100644 --- a/src/adl_support/rest_support.clj +++ b/src/adl_support/rest_support.clj @@ -46,10 +46,10 @@ ;; TODO: candidate for moving to adl-support.core [form request] `(if-valid-user - ~form - ~request - {:status 403 - :body (json/write-str "You must be logged in to do that")})) + ~form + ~request + {:status 403 + :body (json/write-str "You must be logged in to do that")})) (defmacro with-params-or-error @@ -64,9 +64,6 @@ :body (json/write-str (str "The following params are required: " ~required))})) -;; (with-params-or-error (/ 1 0) {:a 1 :b 2} #{:a :b :c}) -;; (with-params-or-error "hello" {:a 1 :b 2} #{:a :b }) - (defmacro do-or-server-fail "Evaluate this `form`; if it succeeds, return an HTTP response with this status code and the JSON-formatted result as body; if it fails, return an @@ -78,6 +75,5 @@ {:status ~status :body (:result r#)} {:status 500 - :body r#}))) - + :body r#}))) diff --git a/src/adl_support/utils.clj b/src/adl_support/utils.clj index b22cbf1..2d1b8d2 100644 --- a/src/adl_support/utils.clj +++ b/src/adl_support/utils.clj @@ -658,3 +658,17 @@ 0 (expt 10 v))) (catch Exception _ 0))) + + +(defn order-preserving-set + "The Clojure `set` function does not preserve the order in which elements are + passed to it. This function is like `set`, except + 1. It returns a list, not a hashset, and + 2. It is order-preserving." + [collection] + (loop [lhs (list (first collection)) + rhs (rest collection)] + (cond + (empty? rhs) (reverse lhs) + (some #(= (first rhs) %) lhs) (recur lhs (rest rhs)) + true (recur (cons (first rhs) lhs) (rest rhs))))) diff --git a/test/adl_support/utils_test.clj b/test/adl_support/utils_test.clj index 4499eb7..5132672 100644 --- a/test/adl_support/utils_test.clj +++ b/test/adl_support/utils_test.clj @@ -598,3 +598,9 @@ (is (= (key-names e2) #{"id" "shard"})) (is (= (key-names e2 true) #{:id :shard}))))) + +(deftest order-preserving-set-tests + (testing "order-preserving-set" + (is (= '(:a) (order-preserving-set '(:a :a :a :a)))) + (is (= '(:a) (order-preserving-set [:a :a :a :a]))) + (is (= '(:a :b :c :d :e) (order-preserving-set '(:a :a :b :c :a :b :d :c :e)))))) From 7191d6afe153538fcf166a5e5c1a0157ada48ad7 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Tue, 2 Oct 2018 18:36:01 +0100 Subject: [PATCH 3/8] Support for better form titles --- src/adl_support/forms_support.clj | 22 ++++++++++++++++++++-- 1 file changed, 20 insertions(+), 2 deletions(-) diff --git a/src/adl_support/forms_support.clj b/src/adl_support/forms_support.clj index 101f577..81dacff 100644 --- a/src/adl_support/forms_support.clj +++ b/src/adl_support/forms_support.clj @@ -3,11 +3,11 @@ :author "Simon Brooke"} adl-support.forms-support (:require [adl-support.core :refer :all] - [adl-support.utils :refer [descendants-with-tag safe-name singularise]] + [adl-support.utils :refer [capitalise descendants-with-tag safe-name singularise]] [clojure.core.memoize :as memo] [clojure.data.json :as json] [clojure.java.io :as io] - [clojure.string :refer [lower-case]])) + [clojure.string :refer [join lower-case]])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; @@ -122,3 +122,21 @@ (map #(hash-map (keyword (-> % :attrs :name)) (-> % :attrs :default)) (descendants-with-tag entity :property #(-> % :attrs :default))))) + + +(defn form-title + "Construct an appropriate title for a form having this `form-name`, for an + entity having these `user-distinct-property-keys`, given this `record`." + [record form-name user-distinct-property-keys] + (str + form-name + ": " + (join + ", " + (remove + nil? + (map + record + user-distinct-property-keys))))) + + From 12cd3a361f105cd1595933efbae633aef4d71893 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 3 Oct 2018 12:58:47 +0100 Subject: [PATCH 4/8] Added `entity-by-name` --- src/adl_support/utils.clj | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/src/adl_support/utils.clj b/src/adl_support/utils.clj index 2d1b8d2..8f8ac6b 100644 --- a/src/adl_support/utils.clj +++ b/src/adl_support/utils.clj @@ -672,3 +672,14 @@ (empty? rhs) (reverse lhs) (some #(= (first rhs) %) lhs) (recur lhs (rest rhs)) true (recur (cons (first rhs) lhs) (rest rhs))))) + + +(defmacro entity-by-name + "Return the entity with this `entity-name` in this `application`. + TODO: Candidate for move to adl-support.utils." + [entity-name application] + `(child-with-tag + ~application + :entity + #(= (:name (:attrs %)) ~entity-name))) + From 3c8a16aa4f2418f85155f317ac5d648d331f173b Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 4 Oct 2018 18:06:49 +0100 Subject: [PATCH 5/8] Added tests for containment; work on menus. --- src/adl_support/filters.clj | 24 ++++++++++- src/adl_support/tags.clj | 40 +++++++++++++++++- src/adl_support/utils.clj | 45 ++++++--------------- test/adl_support/tags_test.clj | 74 +++++++++++++++++++++++++++++++++- 4 files changed, 147 insertions(+), 36 deletions(-) diff --git a/src/adl_support/filters.clj b/src/adl_support/filters.clj index 7c31b55..262aefb 100644 --- a/src/adl_support/filters.clj +++ b/src/adl_support/filters.clj @@ -4,7 +4,8 @@ adl-support.filters (:require [clojure.string :as s] [selmer.filters :as f] - [selmer.parser :as p])) + [selmer.parser :as p] + [selmer.tags :as t])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; @@ -64,3 +65,24 @@ (f/add-filter! :email email) ;; (p/render "{{p|telephone}}" {:p "07768 130255"}) + +(defn contains + [collection value] + (first + (filter + #(= % value) + collection))) + +;; (contains '(:a :b :c) :a) + +(f/add-filter! :contains contains) + +;; (p/render "{{l|contains:\"foo\"}}" {:l ["froboz" "bar"]}) + +;; (p/render "{% if l|contains:\"foo\" %}I see ya!{% else %}I don't{% endif %}" {:l ["foo" "bar"]}) +;; (p/render "{% if l|contains:\"foo\" %}I see ya!{% else %}I don't{% endif %}" {:l ["froboz" "bar"]}) + +;; (p/render +;; "" +;; {:option {:id 2 :name "Fred"} :record {:roles [2 6]}}) + diff --git a/src/adl_support/tags.clj b/src/adl_support/tags.clj index c808500..d592937 100644 --- a/src/adl_support/tags.clj +++ b/src/adl_support/tags.clj @@ -2,7 +2,9 @@ in generated templates." :author "Simon Brooke"} adl-support.tags - (:require [selmer.parser :as p])) + (:require [clojure.string :refer [split]] + [selmer.parser :as p] + [selmer.tags :as t])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; @@ -32,6 +34,22 @@ success failure)) + +(defn parse-arg + [arg context] + (cond + (number? arg) + arg + (number? (read-string arg)) + (read-string arg) + (= \" (first arg)) + (.substring arg 1 (dec (.length arg))) + (and (= \: (first arg)) (> (count arg) 1)) + (keyword (subs arg 1)) + :else + (get-in context (map keyword (split arg #"\."))))) + + (defn add-tags [] "Add custom tags required by ADL-generated code to the parser's tags." (p/add-tag! :ifmemberof @@ -43,6 +61,24 @@ :else (fn [args context content] "") - :endifmemberof)) + :endifmemberof) + (p/add-tag! :ifcontains + (fn [[c v] context content] + (let [value (parse-arg v context) + collection (parse-arg c context)] + (if + (some + #(= % value) + collection) + (get-in content [:ifcontains :content]) + (get-in content [:else :content])))) + :else + (fn [args context content] + "") + :endifcontains)) + (add-tags) + + + diff --git a/src/adl_support/utils.clj b/src/adl_support/utils.clj index 8f8ac6b..5d26e19 100644 --- a/src/adl_support/utils.clj +++ b/src/adl_support/utils.clj @@ -322,22 +322,6 @@ (= (max n1 n2) 1))) -(defn link-related-query-name - "link is tricky. If there's exactly than one link between the two - entities, we need to generate the same name from both - ends of the link" - [property nearside farside] - (if (unique-link? nearside farside) - (let [ordered (sort-by #(-> % :attrs :name) (list nearside farside))] - (str "list-" - (safe-name (first ordered) :sql) - "-by-" - (safe-name (nth ordered 1) :sql))) - (str "list-" - (safe-name property :sql) "-by-" - (singularise (safe-name nearside :sql))))) - - (defn link-table-name "Canonical name of a link table between entity `e1` and entity `e2`. However, there may be different links between the same two tables with different semantics; if @@ -364,25 +348,22 @@ `farside` are both entities." [property nearside farside] (if - (and + (and (property? property) (entity? nearside) (entity? farside)) - (case (-> property :attrs :type) - "link" (link-related-query-name property nearside farside) - "list" (str "list-" - (safe-name farside :sql) "-by-" - (singularise (safe-name nearside :sql))) - "entity" (str "list-" - (safe-name nearside :sql) "-by-" - (singularise (safe-name farside :sql))) - ;; default - (str "ERROR-bad-property-type-" - (-> ~property :attrs :type) "-of-" - (-> ~property :attrs :name))) - (do - (*warn* "Argument passed to `list-related-query-name` was a non-entity") - nil))) + (case (-> property :attrs :type) + ("link" "list") (str "list-" + (safe-name farside :sql) "-by-" + (singularise (safe-name nearside :sql))) + "entity" (str "get-" (singularise (safe-name farside :sql))) + ;; default + (str "ERROR-bad-property-type-" + (-> ~property :attrs :type) "-of-" + (-> ~property :attrs :name))) + (do + (*warn* "Argument passed to `list-related-query-name` was a non-entity") + nil))) (defn property-for-field diff --git a/test/adl_support/tags_test.clj b/test/adl_support/tags_test.clj index 578deed..356d2a3 100644 --- a/test/adl_support/tags_test.clj +++ b/test/adl_support/tags_test.clj @@ -6,7 +6,7 @@ (add-tags) (deftest if-member-of-tests - (testing "testing the if-member-of tag" + (testing "the `ifmemberof` tag" (let [expected "boo" actual (if-member-of-permitted nil nil "caramba" "boo")] (is (= expected actual) "Nil args, nil ")) @@ -48,3 +48,75 @@ +(deftest if-contains-tests + (testing "the `ifcontains` tag" + (let [expected "Hello!" + actual (parser/render "{% ifcontains record.roles option.id %}Hello!{% else %}Goodbye!{% endifcontains %}" + {:option {:id 2 :name "Fred"} :record {:roles [2 6]}})] + (is (= expected actual) + "Both args are paths which exist in the context; + the value of the first contains the value of the second; + values are numbers")) + (let [expected "Goodbye!" + actual (parser/render "{% ifcontains record.roles option.id %}Hello!{% else %}Goodbye!{% endifcontains %}" + {:option {:id 3 :name "Ginny"} :record {:roles [2 6]}})] + (is (= expected actual) + "Both args are paths which exist in the context; + the value of the first does not contain the value of the second; + values are numbers")) + (let [expected "Hello!" + actual (parser/render "{% ifcontains record.roles option.id %}Hello!{% else %}Goodbye!{% endifcontains %}" + {:option {:id :two :name "Fred"} :record {:roles [:two :six]}})] + (is (= expected actual) + "Both args are paths which exist in the context; + the value of the first contains the value of the second; + values are keywords")) + (let [expected "Goodbye!" + actual (parser/render "{% ifcontains record.roles option.id %}Hello!{% else %}Goodbye!{% endifcontains %}" + {:option {:id :three :name "Ginny"} :record {:roles [:two :six]}})] + (is (= expected actual) + "Both args are paths which exist in the context; + the value of the first does not contain the value of the second; + values are keywords")) + (let [expected "Hello!" + actual (parser/render "{% ifcontains record.roles option.id %}Hello!{% else %}Goodbye!{% endifcontains %}" + {:option {:id "two" :name "Fred"} :record {:roles ["two" "six"]}})] + (is (= expected actual) + "Both args are paths which exist in the context; + the value of the first contains the value of the second; + values are strings")) + (let [expected "Goodbye!" + actual (parser/render "{% ifcontains record.roles option.id %}Hello!{% else %}Goodbye!{% endifcontains %}" + {:option {:id "three" :name "Ginny"} :record {:roles ["two" "six"]}})] + (is (= expected actual) + "Both args are paths which exist in the context; + the value of the first does not contain the value of the second; + values are strings")) + (let [expected "Hello!" + actual (parser/render "{% ifcontains record.roles 2 %}Hello!{% else %}Goodbye!{% endifcontains %}" + {:option {:id 4 :name "Henry"} :record {:roles [2 6]}})] + (is (= expected actual) + "First arg is a path which exists in the context, second is a literal number; + the value of the first contains the value of the second; + values are numbers")) + (let [expected "Goodbye!" + actual (parser/render "{% ifcontains record.roles 3 %}Hello!{% else %}Goodbye!{% endifcontains %}" + {:option {:id 3 :name "Ginny"} :record {:roles [2 6]}})] + (is (= expected actual) + "First arg is a path which exists in the context, second is a literal number; + the value of the first does not contain the value of the second; + values are numbers")) + (let [expected "Hello!" + actual (parser/render "{% ifcontains record.roles :two %}Hello!{% else %}Goodbye!{% endifcontains %}" + {:option {:id 4 :name "Henry"} :record {:roles [:two :six]}})] + (is (= expected actual) + "First arg is a path which exists in the context, second is a literal keyword; + the value of the first contains the value of the second; + values are numbers")) + (let [expected "Goodbye!" + actual (parser/render "{% ifcontains record.roles :three %}Hello!{% else %}Goodbye!{% endifcontains %}" + {:option {:id 3 :name "Ginny"} :record {:roles [:two :six]}})] + (is (= expected actual) + "First arg is a path which exists in the context, second is a literal keyword; + the value of the first does not contain the value of the second; + values are numbers")))) From 7d76a151c1b1954254b30df40ba27fb13b574db8 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 4 Oct 2018 19:14:09 +0100 Subject: [PATCH 6/8] Work on multi-select menus. --- src/adl_support/utils.clj | 42 ++++++++++++++++++++++++--------------- 1 file changed, 26 insertions(+), 16 deletions(-) diff --git a/src/adl_support/utils.clj b/src/adl_support/utils.clj index 5d26e19..27aaf63 100644 --- a/src/adl_support/utils.clj +++ b/src/adl_support/utils.clj @@ -346,24 +346,34 @@ "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." - [property nearside farside] - (if - (and - (property? property) - (entity? nearside) - (entity? farside)) - (case (-> property :attrs :type) - ("link" "list") (str "list-" + ([property nearside farside as-symbol?] + (let [n (case (-> property :attrs :type) + ;; TODO: I am deeply susicious of this. It's just improbable that + ;; the same recipe should work for all three cases. + ("link" "list") (str "list-" + (safe-name farside :sql) "-by-" + (singularise (safe-name nearside :sql))) + "entity" (str "list-" (safe-name farside :sql) "-by-" (singularise (safe-name nearside :sql))) - "entity" (str "get-" (singularise (safe-name farside :sql))) - ;; default - (str "ERROR-bad-property-type-" - (-> ~property :attrs :type) "-of-" - (-> ~property :attrs :name))) - (do - (*warn* "Argument passed to `list-related-query-name` was a non-entity") - nil))) + ;; default + (str "ERROR-bad-property-type-" + (-> ~property :attrs :type) "-of-" + (-> ~property :attrs :name)))] + (if + (and + (property? property) + (entity? nearside) + (entity? farside)) + (if + as-symbol? + (symbol (str "db/" n)) + n) + (do + (*warn* "Argument passed to `list-related-query-name` was a non-entity") + nil)))) + ([property nearside farside] + (list-related-query-name property nearside farside false))) (defn property-for-field From 98122c2080af52e445a68d6a756465ce441c6c2b Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 4 Oct 2018 22:52:23 +0100 Subject: [PATCH 7/8] Work on auxlists --- src/adl_support/forms_support.clj | 2 +- src/adl_support/utils.clj | 73 +++++++++++++++++-------------- 2 files changed, 40 insertions(+), 35 deletions(-) diff --git a/src/adl_support/forms_support.clj b/src/adl_support/forms_support.clj index 81dacff..7ff50c6 100644 --- a/src/adl_support/forms_support.clj +++ b/src/adl_support/forms_support.clj @@ -92,7 +92,7 @@ "The name to which data for this `auxlist` will be bound in the Selmer params." [auxlist] - `(safe-name (str "auxlist-" (-> ~auxlist :attrs :property)) :clojure)) + `(safe-name (-> ~auxlist :attrs :property) :clojure)) (defmacro all-keys-present? diff --git a/src/adl_support/utils.clj b/src/adl_support/utils.clj index 27aaf63..e840e1a 100644 --- a/src/adl_support/utils.clj +++ b/src/adl_support/utils.clj @@ -342,40 +342,6 @@ "_" (cons "ln" (map #(:name (:attrs %)) (list property e1))))))) -(defn 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." - ([property nearside farside as-symbol?] - (let [n (case (-> property :attrs :type) - ;; TODO: I am deeply susicious of this. It's just improbable that - ;; the same recipe should work for all three cases. - ("link" "list") (str "list-" - (safe-name farside :sql) "-by-" - (singularise (safe-name nearside :sql))) - "entity" (str "list-" - (safe-name farside :sql) "-by-" - (singularise (safe-name nearside :sql))) - ;; default - (str "ERROR-bad-property-type-" - (-> ~property :attrs :type) "-of-" - (-> ~property :attrs :name)))] - (if - (and - (property? property) - (entity? nearside) - (entity? farside)) - (if - as-symbol? - (symbol (str "db/" n)) - n) - (do - (*warn* "Argument passed to `list-related-query-name` was a non-entity") - nil)))) - ([property nearside farside] - (list-related-query-name property nearside farside false))) - - (defn property-for-field "Return the property within this `entity` which matches this `field`." [field entity] @@ -609,6 +575,45 @@ #(#{"system" "all"} (:distinct (:attrs %))) (properties entity))) + +(defn 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." + ([property nearside farside as-symbol?] + (let [unique? (= + (count + (filter + #(= (-> % :attrs :entity)(-> property :attrs :entity)) + (descendants-with-tag nearside :property))) + 1) + farname (if unique? (safe-name farside :sql) (safe-name property :sql)) + nearname (singularise (safe-name nearside :sql)) + n (case (-> property :attrs :type) + ;; TODO: I am deeply susicious of this. It's just improbable that + ;; the same recipe should work for all three cases. + ("link" "list") (str "list-" farname "-by-" nearname) + "entity" (str "list-" farname "-by-" nearname) + ;; default + (str "ERROR-bad-property-type-" + (-> ~property :attrs :type) "-of-" + (-> ~property :attrs :name)))] + (if + (and + (property? property) + (entity? nearside) + (entity? farside)) + (if + as-symbol? + (symbol (str "db/" n)) + n) + (do + (*warn* "Argument passed to `list-related-query-name` was a non-entity") + nil)))) + ([property nearside farside] + (list-related-query-name property nearside farside false))) + + (defn path-part "Return the URL path part for this `form` of this `entity` within this `application`. Note that `form` may be a Clojure XML representation of a `form`, `list` or `page` From aa62040555f9aba076fb1d7ef3f87a738d6ea306 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 2 May 2019 15:42:22 +0100 Subject: [PATCH 8/8] lein-release plugin: preparing 0.1.6 release --- project.clj | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/project.clj b/project.clj index 34a7dc4..9a33b0a 100644 --- a/project.clj +++ b/project.clj @@ -1,4 +1,4 @@ -(defproject adl-support "0.1.6-SNAPSHOT" +(defproject adl-support "0.1.6" :description "A small library of functions called by generated ADL code." :url "https://github.com/simon-brooke/adl-support" :license {:name "MIT License"