simon/adl
1
0
Fork 0
Code Issues Pull requests Actions Packages Projects Releases Wiki Activity

Merge branch 'feature/3' into develop

Browse source
This commit is contained in:
Simon Brooke 2018-08-05 17:19:59 +01:00
parent 6ba1ad60c9 f0eb2a7d18
commit c1d1bf59e8
4 changed files with 410 additions and 230 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

70
src/adl/to_hugsql_queries.clj
View file

@ -44,14 +44,16 @@
(where-clause entity (key-properties entity))) (where-clause entity (key-properties entity)))
([entity properties] ([entity properties]
(let (let
[entity-name (:name (:attrs entity)) [entity-name (safe-name entity :sql)
property-names (map #(:name (:attrs %)) properties)] property-names (map #(:name (:attrs %)) properties)]
(if-not (empty? property-names) (if-not (empty? property-names)
(str (str
"WHERE " "WHERE "
(s/join (s/join
"\n\tAND" "\n\tAND"
(map #(str entity-name "." % " = :" %) property-names))))))) (map
#(str entity-name "." (safe-name % :sql) " = :" %)
property-names)))))))
(defn order-by-clause (defn order-by-clause
@ -62,7 +64,7 @@
(order-by-clause entity prefix false)) (order-by-clause entity prefix false))
([entity prefix expanded?] ([entity prefix expanded?]
(let (let
[entity-name (safe-name (:name (:attrs entity)) :sql) [entity-name (safe-name entity :sql)
preferred (filter #(#{"user" "all"} (-> % :attrs :distinct)) preferred (filter #(#{"user" "all"} (-> % :attrs :distinct))
(children entity #(= (:tag %) :property)))] (children entity #(= (:tag %) :property)))]
(if (if
@ -89,10 +91,10 @@
TODO: this depends on the idea that system-unique properties TODO: this depends on the idea that system-unique properties
are not insertable, which is... dodgy." are not insertable, which is... dodgy."
[entity] [entity]
(let [entity-name (safe-name (:name (:attrs entity)) :sql) (let [entity-name (safe-name entity :sql)
pretty-name (singularise entity-name) pretty-name (singularise entity-name)
insertable-property-names (map insertable-property-names (map
#(safe-name (:name (:attrs %)) :sql) #(safe-name % :sql)
(insertable-properties entity)) (insertable-properties entity))
query-name (str "create-" pretty-name "!") query-name (str "create-" pretty-name "!")
signature (if (has-primary-key? entity) signature (if (has-primary-key? entity)
@ -126,9 +128,11 @@
(defn update-query (defn update-query
"Generate an appropriate `update` query for this `entity`" "Generate an appropriate `update` query for this `entity`"
[entity] [entity]
(let [entity-name (safe-name (:name (:attrs entity)) :sql) (let [entity-name (safe-name entity :sql)
pretty-name (singularise entity-name) pretty-name (singularise entity-name)
property-names (map #(:name (:attrs %)) (insertable-properties entity)) property-names (map
#(-> % :attrs :name)
(insertable-properties entity))
query-name (str "update-" pretty-name "!") query-name (str "update-" pretty-name "!")
signature ":! :n"] signature ":! :n"]
(hash-map (hash-map
@ -142,18 +146,22 @@
"-- :doc updates an existing " pretty-name " record\n" "-- :doc updates an existing " pretty-name " record\n"
"UPDATE " entity-name "\n" "UPDATE " entity-name "\n"
"SET " "SET "
(s/join ",\n\t" (map #(str (safe-name % :sql) " = " (keyword %)) property-names)) (s/join
",\n\t"
(map
#(str (safe-name % :sql) " = " (keyword %))
property-names))
"\n" "\n"
(where-clause entity))}))) (where-clause entity))})))
(defn search-query [entity application] (defn search-query [entity application]
"Generate an appropriate search query for string fields of this `entity`" "Generate an appropriate search query for string fields of this `entity`"
(let [entity-name (safe-name (:name (:attrs entity)) :sql) (let [entity-name (safe-name entity :sql)
pretty-name (singularise entity-name) pretty-name (singularise entity-name)
query-name (str "search-strings-" entity-name) query-name (str "search-strings-" entity-name)
signature ":? :*" signature ":? :*"
properties (remove #(#{"link"}(:type (:attrs %))) (all-properties entity))] properties (remove #(#{"(safe-name entity :sql)"}(:type (:attrs %))) (all-properties entity))]
(hash-map (hash-map
(keyword query-name) (keyword query-name)
{:name query-name {:name query-name
@ -180,7 +188,7 @@
string? string?
(map (map
#(let #(let
[sn (safe-name (-> % :attrs :name) :sql)] [sn (safe-name % :sql)]
(str (str
"(if (:" (-> % :attrs :name) " params) (str \"AND " "(if (:" (-> % :attrs :name) " params) (str \"AND "
(case (-> % :attrs :type) (case (-> % :attrs :type)
@ -214,7 +222,7 @@
([entity properties] ([entity properties]
(if-not (if-not
(empty? properties) (empty? properties)
(let [entity-name (safe-name (:name (:attrs entity)) :sql) (let [entity-name (safe-name entity :sql)
pretty-name (singularise entity-name) pretty-name (singularise entity-name)
query-name (if (= properties (key-properties entity)) query-name (if (= properties (key-properties entity))
(str "get-" pretty-name) (str "get-" pretty-name)
@ -254,7 +262,7 @@
Parameters `:limit` and `:offset` may be supplied. If not present limit defaults Parameters `:limit` and `:offset` may be supplied. If not present limit defaults
to 100 and offset to 0." to 100 and offset to 0."
[entity] [entity]
(let [entity-name (safe-name (:name (:attrs entity)) :sql) (let [entity-name (safe-name entity :sql)
pretty-name (singularise entity-name) pretty-name (singularise entity-name)
query-name (str "list-" entity-name) query-name (str "list-" entity-name)
signature ":? :*"] signature ":? :*"]
@ -282,7 +290,8 @@
[entity application] [entity application]
(let [entity-name (:name (:attrs entity)) (let [entity-name (:name (:attrs entity))
pretty-name (singularise entity-name) pretty-name (singularise entity-name)
links (filter #(#{"link" "entity"} (:type (:attrs %))) (children-with-tag entity :property))] entity-safe (safe-name entity :sql)
links (filter #(#{"list" "link" "entity"} (:type (:attrs %))) (children-with-tag entity :property))]
(apply (apply
merge merge
(map (map
@ -295,10 +304,11 @@
(= (:tag x) :entity) (= (:tag x) :entity)
(= (:name (:attrs x)) far-name))))) (= (:name (:attrs x)) far-name)))))
pretty-far (singularise far-name) pretty-far (singularise far-name)
safe-far (safe-name far-entity :sql)
farkey (-> % :attrs :farkey) farkey (-> % :attrs :farkey)
link-type (-> % :attrs :type) link-type (-> % :attrs :type)
link-field (-> % :attrs :name) link-field (-> % :attrs :name)
query-name (str "list-" entity-name "-by-" pretty-far) query-name (list-related-query-name % entity far-entity)
signature ":? :*"] signature ":? :*"]
(hash-map (hash-map
(keyword query-name) (keyword query-name)
@ -315,23 +325,27 @@
(case link-type (case link-type
"entity" (list "entity" (list
(str "-- :name " query-name " " signature) (str "-- :name " query-name " " signature)
(str "-- :doc lists all existing " pretty-name " records related to a given " pretty-far) (str "-- :doc lists all existing " pretty-far " records related to a given " pretty-name)
(str "SELECT lv_" entity-name ".* \nFROM lv_" entity-name ", " entity-name) (str "SELECT lv_" entity-safe ".* \nFROM lv_" entity-safe)
(str "WHERE lv_" entity-name "." (first (key-names entity)) " = " (str "WHERE lv_" entity-safe "." (safe-name % :sql) " = :id")
entity-name "." (first (key-names entity))
"\n\tAND " entity-name "." link-field " = :id")
(order-by-clause entity "lv_" false)) (order-by-clause entity "lv_" false))
"link" (let [link-table-name "link" (let [link-table-name
(link-table-name % entity far-entity)] (link-table-name % entity far-entity)]
(list (list
(str "-- :name " query-name " " signature) (str "-- :name " query-name " " signature)
(str "-- :doc links all existing " pretty-name " records related to a given " pretty-far) (str "-- :doc links all existing " pretty-far " records related to a given " pretty-name)
(str "SELECT * \nFROM " entity-name ", " link-table-name) (str "SELECT lv_" safe-far ".* \nFROM lv_" safe-far ", " link-table-name)
(str "WHERE " entity-name "." (str "WHERE lv_" safe-far "."
(first (key-names entity)) (safe-name (first (key-names far-entity)) :sql)
" = " link-table-name "." (singularise entity-name) "_id") " = " link-table-name "." (singularise safe-far) "_id")
(str "\tAND " link-table-name "." (singularise far-name) "_id = :id") (str "\tAND " link-table-name "." (singularise entity-safe) "_id = :id")
(order-by-clause entity))) (order-by-clause far-entity "lv_" false)))
"list" (list
(str "-- :name " query-name " " signature)
(str "-- :doc lists all existing " pretty-far " records related to a given " pretty-name)
(str "SELECT lv_" safe-far ".* \nFROM lv_" safe-far)
(str "WHERE lv_" safe-far "." (safe-name (first (key-names far-entity)) :sql) " = :id")
(order-by-clause far-entity "lv_" false))
(list (str "ERROR: unexpected type " link-type " of property " %))))) (list (str "ERROR: unexpected type " link-type " of property " %)))))
})) }))
links)))) links))))
@ -341,7 +355,7 @@
"Generate an appropriate `delete` query for this `entity`" "Generate an appropriate `delete` query for this `entity`"
(if (if
(has-primary-key? entity) (has-primary-key? entity)
(let [entity-name (:name (:attrs entity)) (let [entity-name (safe-name entity :sql)
pretty-name (singularise entity-name) pretty-name (singularise entity-name)
query-name (str "delete-" pretty-name "!") query-name (str "delete-" pretty-name "!")
signature ":! :n"] signature ":! :n"]

10
src/adl/to_psql.clj
View file

@ -466,6 +466,7 @@
#(and #(and
(entity? %) (entity? %)
(= (:name (:attrs %)) (:entity (:attrs property))))) (= (:name (:attrs %)) (:entity (:attrs property)))))
unique? (unique-link? e1 e2)
link-table-name (link-table-name property e1 e2)] link-table-name (link-table-name property e1 e2)]
(if (if
;; we haven't already emitted this one... ;; we haven't already emitted this one...
@ -485,6 +486,13 @@
[(construct-link-property e1) [(construct-link-property e1)
(construct-link-property e2)] (construct-link-property e2)]
permissions)))}] permissions)))}]
(if-not unique?
(*warn*
(str "WARNING: Manually check link tables between "
(-> e1 :attrs :name)
" and "
(-> e2 :attrs :name)
" for redundancy")))
;; mark it as emitted ;; mark it as emitted
(swap! emitted-link-tables conj link-table-name) (swap! emitted-link-tables conj link-table-name)
;; emit it ;; emit it
@ -498,7 +506,7 @@
(:name (:attrs e1)) (:name (:attrs e1))
" with " " with "
(:name (:attrs e2)))) (:name (:attrs e2))))
;; and immediately emit its referential integrity links ;; and immediately emit its referential integrity links
(emit-referential-integrity-links link-entity application))))))) (emit-referential-integrity-links link-entity application)))))))

355
src/adl/to_selmer_routes.clj
View file

@ -65,58 +65,146 @@
(vector (symbol (str (:name (:attrs application)) ".routes.manual")) :as 'm)))) (vector (symbol (str (:name (:attrs application)) ".routes.manual")) :as 'm))))
(defn make-form-get-handler-content (defn compose-fetch-record
[f e a n] [e]
(let [entity-name (singularise (:name (:attrs e)))] (let
;; TODO: as yet makes no attempt to save the record [entity-name (singularise (:name (:attrs e)))
(list 'let warning (str
(vector "Error while fetching "
'record (list entity-name
'get-current-value " record")]
(symbol (str "db/get-" entity-name)) (list
'params 'if
entity-name)) (list
(reduce 'all-keys-present?
merge 'params (key-names e true))
{:error (list :warnings 'record) (list
:record (list 'dissoc 'record :warnings)} 'support/do-or-log-error
(map (list
(fn [property] (query-name e :get)
(symbol "db/*db*")
'params)
:message warning
:error-return {:warnings [warning]}))))
(defn compose-get-menu-options
[property application]
;; TODO: doesn't handle the case of type="link"
(case (-> property :attrs :type)
"entity" (if-let [e (child-with-tag
application
:entity
#(= (-> % :attrs :name)
(-> property :attrs :entity)))]
(hash-map (hash-map
(keyword (-> property :attrs :name)) (keyword (-> property :attrs :name))
(list (list
'flatten 'get-menu-options
(list (singularise (-> e :attrs :name))
'remove (query-name e :search-strings)
'nil? (query-name e :search-strings)
(list (keyword (-> property :attrs :farkey))
'list (list (keyword (-> property :attrs :name)) 'params)))
;; Get the current value of the property, if it's an entity {})
(if (= (-> property :attrs :type) "entity") "link" (list
(list 'get-menu-options 'do
(-> e :attrs :name) (list
(-> property :attrs :farkey) 'comment
(list (keyword (-> property :attrs :name)) 'params)))))))) "Can't yet handle link properties")
(filter #(:entity (:attrs %)) {})
(descendants-with-tag e :property))))))) "list" (list
'do
(list
'comment
"Can't yet handle link properties")
{})
(list
'do
(list
'comment
(str "Unexpected type " (-> property :atts :type)))
{})))
(defn compose-fetch-auxlist-data
[auxlist entity application]
(let [p-name (-> auxlist :attrs :property)
property (child-with-tag entity
:property
#(= (-> % :attrs :name) p-name))
f-name (-> property :attrs :entity)
farside (child-with-tag application
:entity
#(= (-> % :attrs :name) f-name))]
(if (and (entity? entity) (entity? farside))
(list 'if (list 'all-keys-present? 'params (key-names entity true))
(hash-map
(keyword (auxlist-data-name auxlist))
(list
(symbol (str "db/" (list-related-query-name property entity farside)))
'db/*db*
{:id
(list
(case (-> property :attrs :type)
"link" :id
"list" (keyword (-> property :attrs :name)))
'params)})))
(do
(if-not
(entity? entity)
(*warn*
(str
"Entity '"
(-> entity :attrs :name)
"' passed to compose-fetch-auxlist-data is a non-entity")))
(if-not
(entity? farside)
(*warn*
(str
"Entity '"
f-name
"' (" farside ")
found in compose-fetch-auxlist-data is a non-entity")))
nil))))
(defn make-form-get-handler-content
[f e a n]
(list
'let
(vector
'record (compose-fetch-record e))
(list
'reduce
'merge
{:error (list :warnings 'record)
:record (list 'dissoc 'record :warnings)}
(cons
'list
(concat
(map
#(compose-get-menu-options % a)
(filter #(:entity (:attrs %))
(descendants-with-tag e :property)))
(map
#(compose-fetch-auxlist-data % e a)
(descendants-with-tag f :auxlist))
(list
(list 'if (list :error 'request)
{:error (list :error 'request)})
(list 'if (list :message 'request)
{:message (list :message 'request)})))))))
(defn make-page-get-handler-content (defn make-page-get-handler-content
[f e a n] [f e a n]
(let [warning (str "Error while fetching " (singularise (:name (:attrs e))) " record")] (list
(list 'let 'let
(vector 'record (list (vector
'support/handler-content-log-error 'record (compose-fetch-record e))
(list 'if (list 'subset? (list 'keys 'p) (key-names e)) [] {:warnings (list :warnings 'record)
(list :record (list 'assoc 'record :warnings nil)}))
(symbol
(str "db/get-" (singularise (:name (:attrs e)))))
(symbol "db/*db*")
'params))
:message warning
:error-return {:warnings [warning]}))
{:warnings (list :warnings 'record)
:record (list 'assoc 'record :warnings nil)})))
(defn make-list-get-handler-content (defn make-list-get-handler-content
@ -130,45 +218,55 @@
(list (list
'some 'some
(set (map #(keyword (-> % :attrs :name)) (all-properties e))) (set (map #(keyword (-> % :attrs :name)) (all-properties e)))
(list 'keys 'params)) (list
(list 'do 'keys 'params))
(list (symbol "log/debug") (list (symbol (str "db/search-strings-" (:name (:attrs e)) "-sqlvec")) 'params)) (list
(list 'do
'support/do-or-log-error (list
(list (symbol "log/debug")
(symbol (str "db/search-strings-" (:name (:attrs e)))) (list
(symbol "db/*db*") (symbol
'params) (str "db/search-strings-" (:name (:attrs e)) "-sqlvec")) 'params))
:message (str (list
"Error while searching " 'support/do-or-log-error
(singularise (:name (:attrs e))) (list
" records") (symbol (str "db/search-strings-" (:name (:attrs e))))
:error-return {:warnings [(str (symbol "db/*db*")
"Error while searching " 'params)
(singularise (:name (:attrs e))) :message (str
" records")]})) "Error while searching "
(list 'do (singularise (:name (:attrs e)))
(list (symbol "log/debug") (list (symbol (str "db/list-" (:name (:attrs e)) "-sqlvec")) 'params)) " records")
(list :error-return {:warnings [(str
'support/do-or-log-error "Error while searching "
(list (singularise (:name (:attrs e)))
(symbol " records")]}))
(str (list
"db/list-" 'do
(:name (:attrs e)))) (list
(symbol "db/*db*") {}) (symbol "log/debug")
:message (str (list (symbol (str "db/list-" (:name (:attrs e)) "-sqlvec")) 'params))
"Error while fetching " (list
(singularise (:name (:attrs e))) 'support/do-or-log-error
" records") (list
:error-return {:warnings [(str (symbol
"Error while fetching " (str
(singularise (:name (:attrs e))) "db/list-"
" records")]})))) (:name (:attrs e))))
(list 'if (symbol "db/*db*") 'params)
(list :warnings 'records) :message (str
'records "Error while fetching "
{:records 'records}))) (singularise (:name (:attrs e)))
" records")
:error-return {:warnings [(str
"Error while fetching "
(singularise (:name (:attrs e)))
" records")]}))))
(list
'if
(list :warnings 'records)
'records
{:records 'records})))
(defn handler-name (defn handler-name
@ -211,49 +309,58 @@
[create-name (query-name e :create) [create-name (query-name e :create)
update-name (query-name e :update)] update-name (query-name e :update)]
(list (list
'let 'let
(vector (vector
'result 'insert-params (list
(list 'prepare-insertion-params
'valid-user-or-forbid 'params
(list (set
'with-params-or-error (map
#(-> % :attrs :name)
(insertable-properties e))))
'result
(list (list
'do-or-server-fail 'valid-user-or-forbid
(list
'if
(list 'all-keys-present? 'params (key-names e true))
(list (list
update-name 'with-params-or-error
'db/*db* (list
'params) 'if
(list (list 'all-keys-present? 'params (key-names e true))
create-name (list
'db/*db* 'do-or-server-fail
'params)) (list
200) ;; OK update-name
'params 'db/*db*
(set 'insert-params)
(map 200)
#(keyword (:name (:attrs %))) (list
(insertable-properties e)))) 'do-or-server-fail
'request)) (list
(list create-name
'if 'db/*db*
'insert-params)
201))
'params
(set
(map
#(keyword (:name (:attrs %)))
(required-properties e))))
'request))
(list (list
(set [200 400]) (symbol (handler-name f e a :get))
(list :status 'result)) (list 'merge
(list (list
(symbol (handler-name f e a :get)) 'assoc
(list 'request
'assoc :params
'request (list
:params 'merge
(list 'params
'merge 'result))
'params (list 'case (:status 'result)
'result))) 200 {:message "Record stored"}
'result)))) 201 (str "Record created: " (list :body 'result))
{:error (list :body 'result)}))))))
(defn make-post-handler (defn make-post-handler

205
src/adl/to_selmer_templates.clj
View file

@ -3,6 +3,7 @@
:author "Simon Brooke"} :author "Simon Brooke"}
adl.to-selmer-templates adl.to-selmer-templates
(:require [adl-support.core :refer :all] (:require [adl-support.core :refer :all]
[adl-support.forms-support :refer :all]
[adl.to-hugsql-queries :refer [expanded-token]] [adl.to-hugsql-queries :refer [expanded-token]]
[adl-support.utils :refer :all] [adl-support.utils :refer :all]
[clojure.java.io :refer [file make-parents resource]] [clojure.java.io :refer [file make-parents resource]]
@ -65,7 +66,6 @@
(defn emit-content (defn emit-content
([content] ([content]
(do-or-warn
(cond (cond
(nil? content) (nil? content)
nil nil
@ -77,8 +77,7 @@
(seq? content) (seq? content)
(map emit-content (remove nil? content)) (map emit-content (remove nil? content))
true true
(str "<!-- don't know what to do with '" content "' -->")) (str "<!-- don't know what to do with '" content "' -->")))
(str "Failed while writing " content)))
([filename application k] ([filename application k]
(emit-content filename nil nil application k)) (emit-content filename nil nil application k))
([filename spec entity application k] ([filename spec entity application k]
@ -374,6 +373,20 @@
"{% endif %}")))}) "{% endif %}")))})
(defn get-size-for-widget
"Return, as an integer, the fieldwidth for the input widget for this
`property`."
[property]
(let [s (try
(read-string
(:size (:attrs property)))
(catch Exception _ 16))]
(if
(not (integer? s))
16
s)))
(defn compose-input-widget-para (defn compose-input-widget-para
"Generate an input widget for this `field-or-property` of this `form` for "Generate an input widget for this `field-or-property` of this `form` for
this `entity` taken from within this `application`, in context of a para this `entity` taken from within this `application`, in context of a para
@ -390,17 +403,14 @@
:name widget-name :name widget-name
:type w-type :type w-type
:value (str "{{record." widget-name "}}") :value (str "{{record." widget-name "}}")
:maxlength (:size (:attrs property)) :maxlength (str (max (get-size-for-widget property) 16))
:size (cond :size (str (min (get-size-for-widget property) 60))}
(nil? (:size (:attrs property))) (case (-> property :attrs :type)
"16" "real"
(try {:step 0.000001} ;; this is a bit arbitrary!
(> (read-string "integer"
(:size (:attrs property))) 60) {:step 1}
(catch Exception _ false)) nil)
"60"
true
(:size (:attrs property)))}
;; TODO: should match pattern from typedef ;; TODO: should match pattern from typedef
(if (if
(:minimum (:attrs typedef)) (:minimum (:attrs typedef))
@ -479,10 +489,12 @@
(defn edit-link (defn edit-link
[entity application parameters] [source entity application parameters]
(str (str
"{{servlet-context}}/" "{{servlet-context}}/"
(editor-name entity application) (or
(-> source :attrs :onselect)
(editor-name entity application))
"?" "?"
(s/join (s/join
"&amp;" "&amp;"
@ -494,7 +506,7 @@
(defn list-tbody (defn list-tbody
"Return a table body element for the list view for this `list-spec` of "Return a table body element for the list view for this `list-spec` of
this `entity` within this `application`, using data from this source." this `entity` within this `application`, using data from this `source`."
[source list-spec entity application] [source list-spec entity application]
{:tag :tbody {:tag :tbody
:content :content
@ -502,40 +514,50 @@
{:tag :tr {:tag :tr
:content :content
(apply (apply
vector vector
(remove
nil?
(concat (concat
(map (map
(fn [field] (fn [field]
{:tag :td :content {:tag :td :content
(let (let
[p (first [p (first
(filter (filter
#(= #(=
(:name (:attrs %)) (:name (:attrs %))
(:property (:attrs field))) (:property (:attrs field)))
(all-properties entity))) (all-properties entity)))
s (safe-name (:name (:attrs p)) :sql) s (safe-name (:name (:attrs p)) :sql)
e (first e (first
(filter (filter
#(= (:name (:attrs %)) (:entity (:attrs p))) #(= (:name (:attrs %)) (:entity (:attrs p)))
(children-with-tag application :entity))) (children-with-tag application :entity)))
c (str "{{ record." s " }}")] c (str "{{ record." s " }}")]
(if (if
(= (:type (:attrs p)) "entity") (= (:type (:attrs p)) "entity")
[{:tag :a [{:tag :a
:attrs {:href (edit-link :attrs {:href (edit-link
e source
(child-with-tag
application application
(list (:name (:attrs p))))} :entity
:content [(str "{{ record." s "_expanded }}")]}] #(= (-> % :attrs :name)(-> p :attrs :entity)))
[c]))}) application
(children-with-tag list-spec :field)) (list (:name (:attrs p))))}
[{:tag :td :content [(str "{{ record." s "_expanded }}")]}]
[c]))})
(children-with-tag list-spec :field))
[{:tag :td
:content :content
[{:tag :a [(if
:attrs (or (= (:tag list-spec) :list)
{:href (edit-link entity application (key-names entity))} (-> list-spec :attrs :onselect))
:content ["View"]}]}]))} {:tag :a
:attrs
{:href (edit-link source entity application (key-names entity))}
:content ["View"]}
"&nbsp;")]}])))}
"{% endfor %}"]}) "{% endfor %}"]})
@ -545,42 +567,70 @@
entity entity
:property :property
#(= #(=
(-> % :attrs :name) (-> % :attrs :name)
(-> auxlist :attrs :property))) (-> auxlist :attrs :property)))
farside (child-with-tag farside (child-with-tag
application application
:entity :entity
#(= #(=
(-> % :attrs :name) (-> % :attrs :name)
(-> property :attrs :entity)))] (-> property :attrs :entity)))]
(if (if
(and property farside) (and property farside)
{:tag :div {:tag :div
:attrs {:class "auxlist"} :attrs {:class "auxlist"}
:content :content
[{:tag :h2 (apply
:content [(prompt auxlist form entity application)]} vector
{:tag :table (remove
:content nil?
[{:tag :thead (flatten
:content (list
[{:tag :tr ;; only show auxlists if we've got keys
:content (str "{% if all "
(apply (s/join " " (map #(str "params." %) (key-names entity)))
vector " %}")
(flatten ;; only show the body of auxlists if the list is non-empty
(list (str "{% if " (auxlist-data-name auxlist) "|not-empty %}")
(map
#(hash-map {:tag :h2
:tag :th :content [(prompt auxlist form entity application)]}
:content [(prompt % form entity application)]) {:tag :table
(children-with-tag auxlist :field)) :content
{:tag :th :content ["&nbsp;"]})))}]} [{:tag :thead
(list-tbody :content
(-> property :attrs :name) [{:tag :tr
auxlist :content
farside (apply
application)]}]}))) vector
(remove
nil?
(flatten
(list
(map
#(hash-map
:tag :th
:content [(prompt % form entity application)])
(children-with-tag auxlist :field))
{:tag :th :content ["&nbsp;"]}))))}]}
(list-tbody
(auxlist-data-name auxlist)
auxlist
farside
application)]}
"{% endif %}"
(if
(= (-> auxlist :attrs :canadd) "true")
(wrap-in-if-member-of
(big-link (str
"Add a new "
(pretty-name property))
(editor-name farside application))
:writeable
farside
application)
)
"{% endif %}"))))})))
(defn compose-form-auxlists (defn compose-form-auxlists
@ -1030,11 +1080,12 @@
(if (if
(pos? *verbosity*) (pos? *verbosity*)
(*warn* "\tGenerated " filepath)) (*warn* "\tGenerated " filepath))
(str filepath)))))) (str filepath))
(str "While generating " filepath)))))
;; (def a (x/parse "../youyesyet/youyesyet.canonical.adl.xml")) ;; (def a (x/parse "../youyesyet/youyesyet.canonical.adl.xml"))
;; (def e (child-with-tag a :entity)) ;; (def e (child-with-tag a :entity #(= (-> % :attrs :name) "teams")))
;; (def f (child-with-tag e :form)) ;; (def f (child-with-tag e :form))
;; (write-template-file "froboz" (form-to-template f e a) a) ;; (write-template-file "froboz" (form-to-template f e a) a)
;; (def t (form-to-template f e a)) ;; (def t (form-to-template f e a))