diff --git a/resources/transforms/adl2canonical.xslt b/resources/transforms/adl2canonical.xslt
index 78f9f33..9c583db 100755
--- a/resources/transforms/adl2canonical.xslt
+++ b/resources/transforms/adl2canonical.xslt
@@ -418,6 +418,7 @@
<xsl:attribute name="property">
<xsl:value-of select="@name"/>
</xsl:attribute>
+ <xsl:copy-of select="*"/>
</field>
</xsl:for-each>
</xsl:template>
@@ -435,6 +436,7 @@
<xsl:attribute name="property">
<xsl:value-of select="@name"/>
</xsl:attribute>
+ <xsl:copy-of select="*"/>
</field>
</xsl:otherwise>
</xsl:choose>
@@ -454,6 +456,7 @@
</xsl:attribute>
<xsl:apply-templates select="adl:prompt"/>
<xsl:apply-templates select="adl:help"/>
+ <xsl:copy-of select="*"/>
</field>
</xsl:for-each>
</xsl:template>
diff --git a/src/adl/to_hugsql_queries.clj b/src/adl/to_hugsql_queries.clj
index 4317007..4700ae8 100644
--- a/src/adl/to_hugsql_queries.clj
+++ b/src/adl/to_hugsql_queries.clj
@@ -36,17 +36,25 @@
"The path to which generated files will be written."
"resources/auto/")
+(def electors {:tag :entity, :attrs {:magnitude "6", :name "electors", :table "electors"}, :content [{:tag :key, :attrs nil, :content [{:tag :property, :attrs {:distinct "system", :immutable "true", :column "id", :name "id", :type "integer", :required "true"}, :content [{:tag :prompt, :attrs {:locale "en-GB", :prompt "id"}, :content nil}]}]} {:tag :property, :attrs {:distinct "user", :column "name", :name "name", :type "string", :required "true", :size "64"}, :content [{:tag :prompt, :attrs {:locale "en-GB", :prompt "name"}, :content nil}]} {:tag :property, :attrs {:farkey "id", :entity "dwelling", :column "dwelling_id", :name "dwelling_id", :type "entity", :required "true"}, :content [{:tag :prompt, :attrs {:locale "en-GB", :prompt "Flat"}, :content nil}]} {:tag :property, :attrs {:distinct "user", :column "phone", :name "phone", :type "string", :size "16"}, :content [{:tag :prompt, :attrs {:locale "en-GB", :prompt "phone"}, :content nil}]} {:tag :property, :attrs {:distinct "user", :column "email", :name "email", :type "string", :size "128"}, :content [{:tag :prompt, :attrs {:locale "en-GB", :prompt "email"}, :content nil}]} {:tag :property, :attrs {:default "Unknown", :farkey "id", :entity "genders", :column "gender", :type "entity", :name "gender"}, :content [{:tag :prompt, :attrs {:locale "en-GB", :prompt "gender"}, :content nil}]} {:tag :list, :attrs {:name "Electors", :properties "listed"}, :content [{:tag :field, :attrs {:property "id"}, :content nil} {:tag :field, :attrs {:property "name"}, :content nil} {:tag :field, :attrs {:property "dwelling_id"}, :content nil} {:tag :field, :attrs {:property "phone"}, :content nil} {:tag :field, :attrs {:property "email"}, :content nil} {:tag :field, :attrs {:property "gender"}, :content nil}]} {:tag :form, :attrs {:name "Elector", :properties "listed"}, :content [{:tag :field, :attrs {:property "id"}, :content nil} {:tag :field, :attrs {:property "name"}, :content nil} {:tag :field, :attrs {:property "dwelling_id"}, :content nil} {:tag :field, :attrs {:property "phone"}, :content nil} {:tag :field, :attrs {:property "email"}, :content nil} {:tag :field, :attrs {:property "gender"}, :content nil}]}]})
(defn where-clause
- "Generate an appropriate `where` clause for queries on this `entity`"
- [entity]
- (let
- [entity-name (:name (:attrs entity))]
- (str
- "WHERE " entity-name "."
- (s/join
- (str " AND\n\t" entity-name ".")
- (map #(str % " = " (keyword %)) (key-names entity))))))
+ "Generate an appropriate `where` clause for queries on this `entity`;
+ if `properties` are passed, filter on those properties, otherwise the key
+ properties."
+ ([entity]
+ (where-clause entity (key-properties entity)))
+ ([entity properties]
+ (let
+ [entity-name (:name (:attrs entity))
+ property-names (map #(:name (:attrs %)) properties)]
+ (if
+ (not (empty? property-names))
+ (str
+ "WHERE "
+ (s/join
+ "\n\tAND"
+ (map #(str entity-name "." % " = :" %) property-names)))))))
(defn order-by-clause
@@ -75,11 +83,7 @@
[entity]
(let [entity-name (:name (:attrs entity))
pretty-name (singularise entity-name)
- insertable-property-names (map
- #(:name (:attrs %))
- (filter
- #(not (= (:distinct (:attrs %)) "system"))
- (all-properties entity)))
+ insertable-property-names (map #(:name (:attrs %)) (insertable-properties entity))
query-name (str "create-" pretty-name "!")
signature ":! :n"]
(hash-map
@@ -110,11 +114,7 @@
(has-non-key-properties? entity))
(let [entity-name (:name (:attrs entity))
pretty-name (singularise entity-name)
- property-names (remove
- nil?
- (map
- #(if (= (:tag %) :property) (:name (:attrs %)))
- (vals (:properties (:content entity)))))
+ property-names (map #(:name (:attrs %)) (insertable-properties entity))
query-name (str "update-" pretty-name "!")
signature ":! :n"]
(hash-map
@@ -135,73 +135,85 @@
(defn search-query [entity]
- "Generate an appropriate search query for this `entity`"
+ "Generate an appropriate search query for string fields of this `entity`"
(let [entity-name (:name (:attrs entity))
pretty-name (singularise entity-name)
query-name (str "search-strings-" pretty-name)
signature ":? :1"
- props (concat (properties entity-map) (insertable-key-properties entity-map))
- string-fields (filter
- #(= (-> % :attrs :type) "string")
- (children entity #(= (:tag %) :property)))]
- (if
- (empty? string-fields)
- {}
- (hash-map
- (keyword query-name)
- {:name query-name
- :signature signature
- :entity entity
- :type :text-search
- :query
- (s/join
- "\n"
- (remove
- empty?
- (list
- (str "-- :name " query-name " " signature)
- (str
- "-- :doc selects existing "
- pretty-name
- " records having any string field matching `:pattern` by substring match")
- (str "SELECT * FROM " entity-name)
- "WHERE "
- (s/join
- "\n\tOR "
+ properties (all-properties entity)]
+ (hash-map
+ (keyword query-name)
+ {:name query-name
+ :signature signature
+ :entity entity
+ :type :text-search
+ :query
+ (s/join
+ "\n"
+ (remove
+ empty?
+ (list
+ (str "-- :name " query-name " " signature)
+ (str
+ "-- :doc selects existing "
+ pretty-name
+ " records having any string field matching `:pattern` by substring match")
+ (str "SELECT * FROM " entity-name)
+ "WHERE "
+ (s/join
+ "\n\tOR "
+ (filter
+ string?
(map
- #(str (-> % :attrs :name) " LIKE '%:pattern%'")
- string-fields))
- (order-by-clause entity)
- "--~ (if (:offset params) \"OFFSET :offset \")"
- "--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")")))}))))
+ #(if
+ (#{"string" "date" "text"} (:type (:attrs %)))
+ (str (-> % :attrs :name) " LIKE '%:pattern%'"))
+ properties)))
+ (order-by-clause entity)
+ "--~ (if (:offset params) \"OFFSET :offset \")"
+ "--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")")))})))
-(defn select-query [entity]
+(defn select-query
"Generate an appropriate `select` query for this `entity`"
- (if
- (has-primary-key? entity)
- (let [entity-name (:name (:attrs entity))
- pretty-name (singularise entity-name)
- query-name (str "get-" pretty-name)
- signature ":? :1"]
- (hash-map
- (keyword query-name)
- {:name query-name
- :signature signature
- :entity entity
- :type :select-1
- :query
- (s/join
- "\n"
- (remove
- empty?
- (list
- (str "-- :name " query-name " " signature)
- (str "-- :doc selects an existing " pretty-name " record")
- (str "SELECT * FROM " entity-name)
- (where-clause entity)
- (order-by-clause entity))))}))
- {}))
+ ([entity properties]
+ (if
+ (not (empty? properties))
+ (let [entity-name (:name (:attrs entity))
+ pretty-name (singularise entity-name)
+ query-name (if (= properties (key-properties entity))
+ (str "get-" pretty-name)
+ (str "get-" pretty-name "-by-" (s/join "=" (map #(:name (:attrs %)) properties))))
+ signature ":? :1"]
+ (hash-map
+ (keyword query-name)
+ {:name query-name
+ :signature signature
+ :entity entity
+ :type :select-1
+ :query
+ (s/join
+ "\n"
+ (remove
+ empty?
+ (list
+ (str "-- :name " query-name " " signature)
+ (str "-- :doc selects an existing " pretty-name " record")
+ (str "SELECT * FROM " entity-name)
+ (where-clause entity properties)
+ (order-by-clause entity))))}))
+ {}))
+ ([entity]
+ (let [distinct-fields (distinct-properties entity)]
+ (apply
+ merge
+ (cons
+ (select-query entity (key-properties entity))
+ (map
+ #(select-query entity %)
+ (combinations distinct-fields (count distinct-fields))))))))
+
+(select-query electors)
(defn list-query
@@ -373,21 +385,27 @@
(defn queries
- "Generate all standard queries for this `entity` in this `application`."
- [entity application]
- (merge
- {}
- (insert-query entity)
- (update-query entity)
- (delete-query entity)
- (if
- (link-table? entity)
- (link-table-queries entity application)
- (merge
- (select-query entity)
- (list-query entity)
- (search-query entity)
- (foreign-queries entity application)))))
+ "Generate all standard queries for this `entity` in this `application`; if
+ no entity is specified, generate all queris for the application."
+ ([application entity]
+ (merge
+ {}
+ (insert-query entity)
+ (update-query entity)
+ (delete-query entity)
+ (if
+ (link-table? entity)
+ (link-table-queries entity application)
+ {})
+ (select-query entity)
+ (list-query entity)
+ (search-query entity)
+ (foreign-queries entity application)))
+ ([application]
+ (apply
+ merge
+ (map #(queries application %)
+ (children-with-tag application :entity)))))
(defn to-hugsql-queries
@@ -410,11 +428,5 @@
(sort
#(compare (:name %1) (:name %2))
(vals
- (apply
- merge
- (map
- #(queries % application)
- (children
- application
- (fn [child] (= (:tag child) :entity))))))))))))
+ (queries application))))))))
diff --git a/src/adl/to_json_routes.clj b/src/adl/to_json_routes.clj
index 01a8ddc..97e015c 100644
--- a/src/adl/to_json_routes.clj
+++ b/src/adl/to_json_routes.clj
@@ -2,7 +2,6 @@
:author "Simon Brooke"}
adl.to-json-routes
(:require [clojure.java.io :refer [file]]
- [clojure.math.combinatorics :refer [combinations]]
[clojure.string :as s]
[clj-time.core :as t]
[clj-time.format :as f]))
diff --git a/src/adl/to_selmer_routes.clj b/src/adl/to_selmer_routes.clj
new file mode 100644
index 0000000..9386d13
--- /dev/null
+++ b/src/adl/to_selmer_routes.clj
@@ -0,0 +1,152 @@
+(ns ^{:doc "Application Description Language: generate routes for user interface requests."
+ :author "Simon Brooke"}
+ adl.to-selmer-routes
+ (:require [clojure.java.io :refer [file make-parents writer]]
+ [clojure.pprint :refer [pprint]]
+ [clojure.string :as s]
+ [clojure.xml :as x]
+ [clj-time.core :as t]
+ [clj-time.format :as f]
+ [adl.utils :refer :all]))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;
+;;;; adl.to-selmer-routes: generate RING routes for REST requests.
+;;;;
+;;;; This program is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU General Public License
+;;;; as published by the Free Software Foundation; either version 2
+;;;; of the License, or (at your option) any later version.
+;;;;
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this program; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;;; USA.
+;;;;
+;;;; Copyright (C) 2018 Simon Brooke
+;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; Generally. there's one route in the generated file for each Selmer template which has been generated.
+
+(def ^:dynamic *output-path*
+ "The path to which generated files will be written."
+ "resources/auto/")
+
+
+(defn file-header
+ [application]
+ (list
+ 'ns
+ (symbol (str (:name (:attrs application)) ".routes.auto"))
+ (str "JSON routes for " (pretty-name application)
+ " auto-generated by [Application Description Language framework](https://github.com/simon-brooke/adl) at "
+ (f/unparse (f/formatters :basic-date-time) (t/now)))
+ (list
+ :require
+ '[noir.response :as nresponse]
+ '[noir.util.route :as route]
+ '[compojure.core :refer [defroutes GET POST]]
+ '[ring.util.http-response :as response]
+ '[clojure.java.io :as io]
+ '[hugsql.core :as hugsql]
+ (vector (symbol (str (:name (:attrs application)) ".routes.manual")) :as 'm))))
+
+(defn make-handler
+ [f e a]
+ (let [n (path-part f e a)]
+ (list
+ 'defn
+ (symbol n)
+ (vector 'r)
+ (list
+ 'layout/render
+ (list 'resolve-template (str n ".html")) {:title (pretty-name e)}))))
+
+(defn make-route
+ "Make a route for method `m` to request the resource with name `n`."
+ [m n]
+ (list
+ m
+ (str "/" n)
+ 'request
+ (list
+ 'route/restricted
+ (list
+ 'apply
+ (list 'resolve-handler n)
+ (list 'list 'request)))))
+
+(defn make-defroutes
+ [application]
+ (let [routes (flatten
+ (map
+ (fn [e]
+ (map
+ (fn [c]
+ (path-part c e application))
+ (filter (fn [c] (#{:form :list :page} (:tag c))) (children e))))
+ (children-with-tag application :entity)))]
+ (cons
+ 'defroutes
+ (cons
+ 'auto-selmer-routes
+ (interleave
+ (map
+ (fn [r] (make-route 'GET r))
+ (sort routes))
+ (map
+ (fn [r] (make-route 'POST r))
+ (sort routes)))))))
+
+
+(defn to-selmer-routes
+ [application]
+ (let [filename (str *output-path* (:name (:attrs application)) "/routes/auto.clj")]
+ (make-parents filename)
+ (with-open [output (writer filename)]
+ (binding [*out* output]
+ (pprint (file-header application))
+ (println)
+ (pprint '(defn raw-resolve-template [n]
+ (if
+ (.exists (io/as-file (str "resources/templates/" n)))
+ n
+ (str "auto/" n))))
+ (println)
+ (pprint '(def resolve-template (memoise raw-resolve-template)))
+ (println)
+ (doall
+ (map
+ (fn [e]
+ (doall
+ (map
+ (fn [c]
+ (pprint (make-handler c e application))
+ (println))
+ (filter (fn [c] (#{:form :list :page} (:tag c))) (children e)))))
+ (children-with-tag application :entity)))
+ (pprint '(defn raw-resolve-handler
+ "Prefer the manually-written version of the handler with name `n`, if it exists, to the automatically generated one"
+ [n]
+ (let [s (symbol (str "m." n))]
+ (if
+ (bound? s)
+ (eval s)
+ (eval (symbol n))))))
+ (println)
+ (pprint '(def resolve-handler
+ (memoize raw-resolve-handler)))
+ (println)
+ (pprint (make-defroutes application))
+ (println)))))
+
+(def x (x/parse "../youyesyet/youyesyet.canonical.adl.xml"))
+
+(to-selmer-routes x)
+
diff --git a/src/adl/to_selmer_templates.clj b/src/adl/to_selmer_templates.clj
index e976341..7ad3beb 100644
--- a/src/adl/to_selmer_templates.clj
+++ b/src/adl/to_selmer_templates.clj
@@ -1,9 +1,8 @@
-(ns ^{;; :doc "Application Description Language - generate RING routes for REST requests."
+(ns ^{;; :doc "Application Description Language - generate Selmer templates for the HTML pages implied by an ADL file."
:author "Simon Brooke"}
adl.to-selmer-templates
(:require [adl.utils :refer :all]
[clojure.java.io :refer [file]]
- [clojure.math.combinatorics :refer [combinations]]
[clojure.pprint :as p]
[clojure.string :as s]
[clojure.xml :as x]
@@ -13,7 +12,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
-;;;; adl.to-json-routes: generate RING routes for REST requests.
+;;;; adl.to-selmer-templates.
;;;;
;;;; This program is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU General Public License
@@ -43,6 +42,31 @@
"The path to which generated files will be written."
"resources/auto/")
+
+(defn big-link
+ [content url]
+ {:tag :div
+ :attrs {:class "big-link-container"}
+ :content
+ [{:tag :a :attrs {:href url}
+ :content (if
+ (vector? content)
+ content
+ [content])}]})
+
+
+(defn back-link
+ [content url]
+ {:tag :div
+ :attrs {:class "back-link-container"}
+ :content
+ [{:tag :a :attrs {:href url}
+ :content (if
+ (vector? content)
+ content
+ [content])}]})
+
+
(defn file-header
"Generate a header for a template file."
[filename]
@@ -67,15 +91,19 @@
"Return an appropriate prompt for the given `field-or-property` taken from this
`form` of this `entity` of this `application`, in the context of the current
binding of `*locale*`. TODO: something more sophisticated about i18n"
- [field-or-property form entity application]
- (or
- (first
- (children
- field-or-property
- #(and
- (= (:tag %) :prompt)
- (= (:locale :attrs %) *locale*))))
- (:name (:attrs field-or-property))))
+ ([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)))))
(defn csrf-widget
@@ -166,12 +194,48 @@
))))
+(defn select-widget
+ [property form entity application]
+ (let [farname (:entity (:attrs property))
+ farside (first (children application #(= (:name (:attrs %)) farname)))
+ magnitude (try (read-string (:magnitude (:attrs farside))) (catch Exception _ 7))
+ async? (and (number? magnitude) (> magnitude 1))
+ widget-name (:name (:attrs property))]
+ {:tag :div
+ :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 "/* javascript to repopulate the select widget */"}})
+ {:tag :select
+ :attrs (merge
+ {:id widget-name
+ :name widget-name}
+ (if
+ (= (:type (:attrs property)) "link")
+ {:multiple "multiple"})
+ (if
+ async?
+ {:comment "JavaScript stuff to fix up aynchronous loading"}))
+ :content (apply vector (get-options property form entity application))})))}))
+
+
(defn widget
"Generate a widget for this `field-or-property` of this `form` for this `entity`
taken from within this `application`."
[field-or-property form entity application]
(let
- [widget-name (:name (:attrs field-or-property))
+ [widget-name (if (= (:tag field-or-property) :property)
+ (:name (:attrs field-or-property))
+ (:property (:attrs field-or-property)))
property (if
(= (:tag field-or-property) :property)
field-or-property
@@ -199,13 +263,11 @@
:content [{:tag :label
:attrs {:for widget-name}
:content [(prompt field-or-property form entity application)]}
- "TODO: selmer command to hide for all groups except for those for which it is writable"
- (if
+ (str "{% ifwritable " (:name (:attrs entity)) " " (:name (:attrs property)) " %}")
+ (cond
select?
- {:tag :select
- :attrs {:id widget-name
- :name widget-name}
- :content (get-options property form entity application)}
+ (select-widget property form entity application)
+ true
{:tag :input
:attrs (merge
{:id widget-name
@@ -219,14 +281,20 @@
(:maximum (:attrs typedef))
{:max (:maximum (:attrs typedef))}))})
"{% else %}"
- "TODO: selmer if command to hide for all groups except to those for which it is readable"
+ (str "{% ifreadable " (:name (:attrs entity)) " " (:name (:attrs property)) "%}")
{:tag :span
:attrs {:id widget-name
:name widget-name
:class "pseudo-widget disabled"}
:content [(str "{{record." widget-name "}}")]}
- "{% endif %}"
- "{% endif %}"]})))
+ "{% endifreadable %}"
+ "{% endifwritable %}"]})))
+
+
+(defn fields
+ [form]
+ (descendants-with-tag form :field))
+
(defn form-to-template
@@ -235,22 +303,14 @@
template for the entity."
[form entity application]
(let
- [name (str (if form (:name (:attrs form)) "edit") "-" (:name (:attrs entity)))
- keyfields (children
+ [keyfields (children
;; there should only be one key; its keys are properties
- (first (children entity #(= (:tag %) :key))))
- fields (if
- (and form (= "listed" (:properties (:attrs form))))
- ;; if we've got a form, collect its fields, fieldgroups and verbs
- (flatten
- (map #(if (#{:field :fieldgroup :verb} (:tag %)) %)
- (children form)))
- (children entity #(= (:tag %) :property)))]
+ (first (children entity #(= (:tag %) :key))))]
{:tag :div
:attrs {:id "content" :class "edit"}
:content
[{:tag :form
- :attrs {:action (str "{{servlet-context}}/" name)
+ :attrs {:action (str "{{servlet-context}}/" (editor-name entity application))
:method "POST"}
:content (flatten
(list
@@ -260,7 +320,7 @@
keyfields)
(map
#(widget % form entity application)
- fields)
+ (fields entity))
(save-widget form entity application)
(delete-widget form entity application)))}]}))
@@ -273,67 +333,91 @@
[page entity application]
)
-(defn list-to-template
+
+(defn- list-thead
+ [list-spec]
+ {:tag :thead
+ :content
+ [{:tag :tr
+ :content
+ (apply
+ vector
+ (map
+ #(hash-map
+ :content [(prompt %)]
+ :tag :th)
+ (fields list-spec)))}
+ {:tag :tr
+ :content
+ (apply
+ vector
+ (map
+ #(hash-map
+ :tag :th
+ :content
+ [{:tag :input
+ :attrs {:id (:property (:attrs %))
+ :name (:property (:attrs %))}}])
+ (fields list-spec)))}]})
+
+
+(defn- list-tbody
+ [list-spec entity application]
+ {:tag :tbody
+ :content
+ ["{% for record in %records% %}"
+ {:tag :tr
+ :content
+ (apply
+ vector
+ (concat
+ (map
+ (fn [field]
+ {:tag :td :content [(str "{{ record." (:property (:attrs field)) " }}")]})
+ (fields list-spec))
+ [{:tag :td
+ :content
+ [{:tag :a
+ :attrs
+ {:href
+ (str
+ (editor-name entity application)
+ "?"
+ (s/join
+ "&"
+ (map
+ #(let [n (:name (:attrs %))]
+ (str n "={{ record." n "}}"))
+ (children (first (filter #(= (:tag %) :key) (children entity)))))))}
+ :content ["View"]}]}]))}
+ "{% endfor %}"]})
+
+
+(defn- list-to-template
"Generate a template as specified by this `list` element for this `entity`,
taken from this `application`. If `list` is nill, generate a default list
template for the entity."
[list-spec entity application]
- (let [user-distinct-fields]
- [:tag :div
- :attrs {:id "content" :class "edit"}
+ {:tag :form
+ :attrs {:id "content" :class "list"}
+ :content
+ [(big-link (str "Add a new " (pretty-name entity)) (editor-name entity application))
+ {:tag :table
+ :attrs {:caption (:name (:attrs entity))}
:content
- [:table {:caption (:name (:attrs entity))}
- [:thead
- [:tr
- (map
- #(vector :th (prompt %))
- (:fields list-spec))]
- [tr
- (map
- #(vector :th (prompt %))
- (:fields list-spec))]
- ]
- "{% for record in %records% %}"
- [:tr
- (map
- (fn [field]
- [:td (str "{% record." (:name (:attrs %)) " %}")])
- (:fields list-spec))
- [:td
- [:a
- {:href
- (str
- "view-or-edit-"
- (:name (:attrs entity))
- "?"
- (s/join
- "&"
- (map
- #(let [n (:name (:attrs %))]
- (str n "=record." n)))
- (children (first (filter #(= (:tag %) :key) (children entity))))))}
- View]]]
- "{% endfor %}"
- [:tfoot]]
- "{% if offset > 0 %}"
- [:div {:id "back-link-container"}
- [:a {:href "FIXME"}
- Previous]]
- "{% endif %}"
- [:div {:id "big-link-container"}
- [:a {:href "FIXME"}
- Next]]
- ]))
+ [
+ (list-thead list-spec)
+ (list-tbody list-spec entity application)
+ {:tag :tfoot}]}
+ "{% if offset > 0 %}"
+ (back-link "Previous" "FIXME")
+ "{% endif %}"
+ (big-link "Next" "FIXME")
+ (big-link (str "Add a new " (pretty-name entity)) (editor-name entity application))]})
-
-
- ]}))
-
-
-
(defn entity-to-templates
"Generate one or more templates for editing instances of this
`entity` in this `application`"
@@ -349,37 +433,91 @@
(merge
(if
forms
- (apply merge (map #(assoc {} (keyword (str "form-" (:name (:attrs entity)) "-" (:name (:attrs %))))
+ (apply merge (map #(assoc {} (keyword (path-part % entity application))
(form-to-template % entity application))
forms))
{(keyword (str "form-" (:name (:attrs entity))))
(form-to-template nil entity application)})
(if
pages
- (apply merge (map #(assoc {} (keyword (str "page-" (:name (:attrs entity)) "-" (:name (:attrs %))))
+ (apply merge (map #(assoc {} (keyword (path-part % entity application))
(page-to-template % entity application))
pages))
{(keyword (str "page-" (:name (:attrs entity))))
(page-to-template nil entity application)})
(if
lists
- (apply merge (map #(assoc {} (keyword (str "list-" (:name (:attrs entity)) "-" (:name (:attrs %))))
+ (apply merge (map #(assoc {} (keyword (path-part % entity application))
(list-to-template % entity application))
lists))
{(keyword (str "list-" (:name (:attrs entity))))
(form-to-template nil entity application)})))))
+
+(defn application-to-template
+ [application]
+ (let
+ [first-class-entities (filter
+ #(children-with-tag % :list)
+ (children-with-tag application :entity))]
+ {:application-index
+ {:tag :dl
+ :attrs {:class "index"}
+ :content
+ (apply
+ vector
+ (interleave
+ (map
+ #(hash-map
+ :tag :dt
+ :content
+ [{:tag :a
+ :attrs {:href (path-part :list % application)}
+ :content [(pretty-name %)]}])
+ first-class-entities)
+ (map
+ #(hash-map
+ :tag :dd
+ :content (apply
+ vector
+ (map
+ (fn [d]
+ (hash-map
+ :tag :p
+ :content (:content d)))
+ (children-with-tag % :documentation))))
+ first-class-entities)))}}))
+
+
+
(defn write-template-file
[filename template]
- (spit
- (str *output-path* filename)
- (s/join
- "\n"
- (list
- (file-header filename)
- (with-out-str (x/emit-element template))
- (file-footer filename)))))
+ (if
+ template
+ (try
+ (spit
+ (str *output-path* filename)
+ (s/join
+ "\n"
+ (list
+ (file-header filename)
+ (with-out-str
+ (x/emit-element template))
+ (file-footer filename))))
+ (catch Exception any
+ (spit
+ (str *output-path* filename)
+ (with-out-str
+ (println
+ (str
+ "<!-- Exception "
+ (.getName (.getClass any))
+ (.getMessage any)
+ " while printing "
+ filename "-->"))
+ (p/pprint template))))))
+ filename)
(defn to-selmer-templates
@@ -388,7 +526,7 @@
(let
[templates-map (reduce
merge
- {}
+ (application-to-template application)
(map
#(entity-to-templates % application)
(children application #(= (:tag %) :entity))))]
@@ -397,8 +535,15 @@
#(if
(templates-map %)
(let [filename (str (name %) ".html")]
- (write-template-file filename (templates-map %))))
- (keys templates-map)))
- templates-map))
+ (try
+ (write-template-file filename (templates-map %))
+ (catch Exception any
+ (str
+ "Exception "
+ (.getName (.getClass any))
+ (.getMessage any)
+ " while writing "
+ filename)))))
+ (keys templates-map)))))
diff --git a/src/adl/utils.clj b/src/adl/utils.clj
index de0cc44..f39d540 100644
--- a/src/adl/utils.clj
+++ b/src/adl/utils.clj
@@ -36,11 +36,9 @@
(keyword? (:tag element)) ;; it has a tag; it seems to be an XML element
(:content element)))
([element predicate]
- (remove ;; there's a more idionatic way of doing remove-nil-map, but for the moment I can't recall it.
- nil?
- (map
- #(if (predicate %) %)
- (children element)))))
+ (filter
+ predicate
+ (children element))))
(defn attributes
@@ -51,11 +49,9 @@
(keyword? (:tag element)) ;; it has a tag; it seems to be an XML element
(:attrs element)))
([element predicate]
- (remove ;; there's a more idionatic way of doing remove-nil-map, but for the moment I can't recall it.
- nil?
- (map
- #(if (predicate %) %)
- (:attrs element)))))
+ (filter
+ predicate
+ (attributes element))))
(defn typedef
@@ -140,13 +136,33 @@
(defn singularise
"Attempt to construct an idiomatic English-language singular of this string."
[string]
- (s/replace
+ (cond
+ (.endsWith string "ss") string
+ (.endsWith string "ise") string
+ true
(s/replace
(s/replace
- (s/replace string #"_" "-")
- #"s$" "")
- #"se$" "s")
- #"ie$" "y"))
+ (s/replace
+ (s/replace string #"_" "-")
+ #"s$" "")
+ #"se$" "s")
+ #"ie$" "y")))
+
+
+(defn capitalise
+ "Return a string like `s` but with each token capitalised."
+ [s]
+ (s/join
+ " "
+ (map
+ #(apply str (cons (Character/toUpperCase (first %)) (rest %)))
+ (s/split s #"[ \t\r\n]+"))))
+
+
+(defn pretty-name
+ [entity]
+ (capitalise (singularise (:name (:attrs entity)))))
+
(defn link-table?
@@ -159,26 +175,8 @@
(defn read-adl [url]
(let [adl (x/parse url)
valid? (valid-adl? adl)]
- adl))
-;; (if valid? adl
-;; (throw (Exception. (str (validate-adl adl)))))))
-
-(defn key-names [entity-map]
- (remove
- nil?
- (map
- #(:name (:attrs %))
- (vals (:content (:key (:content entity-map)))))))
-
-
-(defn has-primary-key? [entity-map]
- (> (count (key-names entity-map)) 0))
-
-
-(defn has-non-key-properties? [entity-map]
- (>
- (count (vals (:properties (:content entity-map))))
- (count (key-names entity-map))))
+ (if valid? adl
+ (throw (Exception. (str (validate-adl adl)))))))
(defn children-with-tag
@@ -186,6 +184,11 @@
[element tag]
(children element #(= (:tag %) tag)))
+(defmacro properties
+ "Return all the properties of this `entity`."
+ [entity]
+ `(children-with-tag ~entity :property))
+
(defn descendants-with-tag
"Return all descendants of this `element`, recursively, which have this `tag`."
[element tag]
@@ -199,8 +202,77 @@
(children element))))))
-(defn all-properties
- "Return all properties of this entity (including key properties)."
- [entity]
- (descendants-with-tag entity :property))
+(defn insertable?
+ "Return `true` it the value of this `property` may be set from user-supplied data."
+ [property]
+ (and
+ (= (:tag property) :property)
+ (not (= (:distinct (:attrs property)) "system"))))
+(defmacro all-properties
+ "Return all properties of this `entity` (including key properties)."
+ [entity]
+ `(descendants-with-tag ~entity :property))
+
+(defmacro insertable-properties
+ "Return all the properties of this `entity` (including key properties) into
+ which user-supplied data can be inserted"
+ [entity]
+ `(filter
+ insertable?
+ (all-properties ~entity)))
+
+(defmacro key-properties
+ [entity]
+ `(children-with-tag (first (children-with-tag ~entity :key)) :property))
+
+(defmacro insertable-key-properties
+ [entity]
+ `(filter insertable? (key-properties entity)))
+
+
+(defn key-names [entity]
+ (remove
+ nil?
+ (map
+ #(:name (:attrs %))
+ (key-properties entity))))
+
+
+(defn has-primary-key? [entity]
+ (> (count (key-names entity)) 0))
+
+
+(defn has-non-key-properties? [entity]
+ (>
+ (count (all-properties entity))
+ (count (key-properties entity))))
+
+
+(defn distinct-properties
+ [entity]
+ (filter
+ #(#{"system" "all"} (:distinct (:attrs %)))
+ (properties entity)))
+
+(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`
+ ADL element, or may be one of the keywords `:form`, `:list`, `:page` in which case the
+ first child of the `entity` of the specified type will be used."
+ [form entity application]
+ (cond
+ (and (map? form) (#{:list :form :page} (:tag form)))
+ (s/join
+ "-"
+ (flatten
+ (list
+ (name (:tag form)) (:name (:attrs entity)) (s/split (:name (:attrs form)) #"[ \n\r\t]+"))))
+ (keyword? form)
+ (path-part (first (children-with-tag entity form)) entity application)))
+
+(defn editor-name
+ "Return the path-part of the editor form for this `entity`. Note:
+ assumes the editor form is the first form listed for the entity."
+ [entity application]
+ (path-part :form entity application))
diff --git a/test/adl/utils_test.clj b/test/adl/utils_test.clj
new file mode 100644
index 0000000..cd9c083
--- /dev/null
+++ b/test/adl/utils_test.clj
@@ -0,0 +1,10 @@
+(ns adl.utils-test
+ (:require [clojure.string :as s]
+ [clojure.test :refer :all]
+ [adl.utils :refer :all]))
+
+(deftest singularise-tests
+ (testing "Singularise"
+ (is (= "address" (singularise "addresses")))
+ (is (= "address" (singularise "address")))
+ (is (= "expertise" (singularise "expertise")))))