From ac070b537fba30f68fa835897bda8eb18913150e Mon Sep 17 00:00:00 2001
From: Simon Brooke <simon@journeyman.cc>
Date: Wed, 4 Jul 2018 22:29:33 +0100
Subject: [PATCH] Small improvements. More and more works.
---
src/adl/to_hugsql_queries.clj | 7 +--
src/adl/to_selmer_routes.clj | 66 ++++++++++++++++++---------
src/adl/to_selmer_templates.clj | 81 +++++++++++++++++----------------
3 files changed, 87 insertions(+), 67 deletions(-)
diff --git a/src/adl/to_hugsql_queries.clj b/src/adl/to_hugsql_queries.clj
index 3da9fd6..0dabffd 100644
--- a/src/adl/to_hugsql_queries.clj
+++ b/src/adl/to_hugsql_queries.clj
@@ -114,10 +114,6 @@
(defn update-query
"Generate an appropriate `update` query for this `entity`"
[entity]
- (if
- (and
- (has-primary-key? entity)
- (has-non-key-properties? entity))
(let [entity-name (safe-name (:name (:attrs entity)) :sql)
pretty-name (singularise entity-name)
property-names (map #(:name (:attrs %)) (insertable-properties entity))
@@ -136,8 +132,7 @@
"SET "
(s/join ",\n\t" (map #(str (safe-name % :sql) " = " (keyword %)) property-names))
"\n"
- (where-clause entity))}))
- {}))
+ (where-clause entity))})))
(defn search-query [entity application]
diff --git a/src/adl/to_selmer_routes.clj b/src/adl/to_selmer_routes.clj
index ed4fe70..e016a3f 100644
--- a/src/adl/to_selmer_routes.clj
+++ b/src/adl/to_selmer_routes.clj
@@ -182,28 +182,49 @@
(list
'l/render
(list 'support/resolve-template (str n ".html"))
- '(:session r)
- (merge
- {:title (capitalise (:name (:attrs f)))
- :params 'p}
- (case (:tag f)
- (:form :page)
- (reduce
- merge
- {:record
- (list 'if (list 'empty? (list 'remove 'nil? (list 'vals 'p))) []
- (list
- (symbol
- (str "db/get-" (singularise (:name (:attrs e)))))
- (symbol "db/*db*")
- 'p))}
- (map
- (fn [p]
- (hash-map
- (keyword (-> p :attrs :entity))
- (list (symbol (str "db/list-" (:entity (:attrs p)))) (symbol "db/*db*"))))
- (filter #(#{"entity" "link"} (:type (:attrs %)))
- (descendants-with-tag e :property))))
+ (list :session 'r)
+ (list 'merge
+ {:title (capitalise (:name (:attrs f)))
+ :params 'p}
+ (case (:tag f)
+ (:form :page)
+ (list
+ 'reduce
+ 'merge
+ (list 'merge
+ (list 'cond (list :save-button 'p)
+ (list 'try
+ (list 'if
+ (list 'some (key-names e) (list 'map 'name (list 'keys 'p)))
+ (list 'do
+ (list (symbol
+ (str "db/update-" (singularise (-> e :attrs :name)) "!"))
+ 'db/*db*
+ 'p)
+ {:message "Updated record"})
+ (list 'do
+ (list (symbol
+ (str "db/create-" (singularise (-> e :attrs :name)) "!"))
+ 'db/*db*
+ 'p)
+ {:message "Saved record"}))
+ `(catch Exception any#
+ {:error (.getMessage any#)})))
+ {:record
+ (list 'if (list 'empty? (list 'remove 'nil? (list 'vals 'p))) []
+ (list
+ (symbol
+ (str "db/get-" (singularise (:name (:attrs e)))))
+ (symbol "db/*db*")
+ 'p))})
+ (cons 'list
+ (map
+ (fn [p]
+ (hash-map
+ (keyword (-> p :attrs :entity))
+ (list (symbol (str "db/list-" (:entity (:attrs p)))) (symbol "db/*db*"))))
+ (filter #(#{"entity" "link"} (:type (:attrs %)))
+ (descendants-with-tag e :property)))))
:list
{:records
(list
@@ -231,6 +252,7 @@
;; (def e (child-with-tag a :entity))
;; (def f (child-with-tag e :form))
;; (def n (path-part f e a))
+;; (make-handler f e a)
;; (vector
;; 'p
;; (list 'merge
diff --git a/src/adl/to_selmer_templates.clj b/src/adl/to_selmer_templates.clj
index 011aad2..bd2b89d 100644
--- a/src/adl/to_selmer_templates.clj
+++ b/src/adl/to_selmer_templates.clj
@@ -114,7 +114,6 @@
"\n"
(flatten
(list
- "{% endblock %}"
(emit-content filename spec entity application :foot))))))
@@ -238,38 +237,42 @@
magnitude (try (read-string (:magnitude (:attrs farside))) (catch Exception _ 7))
async? (and (number? magnitude) (> magnitude 1))
widget-name (safe-name (:name (:attrs property)) :sql)]
- {:tag :div
+ {:tag :span
:attrs {:class "select-box" :farside farname :found (if farside "true" "false")}
:content
(apply
vector
(remove
nil?
- (list
- (if
- async?
- {:tag :input
- :attrs
- {:name (str widget-name "_search_box")
- :onchange (str "$.getJSON(\"/auto/json/seach-strings-" (-> farside :attrs :name)
- "?"
- (s/join (str "=\" + " widget-name "_search_box.text + \"&")
- (user-distinct-property-names farside))
- (str "=\" + " widget-name "_search_box.text")
- ", null, function (data) {updateMenuOptions(\""
- widget-name "\", \""
- (first (key-names farside))
- "\", [\""
- (s/join "\", \"" (user-distinct-property-names farside))
- "\"], data);})")}})
- {:tag :select
- :attrs (merge
- {:id widget-name
- :name widget-name}
- (if
- (= (:type (:attrs property)) "link")
- {:multiple "multiple"}))
- :content (apply vector (get-options property form entity application))})))}))
+ (flatten
+ (list
+ (if
+ async?
+ (list
+ {:tag :input
+ :attrs
+ {:name (str widget-name "_search_box")
+ :onchange (str "$.getJSON(\"/auto/json/seach-strings-"
+ (-> farside :attrs :name)
+ "?"
+ (s/join (str "=\" + " widget-name "_search_box.text + \"&")
+ (user-distinct-property-names farside))
+ (str "=\" + " widget-name "_search_box.text")
+ ", null, function (data) {updateMenuOptions(\""
+ widget-name "\", \""
+ (first (key-names farside))
+ "\", [\""
+ (s/join "\", \"" (user-distinct-property-names farside))
+ "\"], data);})")}}
+ {:tag :br}))
+ {:tag :select
+ :attrs (merge
+ {:id widget-name
+ :name widget-name}
+ (if
+ (= (:type (:attrs property)) "link")
+ {:multiple "multiple"}))
+ :content (apply vector (get-options property form entity application))}))))}))
(defn compose-if-member-of-tag
@@ -378,11 +381,9 @@
(defn compose-select-script-header [entity application]
- ["{% block extra-head %}"
- {:tag :script :attrs {:type "text/javascript"}
+ {:tag :script :attrs {:type "text/javascript"}
:content
- [(slurp "resources/js/select-widget-support.js")]}
- "{% endblock %}"])
+ [(slurp "resources/js/select-widget-support.js")]})
(defn form-to-template
@@ -417,7 +418,7 @@
(delete-widget form entity application)))}]}}
(if
(some #(= "select" (widget-type % application)) (properties entity))
- {:header (compose-select-script-header entity application)}
+ {:extra-head (compose-select-script-header entity application)}
{})))
@@ -467,13 +468,15 @@
:content
[{:tag :tr
:content
- (apply
- vector
- (map
- #(hash-map
- :content [(prompt %)]
- :tag :th)
- (children-with-tag list-spec :field)))}
+ (conj
+ (apply
+ vector
+ (map
+ #(hash-map
+ :content [(prompt %)]
+ :tag :th)
+ (children-with-tag list-spec :field)))
+ {:tag :th :content [" "]})}
{:tag :tr
:content
(apply