Much progress! Many working!
This commit is contained in:
parent
538406b473
commit
398e3c3a6c
|
|
@ -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>
|
||||
|
|
|
|||
|
|
@ -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))))))))
|
||||
|
||||
|
|
|
|||
|
|
@ -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]))
|
||||
|
|
|
|||
152
src/adl/to_selmer_routes.clj
Normal file
152
src/adl/to_selmer_routes.clj
Normal file
|
|
@ -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)
|
||||
|
||||
|
|
@ -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)))))
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
10
test/adl/utils_test.clj
Normal file
10
test/adl/utils_test.clj
Normal file
|
|
@ -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")))))
|
||||
Loading…
Reference in a new issue