Much progress! Many working!

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>

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`"
+  "Generate an appropriate `where` clause for queries on this `entity`;
-  [entity]
+  if `properties` are passed, filter on those properties, otherwise the key
-  (let
+  properties."
-    [entity-name (:name (:attrs entity))]
+  ([entity]
-    (str
+   (where-clause entity (key-properties entity)))
-      "WHERE " entity-name "."
+  ([entity properties]
-      (s/join
+   (let
-        (str " AND\n\t" entity-name ".")
+     [entity-name (:name (:attrs entity))
-        (map #(str % " = " (keyword %)) (key-names 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
+        insertable-property-names (map #(:name (:attrs %)) (insertable-properties entity))
-                                    #(:name (:attrs %))
-                                    (filter
-                                      #(not (= (:distinct (:attrs %)) "system"))
-                                      (all-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
+          property-names (map #(:name (:attrs %)) (insertable-properties entity))
-                           nil?
-                           (map
-                             #(if (= (:tag %) :property) (:name (:attrs %)))
-                             (vals (:properties (:content 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))
+        properties (all-properties entity)]
-        string-fields (filter
+    (hash-map
-                        #(= (-> % :attrs :type) "string")
+      (keyword query-name)
-                        (children entity #(= (:tag %) :property)))]
+      {:name query-name
-    (if
+       :signature signature
-      (empty? string-fields)
+       :entity entity
-      {}
+       :type :text-search
-      (hash-map
+       :query
-        (keyword query-name)
+       (s/join
-        {:name query-name
+         "\n"
-         :signature signature
+         (remove
-         :entity entity
+           empty?
-         :type :text-search
+           (list
-         :query
+             (str "-- :name " query-name " " signature)
-         (s/join
+             (str
-           "\n"
+               "-- :doc selects existing "
-           (remove
+               pretty-name
-             empty?
+               " records having any string field matching `:pattern` by substring match")
-             (list
+             (str "SELECT * FROM " entity-name)
-               (str "-- :name " query-name " " signature)
+             "WHERE "
-               (str
+             (s/join
-                 "-- :doc selects existing "
+               "\n\tOR "
-                 pretty-name
+               (filter
-                 " records having any string field matching `:pattern` by substring match")
+                 string?
-               (str "SELECT * FROM " entity-name)
-               "WHERE "
-               (s/join
-                 "\n\tOR "
                  (map
-                   #(str (-> % :attrs :name) " LIKE '%:pattern%'")
+                   #(if
-                   string-fields))
+                      (#{"string" "date" "text"} (:type (:attrs %)))
-               (order-by-clause entity)
+                      (str (-> % :attrs :name) " LIKE '%:pattern%'"))
-               "--~ (if (:offset params) \"OFFSET :offset \")"
+                   properties)))
-               "--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")")))}))))
+             (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
+  ([entity properties]
-    (has-primary-key? entity)
+   (if
-    (let [entity-name (:name (:attrs entity))
+     (not (empty? properties))
-          pretty-name (singularise entity-name)
+     (let [entity-name (:name (:attrs entity))
-          query-name (str "get-" pretty-name)
+           pretty-name (singularise entity-name)
-          signature ":? :1"]
+           query-name (if (= properties (key-properties entity))
-      (hash-map
+                        (str "get-" pretty-name)
-        (keyword query-name)
+                        (str "get-" pretty-name "-by-" (s/join "=" (map #(:name (:attrs %)) properties))))
-        {:name query-name
+           signature ":? :1"]
-         :signature signature
+       (hash-map
-         :entity entity
+         (keyword query-name)
-         :type :select-1
+         {:name query-name
-         :query
+          :signature signature
-         (s/join
+          :entity entity
-           "\n"
+          :type :select-1
-           (remove
+          :query
-             empty?
+          (s/join
-             (list
+            "\n"
-               (str "-- :name " query-name " " signature)
+            (remove
-               (str "-- :doc selects an existing " pretty-name " record")
+              empty?
-               (str "SELECT * FROM " entity-name)
+              (list
-               (where-clause entity)
+                (str "-- :name " query-name " " signature)
-               (order-by-clause entity))))}))
+                (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`."
+  "Generate all standard queries for this `entity` in this `application`; if
-  [entity application]
+  no entity is specified, generate all queris for the application."
-  (merge
+  ([application entity]
-    {}
+   (merge
-    (insert-query entity)
+     {}
-    (update-query entity)
+     (insert-query entity)
-    (delete-query entity)
+     (update-query entity)
-    (if
+     (delete-query entity)
-      (link-table? entity)
+     (if
-      (link-table-queries entity application)
+       (link-table? entity)
-      (merge
+       (link-table-queries entity application)
-        (select-query entity)
+       {})
-        (list-query entity)
+     (select-query entity)
-        (search-query entity)
+     (list-query entity)
-        (foreign-queries entity application)))))
+     (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
+                (queries application))))))))
-                  merge
-                  (map
-                    #(queries % application)
-                    (children
-                      application
-                      (fn [child] (= (:tag child) :entity))))))))))))
 

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]))

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)
+

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]
+  ([field-or-property form entity application]
-  (or
+   (prompt field-or-property))
-    (first
+  ([field-or-property]
-      (children
+   (or
-        field-or-property
+     (first
-        #(and
+       (children
-           (= (:tag %) :prompt)
+         field-or-property
-           (= (:locale :attrs %) *locale*))))
+         #(and
-    (:name (:attrs field-or-property))))
+            (= (: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"
+                 (str "{% ifwritable " (:name (:attrs entity)) " " (:name (:attrs property)) " %}")
-                 (if
+                 (cond
                    select?
-                   {:tag :select
+                   (select-widget property form entity application)
-                    :attrs {:id widget-name
+                   true
-                            :name widget-name}
-                    :content (get-options property form entity application)}
                    {: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 %}"
+                 "{% endifreadable %}"
-                 "{% endif %}"]})))
+                 "{% 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))))
+                 (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)))]
     {: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 :form
-    [:tag :div
+   :attrs {:id "content" :class "list"}
-     :attrs {:id "content" :class "edit"}
+   :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
+       (list-thead list-spec)
-       [:tr
+       (list-tbody list-spec entity application)
-        (map
+       {:tag :tfoot}]}
-         #(vector :th (prompt %))
+    "{% if offset > 0 %}"
-         (:fields list-spec))]
+    (back-link "Previous" "FIXME")
-       [tr
+    "{% endif %}"
-        (map
+    (big-link "Next" "FIXME")
-         #(vector :th (prompt %))
+    (big-link (str "Add a new " (pretty-name entity)) (editor-name entity application))]})
-         (: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]]
-     ]))
 
 
 
 
-
-
-        ]}))
-
-
-
 (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
+  (if
-    (str *output-path* filename)
+    template
-    (s/join
+    (try
-      "\n"
+      (spit
-      (list
+        (str *output-path* filename)
-        (file-header filename)
+        (s/join
-        (with-out-str (x/emit-element template))
+          "\n"
-        (file-footer filename)))))
+          (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 %))))
+             (try
-        (keys templates-map)))
+               (write-template-file filename (templates-map %))
-    templates-map))
+               (catch Exception any
+                 (str
+                   "Exception "
+                   (.getName (.getClass any))
+                   (.getMessage any)
+                   " while writing "
+                   filename)))))
+        (keys templates-map)))))
 
 

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.
+   (filter
-       nil?
+     predicate
-       (map
+     (children element))))
-         #(if (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.
+   (filter
-       nil?
+     predicate
-       (map
+     (attributes element))))
-         #(if (predicate %) %)
-         (:attrs 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/replace
-        #"s$" "")
+          (s/replace string #"_" "-")
-      #"se$" "s")
+          #"s$" "")
-    #"ie$" "y"))
+        #"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
-;;     (if valid? adl
+      (throw (Exception. (str (validate-adl 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))))
 
 
 (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
+(defn insertable?
-  "Return all properties of this entity (including key properties)."
+  "Return `true` it the value of this `property` may be set from user-supplied data."
-  [entity]
+  [property]
-  (descendants-with-tag entity :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))

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")))))