From e98906c85e45e1f63a0aa9805de24477cf136f37 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 10 Jun 2018 21:05:02 +0100 Subject: [PATCH] Much progress! Many working! --- resources/transforms/adl2canonical.xslt | 3 + src/adl/to_hugsql_queries.clj | 212 +++++++------- src/adl/to_json_routes.clj | 1 - src/adl/to_selmer_routes.clj | 179 ++++++++++++ src/adl/to_selmer_templates.clj | 368 +++++++++++++++++------- src/adl/utils.clj | 150 +++++++--- test/adl/utils_test.clj | 10 + 7 files changed, 679 insertions(+), 244 deletions(-) create mode 100644 src/adl/to_selmer_routes.clj create mode 100644 test/adl/utils_test.clj 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 @@ + @@ -435,6 +436,7 @@ + @@ -454,6 +456,7 @@ + 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..551596c --- /dev/null +++ b/src/adl/to_selmer_routes.clj @@ -0,0 +1,179 @@ +(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 routes for user interface 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 parent-name ".db.core")) :as 'db) + (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 'let (vector 'p (list :form-params 'r)) + (list + 'layout/render + (list 'resolve-template (str n ".html")) + (merge + {:title (capitalise (:name (:attrs f))) + :params 'p} + (case (:tag f) + (:form :page) + {:record + (list + (symbol + (str "db/get-" (singularise (:name (:attrs e))))) + 'p)} + :list + {:records + (list + (symbol + (str + "db/search-" + (singularise (:name (:attrs e))))) + 'p)}))))))) + +(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) + (pprint '(defn index + [r] + (layout/render + (resolve-template + "application-index") + {:title "Administrative menu"}))) + (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..d69f9f6 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)))}]})) @@ -268,70 +328,109 @@ (defn page-to-template "Generate a template as specified by this `page` element for this `entity`, - taken from this `application`. If `page` is nill, generate a default page + taken from this `application`. If `page` is nil, generate a default page template for the entity." [page entity application] ) -(defn list-to-template + +(defn- list-thead + "Return a table head element for the list view for this `list-spec` of this `entity` within + this `application`. + + TODO: where entity fields are being shown/searched on, we should be using the user-distinct + fields of the far side, rather than key values" + [list-spec entity application] + {:tag :thead + :content + [{:tag :tr + :content + (apply + vector + (map + #(hash-map + :content [(prompt %)] + :tag :th) + (fields list-spec)))} + {:tag :tr + :content + (apply + vector + + (map + (fn [f] + (let [property (first + (children + entity + (fn [p] (and (= (:tag p) :property) + (= (:name (:attrs p)) (:property (:attrs f)))))))] + (hash-map + :tag :th + :content + [{:tag :input + :type (case (:type (:attrs property)) + ("integer" "real" "money") "number" + ("date" "timestamp") "date" + "time" "time" + "text") + :attrs {:id (:property (:attrs f)) + :name (:property (:attrs f)) + :value (str "{{ params." (:property (:attrs f)) " }}")}}]))) + (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 entity application) + (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 @@ -349,37 +448,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 + "")) + (p/pprint template)))))) + filename) (defn to-selmer-templates @@ -388,7 +541,7 @@ (let [templates-map (reduce merge - {} + (application-to-template application) (map #(entity-to-templates % application) (children application #(= (:tag %) :entity))))] @@ -397,8 +550,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")))))