#7: Sort of done.

Not proud of this. It prints errors to STDOUT, but does not return a sensible value. However, it will do for now.

.gitignore

@@ -10,3 +10,11 @@ target/
 \.lein-failures
 
 *.dump
+
+queries\.auto\.sql
+
+auto_json_routes\.clj
+
+\.idea/
+
+*.iml

project.clj

@@ -1,9 +1,10 @@
-(defproject squirrel-parse "0.1.1"
+(defproject squirrel-parse "0.1.1-SNAPSHOT"
   :description "A library for parsing SQL"
   ;; :url "http://example.com/FIXME"
   :license {:name "GNU General Public License,version 2.0 or (at your option) any later version"
             :url "https://www.gnu.org/licenses/old-licenses/gpl-2.0.en.html"}
   :dependencies [[org.clojure/clojure "1.8.0"]
                  [org.clojure/math.combinatorics "0.1.4"]
+                 [bouncer "1.0.1"]
                  [clj-time "0.14.2"]
                  [instaparse "1.4.8"]])

src/squirrel_parse/to_adl.clj

@@ -115,7 +115,7 @@
           {:tag :prompt
            :attrs
            {:prompt name
-            :local "en-GB"}}}}}})))
+            :locale "en-GB"}}}}}})))
 
 
 (defn make-entity-map [table-decl]

src/squirrel_parse/to_hugsql_queries.clj

@@ -4,6 +4,8 @@
   (: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]
             [squirrel-parse.to-adl :refer [migrations-to-xml]]
             [squirrel-parse.utils :refer [is-link-table? singularise]]))
 
@@ -52,10 +54,18 @@
 
 (defn insert-query [entity-map]
   (let [entity-name (:name (:attrs entity-map))
-        pretty-name (s/replace (s/replace entity-name #"_" "-") #"s$" "")
+        pretty-name (singularise entity-name)
         all-property-names (map #(:name (:attrs %)) (vals (:properties (:content entity-map))))
-        ]
+        query-name (str "create-" pretty-name "!")
-    (str "-- :name create-" pretty-name "! :<!\n"
+        signature " :! :n"]
+    (hash-map
+      (keyword query-name)
+      {:name query-name
+       :signature signature
+       :entity entity-map
+       :type :insert-1
+       :query
+       (str "-- :name " query-name " " signature "\n"
             "-- :doc creates a new " pretty-name " record\n"
             "INSERT INTO " entity-name " ("
             (s/join ",\n\t" all-property-names)
@@ -65,7 +75,7 @@
             (if
               (has-primary-key? entity-map)
               (str "\nreturning " (s/join ",\n\t" (key-names entity-map))))
-         "\n\n")))
+            "\n\n")})))
 
 
 (defn update-query [entity-map]
@@ -74,64 +84,144 @@
       (has-primary-key? entity-map)
       (has-non-key-properties? entity-map))
     (let [entity-name (:name (:attrs entity-map))
-          pretty-name (s/replace (s/replace entity-name #"_" "-") #"s$" "")
+          pretty-name (singularise entity-name)
           property-names (remove
                            nil?
                            (map
                              #(if (= (:tag %) :property) (:name (:attrs %)))
-                             (vals (:properties (:content entity-map)))))]
+                             (vals (:properties (:content entity-map)))))
-      (str "-- :name update-" pretty-name "! :! :n\n"
+          query-name (str "update-" pretty-name "!")
+          signature ":! :n"]
+      (hash-map
+        (keyword query-name)
+        {:name query-name
+         :signature signature
+         :entity entity-map
+         :type :update-1
+         :query
+         (str "-- :name " query-name " " signature "\n"
               "-- :doc updates an existing " pretty-name " record\n"
               "UPDATE " entity-name "\n"
               "SET "
               (s/join ",\n\t" (map #(str % " = " (keyword %)) property-names))
               "\n"
               (where-clause entity-map)
-           "\n\n"))))
+              "\n\n")}))
+    {}))
+
+
+(defn search-query [entity-map]
+  (let [entity-name (:name (:attrs entity-map))
+        pretty-name (singularise entity-name)
+        query-name (str "search-strings-" pretty-name)
+        signature ":? :1"
+        string-fields (filter
+                       #(= (-> % :attrs :type) "string")
+                       (-> entity-map :content :properties vals))]
+    (if
+      (empty? string-fields)
+      {}
+      (hash-map
+       (keyword query-name)
+       {:name query-name
+        :signature signature
+        :entity entity-map
+        :type :text-search
+        :query
+        (str "-- :name " query-name " " signature "\n"
+             "-- :doc selects existing " entity-name " records having any string field matching `:pattern` by substring match\n"
+             "SELECT * FROM " entity-name "\n"
+             "WHERE "
+             (s/join
+              "\n\tOR "
+              (map
+               #(str (-> % :attrs :name) " LIKE '%:pattern%'")
+               string-fields))
+             "\n"
+             (order-by-clause entity-map)
+             "\n"
+            "--~ (if (:offset params) \"OFFSET :offset \") \n"
+            "--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")"
+             "\n\n")}))))
 
 
 (defn select-query [entity-map]
   (if
     (has-primary-key? entity-map)
     (let [entity-name (:name (:attrs entity-map))
-          pretty-name (s/replace (s/replace entity-name #"_" "-") #"s$" "")]
+          pretty-name (singularise entity-name)
-      (str "-- :name get-" pretty-name " :? :1\n"
+          query-name (str "get-" pretty-name)
+          signature ":? :1"]
+      (hash-map
+        (keyword query-name)
+        {:name query-name
+         :signature signature
+         :entity entity-map
+         :type :select-1
+         :query
+         (str "-- :name " query-name " " signature "\n"
               "-- :doc selects an existing " pretty-name " record\n"
               "SELECT * FROM " entity-name "\n"
               (where-clause entity-map)
               "\n"
               (order-by-clause entity-map)
-           "\n\n"))))
+              "\n\n")}))
+    {}))
 
 
-(defn list-query [entity-map]
+(defn list-query
+  "Generate a query to list records in the table represented by this `entity-map`.
+  Parameters `:limit` and `:offset` may be supplied. If not present limit defaults
+  to 100 and offset to 0."
+  [entity-map]
   (let [entity-name (:name (:attrs entity-map))
-        pretty-name (s/replace (s/replace entity-name #"_" "-") #"s$" "")]
+        pretty-name (singularise entity-name)
-    (str "-- :name list-" pretty-name " :? :*\n"
+        query-name (str "list-" entity-name)
+        signature ":? :*"]
+    (hash-map
+      (keyword query-name)
+      {:name query-name
+       :signature signature
+       :entity entity-map
+       :type :select-many
+       :query
+       (str "-- :name " query-name " " signature "\n"
             "-- :doc lists all existing " pretty-name " records\n"
             "SELECT * FROM " entity-name "\n"
-         (order-by-clause entity-map)
+            (order-by-clause entity-map) "\n"
-         "\n\n")))
+            "--~ (if (:offset params) \"OFFSET :offset \") \n"
+            "--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")"
+            "\n\n")})))
 
 
 (defn foreign-queries [entity-map entities-map]
   (let [entity-name (:name (:attrs entity-map))
-        pretty-name (s/replace (s/replace entity-name #"_" "-") #"s$" "")
+        pretty-name (singularise entity-name)
         links (filter #(-> % :attrs :entity) (-> entity-map :content :properties vals))]
     (apply
-      str
+      merge
       (map
         #(let [far-name (-> % :attrs :entity)
                far-entity ((keyword far-name) entities-map)
                pretty-far (s/replace (s/replace far-name #"_" "-") #"s$" "")
                farkey (-> % :attrs :farkey)
-               link-field (-> % :attrs :name)]
+               link-field (-> % :attrs :name)
-           (str "-- :name list-" entity-name "-by-" pretty-far " :? :*\n"
+               query-name (str "list-" entity-name "-by-" pretty-far)
+               signature ":? :*"]
+           (hash-map
+             (keyword query-name)
+             {:name query-name
+              :signature signature
+              :entity entity-map
+              :type :select-one-to-many
+              :far-entity far-entity
+              :query
+              (str "-- :name " query-name " " signature "\n"
                    "-- :doc lists all existing " pretty-name " records related to a given " pretty-far "\n"
                    "SELECT * \nFROM " entity-name "\n"
                    "WHERE " entity-name "." link-field " = :id\n"
                    (order-by-clause entity-map)
-                "\n\n"))
+                   "\n\n")}))
         links))))
 
 
@@ -145,16 +235,26 @@
         near-name (-> near :attrs :name)
         link-name (-> link :attrs :name)
         far-name (-> far :attrs :name)
-        pretty-far (singularise far-name)]
+        pretty-far (singularise far-name)
-    (println links)
+        query-name (str "list-" link-name "-" near-name "-by-" pretty-far)
-    (str "-- :name list-" link-name "-" near-name "-by-" pretty-far " :? :*\n"
+        signature ":? :*"]
+    (hash-map
+      (keyword query-name)
+      {:name query-name
+       :signature signature
+       :entity link
+       :type :select-many-to-many
+       :near-entity near
+       :far-entity far
+       :query
+       (str "-- :name " query-name " " signature " \n"
             "-- :doc lists all existing " near-name " records related through " link-name " to a given " pretty-far "\n"
             "SELECT "near-name ".*\n"
             "FROM " near-name ", " link-name "\n"
             "WHERE " near-name "." (first (key-names near)) " = " link-name "." (-> (links (keyword near-name)) :attrs :name) "\n\t"
             "AND " link-name "." (-> (links (keyword far-name)) :attrs :name) " = :id\n"
             (order-by-clause near)
-         "\n\n")))
+            "\n\n")})))
 
 
 (defn link-table-queries [entity-map entities-map]
@@ -164,9 +264,9 @@
                 (remove nil? (map #(-> % :attrs :entity) (-> entity-map :content :properties vals))))
      pairs (combinations entities 2)]
     (apply
-      str
+      merge
       (map
-        #(str
+        #(merge
            (link-table-query (nth % 0) entity-map (nth % 1))
            (link-table-query (nth % 1) entity-map (nth % 0)))
         pairs))))
@@ -177,26 +277,37 @@
   (if
     (has-primary-key? entity-map)
     (let [entity-name (:name (:attrs entity-map))
-          pretty-name (s/replace (s/replace entity-name #"_" "-") #"s$" "")]
+          pretty-name (singularise entity-name)
-      (str "-- :name delete-" pretty-name "! :! :n\n"
+          query-name (str "delete-" pretty-name "!")
+          signature ":! :n"]
+      (hash-map
+        (keyword query-name)
+        {:name query-name
+         :signature signature
+         :entity entity-map
+         :type :delete-1
+         :query
+         (str "-- :name " query-name " " signature "\n"
               "-- :doc updates an existing " pretty-name " record\n"
               "DELETE FROM " entity-name "\n"
               (where-clause entity-map)
-           "\n\n"))))
+              "\n\n")}))))
 
 
 (defn queries
   [entity-map entities-map]
-  (str
+  (merge
+    {}
     (insert-query entity-map)
     (update-query entity-map)
     (delete-query entity-map)
     (if
       (is-link-table? entity-map)
       (link-table-queries entity-map entities-map)
-      (str
+      (merge
         (select-query entity-map)
         (list-query entity-map)
+        (search-query entity-map)
         (foreign-queries entity-map entities-map)))))
 
 
@@ -206,6 +317,24 @@
   ([migrations-path output]
    (let
      [adl-struct (migrations-to-xml migrations-path "Ignored")
-      file-content (apply str (map #(queries % adl-struct) (vals adl-struct)))]
+      file-content (apply
+                    str
+                    (cons
+                     (str "-- "
+                          output
+                          " autogenerated by \n-- [squirrel-parse](https://github.com/simon-brooke/squirrel-parse)\n-- at "
+                          (f/unparse (f/formatters :basic-date-time) (t/now))
+                          "\n\n")
+                     (doall
+                      (map
+                       #(:query %)
+                       (sort
+                        #(compare (:name %1) (:name %2))
+                        (vals
+                         (apply
+                          merge
+                          (map
+                           #(queries % adl-struct)
+                           (vals adl-struct)))))))))]
      (spit output file-content)
      file-content)))

src/squirrel_parse/to_json_routes.clj

@@ -0,0 +1,242 @@
+(ns ^{:doc "A parser for SQL: generate JSON routes."
+      :author "Simon Brooke"}
+  squirrel-parse.to-json-routes
+  (:require [clojure.java.io :refer [file]]
+            [clojure.math.combinatorics :refer [combinations]]
+            [clojure.pprint :refer [pprint write]]
+            [clojure.string :as s]
+            [clj-time.core :as t]
+            [clj-time.format :as f]
+            [squirrel-parse.to-adl :refer [migrations-to-xml]]
+            [squirrel-parse.to-hugsql-queries :refer [queries]]
+            [squirrel-parse.utils :refer [is-link-table? singularise]]))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;
+;;;; squirrel-parse.to-json-routes: generate JSON routes.
+;;;;
+;;;; 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
+;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; The overall structure of this has quite closely to follow the structure of
+;;; to-hugsql-queries, because essentially we need one JSON entry point to wrap
+;;; each query.
+
+(defn file-header [parent-name this-name]
+  (list
+    'ns
+    (symbol (str parent-name ".routes." this-name))
+    (str "JSON routes for " parent-name
+         " auto-generated by [squirrel-parse](https://github.com/simon-brooke/squirrel-parse) 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))))
+
+
+(defn make-safe-name [string]
+  (s/replace string #"[^a-zA-Z0-9-]" ""))
+
+
+(defn declarations [handlers-map]
+  (cons 'declare (sort (map #(symbol (make-safe-name (name %))) (keys handlers-map)))))
+
+
+(defn generate-handler-src
+  [handler-name query-map method doc]
+  (hash-map
+    :method method
+    :src
+    (remove
+    nil?
+    (list
+      'defn
+      handler-name
+      (str "Auto-generated method to " doc)
+      [{:keys ['params]}]
+      (list 'do (list (symbol (str "db/" (:name query-map))) 'params))
+      (case
+        (:type query-map)
+        (:delete-1 :update-1)
+        '(response/found "/")
+        nil)))))
+
+
+(defn handler
+  "Generate declarations for handlers from query with this `query-key` in this `queries-map` taken from within
+  this `entities-map`. This method must follow the structure of
+  `to-hugsql-queries/queries` quite closely, because we must generate the same names."
+  [query-key queries-map entities-map]
+  (let [query (query-key queries-map)
+        handler-name (symbol (make-safe-name (name query-key)))]
+    (hash-map
+      (keyword handler-name)
+      (merge
+        {:name handler-name
+         :route (str "/json/" handler-name)}
+        (case
+          (:type query)
+          :delete-1
+          (generate-handler-src
+            handler-name query :post
+            (str "delete one record from the `"
+                 (-> query :entity :attrs :name)
+                 "` table. Expects the following key(s) to be present in `params`: `"
+                 (doall (-> query :entity :content :key :content keys))
+                 "`."))
+          :insert-1
+          (generate-handler-src
+            handler-name query :post
+            (str "insert one record to the `"
+                 (-> query :entity :attrs :name)
+                 "` table. Expects the following key(s) to be present in `params`: `"
+                 (pr-str (-> query :entity :content :properties keys))
+                 "`. Returns a map containing the keys `"
+                 (pr-str (-> query :entity :content :key :content keys))
+                 "` identifying the record created."))
+          :update-1
+          (generate-handler-src
+            handler-name query :post
+            (str "update one record in the `"
+                 (-> query :entity :attrs :name)
+                 "` table. Expects the following key(s) to be present in `params`: `"
+                 (pr-str
+                   (distinct
+                     (sort
+                       (flatten
+                         (cons
+                           (-> query :entity :content :properties keys)
+                           (-> query :entity :content :key :content keys))))))
+                 "`."))
+          :select-1
+          (generate-handler-src
+            handler-name query :post
+            (str "select one record from the `"
+                 (-> query :entity :attrs :name)
+                 "` table. Expects the following key(s) to be present in `params`: `"
+                 (pr-str (-> query :entity :content :key :content keys))
+                 "`. Returns a map containing the following keys: `"
+                 (pr-str
+                   (distinct
+                     (sort
+                       (flatten
+                         (cons
+                           (-> query :entity :content :properties keys)
+                           (-> query :entity :content :key :content keys))))))
+                 "`."))
+          :select-many
+          (generate-handler-src
+            handler-name query :get
+            (str "select all records from the `"
+                 (-> query :entity :attrs :name)
+                 "` table. If the keys `(:limit :offset)` are present in the request then they will be used to page through the data. Returns a sequence of maps each containing the following keys: `"
+                 (pr-str
+                   (distinct
+                     (sort
+                       (flatten
+                         (cons
+                           (-> query :entity :content :properties keys)
+                           (-> query :entity :content :key :content keys))))))
+                 "`."))
+          :text-search
+          (generate-handler-src
+            handler-name query :get
+            (str "select all records from the `"
+                 (-> query :entity :attrs :name)
+                 "` table with any text field matching the value of the key `:pattern` which should be in the request. If the keys `(:limit :offset)` are present in the request then they will be used to page through the data. Returns a sequence of maps each containing the following keys: `"
+                 (pr-str
+                   (distinct
+                     (sort
+                       (flatten
+                         (cons
+                           (-> query :entity :content :properties keys)
+                           (-> query :entity :content :key :content keys))))))
+                 "`."))
+          (:select-many-to-many
+           :select-one-to-many)
+          (hash-map :method :get
+                    :src (list 'defn handler-name [{:keys ['params]}]
+                               (list 'do (list (symbol (str "db/" (:name query))) 'params))))
+          ;; default
+          (hash-map
+            :src
+            (str ";; don't know what to do with query `" :key "` of type `" (:type query) "`.")))))))
+
+
+(defn defroutes [handlers-map]
+  (cons
+    'defroutes
+    (cons
+      'auto-rest-routes
+      (map
+        #(let [handler (handlers-map %)]
+           (list
+             (symbol (s/upper-case (name (:method handler))))
+             (str "/json/auto/" (:name handler))
+             'request
+              (list
+                'route/restricted
+               (list (:name handler) 'request))))
+        (sort
+          (keys handlers-map))))))
+
+
+(defn migrations-to-json-routes
+  ([migrations-path parent-namespace-name]
+   (migrations-to-json-routes migrations-path parent-namespace-name "auto-json-routes"))
+  ([migrations-path parent-namespace-name namespace-name]
+   (let [output (str (s/replace namespace-name #"-" "_") ".clj")
+         adl-struct (migrations-to-xml migrations-path "Ignored")
+         q (reduce
+             merge
+             {}
+             (map
+               #(queries % adl-struct)
+               (vals adl-struct)))
+         h (reduce
+             merge
+             {}
+             (map
+               #(handler % q adl-struct)
+               (keys q)))
+         f (cons
+             (file-header parent-namespace-name namespace-name)
+             ;;                          (pre-declare
+             (cons
+               (declarations h)
+               (cons
+                 (defroutes h)
+                 (map #(:src (h %)) (sort (keys h))))))]
+     (spit
+       output
+       (with-out-str
+         (doall
+           (for [expr f]
+             (do
+               (pprint expr)
+               (print "\n\n"))))))
+     f
+     )))

src/squirrel_parse/utils.clj

@@ -213,5 +213,5 @@
 
 
 (defn singularise [string]
-  (s/replace (s/replace string #"_" "-") #"s$" ""))
+  (s/replace (s/replace (s/replace string #"_" "-") #"s$" "") #"ie$" "y"))
 

src/squirrel_parse/validator.clj

@@ -0,0 +1,663 @@
+(ns ^{:doc "A parser for SQL: validator for ADL structure."
+      :author "Simon Brooke"}
+  squirrel-parse.validator
+  (:require [clojure.set :refer [union]]
+            [bouncer.core :as b]
+            [bouncer.validators :as v]))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;
+;;;; squirrel-parse.to-adl: validate Application Description Language.
+;;;;
+;;;; 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
+;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+(defn disjunct-validate
+  ;; OK, so: most of the validators will (usually) fail, and that's OK. How
+  ;; do we identify the one which ought not to have failed?
+  [o & validations]
+  (println (str "Tag: " (:tag o) "; name: " (:name (:attrs o))))
+  (let
+    [rs (map
+         #(b/validate o %)
+         validations)
+     all-candidates (remove nil? (map first rs))
+     suspicious (remove :tag all-candidates)]
+    ;; if *any* succeeded, we succeeded
+    ;; otherwise, one of these is the valid error - but which? The answer, in my case
+    ;; is that if there is any which did not fail on the :tag check, then that is the
+    ;; interesting one. But generally?
+    (doall (map #(println (str "\tError: " %)) suspicious))
+    (empty? suspicious)))
+
+(v/defvalidator disjunct-validator
+  ;; OK, so: most of the validators will (usually) fail, and that's OK. How
+  ;; do we identify the one which ought not to have failed?
+  {:optional false}
+  [value & validations]
+  (let
+    [rs (map
+         #(b/validate value %)
+         validations)]
+    ;; if *any* succeeded, we succeeded
+    ;; otherwise, one of these is the valid error - but which? The answer, in my case
+    ;; is that if there is any which did not fail on the :tag check, then that is the
+    ;; interesting one. But generally?
+    (empty? (remove :tag (map first rs)))))
+
+;;; the remainder of this file is a fairly straight translation of the ADL 1.4 DTD into Clojure
+
+
+(declare fieldgroup-validations)
+
+(def permissions
+  "permissions a group may have on an entity, list, page, form or field
+	permissions are deemed to increase as you go right. A group cannot
+	have greater permission on a field than on the form it is in, or
+	greater permission on form than the entity it belongs to
+
+	* `none`:			none
+	* `read`:			select
+	* `insert`:			insert
+	* `noedit`:			select, insert
+	* `edit`:			select, insert, update
+	* `all`:			select, insert, update, delete"
+  #{"none", "read", "insert", "noedit", "edit", "all"})
+
+(def cascade-actions
+  "actions which should be cascaded to dependent objects. All these values except
+  'manual' are taken from Hibernate and should be passed through the adl2hibernate
+  mapping transparently. Relevent only for properties with type='entity', type='link'
+  and type='list'
+
+  * `all`:       cascade delete, save and update
+  * `all-delete-orphan`: see hibernate documentation; relates to transient objects only
+  * `delete`:    cascade delete actions, but not save and update
+  * `manual`:    cascading will be handled in manually managed code, code to
+              handle cascading should not be generated
+  * `save-update`: cascade save and update actions, but not delete."
+  #{"all", "all-delete-orphan", "delete", "manual", "save-update"})
+
+(def defineable-data-types
+	"data types which can be used in a typedef to provide validation -
+	e.g. a string can be used with a regexp or a scalar can be used with
+	min and max values
+	* `string`: 		varchar		java.sql.Types.VARCHAR
+	* `integer`:		int			java.sql.Types.INTEGER
+	* `real`:			double		java.sql.Types.DOUBLE
+	* `money`:			money		java.sql.Types.INTEGER
+	* `date`:			date		java.sql.Types.DATE
+	* `time`:			time		java.sql.Types.TIME
+	* `timestamp`:		timestamp	java.sql.Types.TIMESTAMP
+	* `uploadable`:		varchar		java.sql.Types.VARCHAR
+	* `image`:			varchar		java.sql.Types.VARCHAR
+
+	uploadable is as string but points to an uploaded file; image is as
+	uploadable but points to an uploadable graphical image file."
+  #{"string", "integer", "real", "money", "date", "time", "timestamp", "uploadable"})
+
+(def simple-data-types
+  "data types which are fairly straightforward translations of JDBC data types
+  * `boolean`:		boolean 	java.sql.Types.BIT or char(1)		  java.sql.Types.CHAR
+  * `text`:			  text or		  java.sql.Types.LONGVARCHAR
+  memo		    java.sql.Types.CLOB"
+  (union
+    defineable-data-types
+    #{"boolean" "text"}))
+
+(def complex-data-types
+  "data types which are more complex than SimpleDataTypes...
+	* `entity` : 		a foreign key link to another entity (i.e. the 'many' end of a
+					    one-to-many link);
+	* `list` :			a list of some other entity that links to me (i.e. the 'one' end of
+					    a one-to-many link);
+	* `link` : 			a many to many link (via a link table);
+	* `defined` : 	a type defined by a typedef."
+  #{"entity", "link", "list", "defined"})
+
+(def special-data-types
+  "data types which require special handling - which don't simply map onto
+  common SQL data types
+  * `geopos` :    a latitude/longitude pair (experimental and not yet implemented)
+  * `image` :     a raster image file, in jpeg, gif, or png format (experimental, not yet implemented)
+  * `message` :   an internationalised message, having different translations for different locales"
+  #{"geopos", "image", "message"})
+
+(def all-data-types (union
+                     simple-data-types
+                     complex-data-types
+                     special-data-types))
+
+(def content
+  "content, for things like pages (i.e. forms, lists, pages)"
+  #{"head", "top", "foot"})
+
+(def field-stuff #{"field", "fieldgroup", "auxlist", "verb"})
+
+(def page-content (union content field-stuff))
+
+(def page-stuff (union page-content #{"permission", "pragma"}))
+
+(def generator-actions #{"assigned", "guid", "manual", "native"})
+
+(def sequences #{"canonical", "reverse-canonical"})
+
+(def specification-validations
+  {:tag [v/required [#(= % :specification)]]})
+
+(def documentation-validations
+  "contains documentation on the element which immediately contains it. TODO:
+  should HTML markup within a documentation element be allowed? If so, are
+  there restrictions?"
+  {:tag [v/required [#(= % :documentation)]]})
+
+(def content-validations
+  {:tag [v/required [#(= % :content)]]})
+
+(def help-validations
+	"helptext about a property of an entity, or a field of a page, form or
+	list, or a typedef. Typically there will be only one of these per property
+  per locale; if there are more than one all those matching the locale may
+  be concatenated, or just one may be used.
+
+	* `locale`:			the locale in which to prefer this prompt"
+  {:tag [v/required [#(= % :help)]]
+   [:attrs :locale] [v/string v/required [v/matches #"[a-z]{2}-[A-Z]{2}"]]})
+
+(def ifmissing-validations
+  "helpful text to be shown if a property value is missing, typically when
+  a form is submitted. Typically there will be only one of these per property
+  per locale; if there are more than one all those matching the locale may
+  be concatenated, or just one may be used. Later there may be more sophisticated
+  behaviour here.
+
+	* `locale`:			the locale in which to prefer this prompt"
+  {:tag [v/required [#(= % :if-missing)]]
+   [:attrs :locale] [v/string v/required [v/matches #"[a-z]{2}-[A-Z]{2}"]]})
+
+(def param-validations
+  "A parameter passed to the generator. Again, based on the Hibernate
+  implementation.
+
+  * `name`:   the name of this parameter."
+  {:tag [v/required [#(= % :param)]]
+   [:attrs :name] [v/string v/required]})
+
+
+(def permission-validations
+  "permissions policy on an entity, a page, form, list or field
+
+	* `group`: 			the group to which permission is granted
+	* `permission`:		the permission which is granted to that group."
+  {:tag [v/required [#(= % :permission)]]
+   [:attrs :group] [v/string v/required] ;; TODO: and it must be the name of a group that has already been defined.
+   [:attrs :permission] [v/required [v/matches permissions]]})
+
+
+(def prompt-validations
+	"a prompt for a property or field; used as the prompt text for a widget
+	which edits it. Typically there will be only one of these per property
+  per locale; if there are more than one all those matching the locale may
+  be concatenated, or just one may be used.
+
+	* `prompt`:			the prompt to use
+	* `locale`:			the locale in which to prefer this prompt."
+  {:tag [v/required [#(= % :prompt)]]
+   [:attrs :prompt] [v/string v/required]
+   [:attrs :locale] [v/string v/required [v/matches #"[a-z]{2}-[A-Z]{2}"]]})
+
+(def ifmissing-validations
+	"helpful text to be shown if a property value is missing, typically when
+  a form is submitted. Typically there will be only one of these per property
+  per locale; if there are more than one all those matching the locale may
+  be concatenated, or just one may be used. Later there may be more sophisticated
+  behaviour here.
+
+	* `locale`:			the locale in which to prefer this prompt."
+  {:tag [v/required [#(= % :ifmissing)]]
+   [:attrs :locale] [v/string v/required [v/matches #"[a-z]{2}-[A-Z]{2}"]]})
+
+(def option-validations
+  "one of an explicit list of optional values a property may have
+  NOTE: whether options get encoded at application layer or at database layer
+  is UNDEFINED; either behaviour is correct. If at database layer it's also
+  UNDEFINED whether they're encoded as a single reference data table or as
+  separate reference data tables for each property.
+
+  * `value`:	the value of this option."
+  {:tag [v/required [#(= % :option)]]
+   [:attrs :value] [v/required]
+   :content [[v/every #(or
+                        (b/valid? % documentation-validations)
+                        (b/valid? % prompt-validations))]]})
+
+(def pragma-validations
+  "pragmatic advice to generators of lists and forms, in the form of
+  name/value pairs which may contain anything. Over time some pragmas
+  will become 'well known', but the whole point of having a pragma
+  architecture is that it is extensible."
+  {:tag [v/required [#(= % :pragma)]]
+   [:attrs :name] [v/string v/required]
+   [:attrs :value] [v/string v/required]})
+
+
+
+(def generator-validations
+  "marks a property which is auto-generated by some part of the system.
+  This is based on the Hibernate construct, except that the Hibernate
+  implementation folds both its internal generators and custom generators
+  onto the same attribute. This separates them onto two attributes so we
+  can police values for Hibernate's 'builtin' generators.
+
+  * `action`:       one of the supported Hibernate builtin generators, or
+                'manual'. 'native' is strongly recommended in most instances
+  * `class`:        if action is 'manual', the name of a manually maintained
+                class conforming to the Hibernate IdentifierGenerator
+                interface, or its equivalent in other languages."
+  {:tag [v/required [#(= % :generator)]]
+   [:attrs :action] [v/string v/required [v/member generator-actions]]
+   [:attrs :class] v/string
+   :content [[v/every #(disjunct-validate %
+                         documentation-validations
+                         param-validations)]]})
+
+
+(def in-implementation-validations
+  "information about how to translate a type into types known to different target
+  languages. TODO: Once again I'm not wholly comfortable with the name; I'm not
+  really comfortable that this belongs in ADL at all.
+
+  * `target`:     the target language
+  * `value`:      the type to use in that target language
+  * `kind`:       OK, I confess I don't understand this, but Andrew needs it... "
+
+  {:tag [v/required [#(= % :in-implementation)]]
+   [:attrs :target] [v/string v/required]
+   [:attrs :value] [v/string v/required]
+   [:attrs :kind] v/string
+   :content [[v/every documentation-validations]]})
+
+(def typedef-validations
+  "the definition of a defined type. At this stage a defined type is either
+	* a string		in which case it must have size and pattern, or
+	* a scalar		in which case it must have minimum and/or maximum
+	pattern must be a regular expression as interpreted by org.apache.regexp.RE
+	minimum and maximum must be of appropriate format for the datatype specified.
+	Validation may be done client-side and/or server-side at application layer
+	and/or server side at database layer.
+
+  * `name`:     the name of this typedef
+  * `type`:     the simple type on which this defined type is based; must be
+            present unless in-implementation children are supplied
+  * `size`:     the data size of this defined type
+  * `pattern`:  a regular expression which values for this type must match
+  * `minimum`:  the minimum value for this type (if base type is scalar)
+  * `maximum`:  the maximum value for this type (if base type is scalar)"
+  {:tag [v/required [#(= % :typedef)]]
+   [:attrs :name] [v/required v/string]
+   [:attrs :type] [[v/member defineable-data-types]]
+   [:attrs :size] [[#(if
+                       (string? %)
+                       (integer? (read-string %))
+                       (integer? %))]]
+   [:attrs :pattern] v/string
+   [:attrs :minimum] [[#(if
+                          (string? %)
+                          (integer? (read-string %))
+                          (integer? %))]]
+   [:attrs :maximum] [[#(if
+                          (string? %)
+                          (integer? (read-string %))
+                          (integer? %))]]
+   :content [[v/every #(or
+                         (b/valid? % documentation-validations)
+                         (b/valid? % in-implementation-validations)
+                         (b/valid? % help-validations))]]})
+
+(def group-validations
+  "a group of people with similar permissions to one another
+
+  * `name`: the name of this group
+  * `parent`: the name of a group of which this group is subset"
+  {:tag [v/required [#(= % :group)]]
+   [:attrs :name] [v/string v/required]
+   [:attrs :parent] v/string
+   :content [[v/every documentation-validations]]})
+
+(def property-validations
+	"a property (field) of an entity (table)
+
+	* `name`:			  the name of this property.
+	* `type`:			  the type of this property.
+	* `default`:		the default value of this property. There will probably be
+					    magic values of this!
+	* `typedef`:	  name of the typedef to use, it type = 'defined'.
+	* `distinct`:		distinct='system' required that every value in the system
+					    will be distinct (i.e. natural primary key);
+					    distinct='user' implies that the value may be used by users
+					    in distinguishing entities even if values are not formally
+					    unique;
+					    distinct='all' implies that the values are formally unique
+					    /and/ are user friendly (NOTE: not implemented).
+	* `entity`:	if type='entity', the name of the entity this property is
+					    a foreign key link to.
+              if type='list', the name of the entity that has a foreign
+              key link to this entity
+	* `farkey`:   if type='list', the name of farside key in the listed
+              entity; if type='entity' and the farside field to join to
+              is not the farside primary key, then the name of that
+              farside field
+	* `required`:		whether this propery is required (i.e. 'not null').
+	* `immutable`:		if true, once a value has been set it cannot be changed.
+	* `size`: 			fieldwidth of the property if specified.
+	* `concrete`: if set to 'false', this property is not stored in the
+              database but must be computed (manually written code must
+              be provided to support this)
+	* `cascade`:  what action(s) on the parent entity should be cascaded to
+              entitie(s) linked on this property. Valid only if type='entity',
+              type='link' or type='list'.
+	* `column`:   name of the column in a SQL database table in which this property
+              is stored. TODO: Think about this.
+	* `unsaved-value`:
+              of a property whose persistent value is set on first being
+              committed to persistent store, the value which it holds before
+              it has been committed"
+  {:tag [v/required [#(= % :property)]]
+   [:attrs :name] [v/required v/string]
+   [:attrs :type] [v/required [v/member all-data-types]]
+   ;; [:attrs :default] [] ;; it's allowed, but I don't have anything particular to say about it
+   [:attrs :typedef] v/string
+   [:attrs :distinct] [v/string [v/member #{"none", "all", "user", "system"}]]
+   [:attrs :entity] v/string
+   [:attrs :farkey] v/string
+   [:attrs :required] [[v/member #{"true", "false"}]]
+   [:attrs :immutable] [[v/member #{"true", "false"}]]
+   [:attrs :size] [[#(cond
+                      (empty? %) ;; it's allowed to be missing
+                      true
+                       (string? %)
+                       (integer? (read-string %))
+                      true
+                       (integer? %))]]
+   [:attrs :column] v/string
+   [:attrs :concrete] [[v/member #{"true", "false"}]]
+   [:attrs :cascade] [[v/member cascade-actions]]
+   :content [[v/every #(disjunct-validate %
+                         documentation-validations
+                         generator-validations
+                         permission-validations
+                         option-validations
+                         prompt-validations
+                         help-validations
+                         ifmissing-validations)]]})
+
+
+(def permission-validations
+  "permissions policy on an entity, a page, form, list or field
+
+  * `group`: 			the group to which permission is granted
+  * `permission`:		the permission which is granted to that group"
+  {:tag [v/required [#(= % :permission)]]
+   [:attrs :group] [v/required v/string] ;; and it also needs to be the name of a pre-declared group
+   [:attrs :permission] [[v/member permissions]]
+   :content [[v/every documentation-validations]]})
+
+(def head-validations
+  "content to place in the head of the generated document; normally HTML."
+  {:tag [v/required [#(= % :head)]]})
+
+(def top-validations
+  "content to place in the top of the body of the generated document;
+	this is any HTML block or inline level element."
+  {:tag [v/required [#(= % :top)]]})
+
+(def foot-validations
+  "content to place in the bottom of the body of the generated document;
+	this is any HTML block or inline level element."
+  {:tag [v/required [#(= % :foot)]]})
+
+(def field-validations
+  "a field in a form or page
+
+  * `property`:   the property which this field displays/edits."
+  {:tag [v/required [#(= % :field)]]
+   [:attrs :property] [v/string v/required] ;; and it must also be the name of a property in the current entity
+   :content [[v/every #(or
+                         (b/valid? % documentation-validations)
+                         (b/valid? % prompt-validations)
+                         (b/valid? % permission-validations)
+                         (b/valid? % help-validations))]]})
+
+(def verb-validations
+  "a verb is something that may be done through a form. Probably the verbs 'store'
+  and 'delete' are implied, but maybe they need to be explicitly declared. The 'verb'
+  attribute of the verb is what gets returned to the controller
+
+  * `verb`  what gets returned to the controller when this verb is selected
+  * `dangerous`  true if this verb causes a destructive change."
+  {:tag [v/required [#(= % :verb)]]
+   [:attrs :verb] [v/string v/required]
+   [:attrs :dangerous] [[v/member #{"true", "false"}] v/required]})
+
+(def order-validations
+  "an ordering or records in a list
+	* `property`:	the property on which to order
+	* `sequence`:	the sequence in which to order"
+  {:tag [v/required [#(= % :order)]]
+   [:attrs :property] [v/string v/required] ;; and it must also be the name of a property in the current entity
+   [:attrs :sequence] [[v/member sequences]]
+   :content [[v/every documentation-validations]]})
+
+(def auxlist-validations
+  "a subsidiary list, on which entities related to primary
+  entities in the enclosing page or list are listed
+
+  * `property`:   the property of the enclosing entity that this
+              list displays (obviously, must be of type='list')
+  * `onselect`:   the form or page of the listed entity to call
+              when an item from the list is selected
+  * `canadd`:     true if the user should be able to add records
+              to this list"
+  {:tag [v/required [#(= % :auxlist)]]
+   [:attrs :property] [v/string v/required] ;; and it must also be the name of a property of type `list` in the current entity
+   [:attrs :onselect] v/string
+   [:attrs :canadd] v/boolean
+   :content [[v/every #(or
+                         (b/valid? % documentation-validations)
+                         (b/valid? % prompt-validations)
+                         (b/valid? % field-validations)
+                         (b/valid? % fieldgroup-validations)
+                         (b/valid? % auxlist-validations)
+                         (b/valid? % verb-validations))]]})
+
+(def fieldgroup-validations
+  "a group of fields and other controls within a form or list, which the
+  renderer might render as a single pane in a tabbed display, for example."
+  {:tag [v/required [#(= % :fieldgroup)]]
+   [:attrs :name] [v/string v/required]
+   :content [[v/every #(or
+                         (b/valid? % documentation-validations)
+                         (b/valid? % prompt-validations)
+                         (b/valid? % permission-validations)
+                         (b/valid? % help-validations)
+                         (b/valid? % field-validations)
+                         (b/valid? % fieldgroup-validations)
+                         (b/valid? % auxlist-validations)
+                         (b/valid? % verb-validations))]]})
+
+
+(def form-validations
+  "a form through which an entity may be added or edited"
+  {:tag [v/required [#(= % :form)]]
+   [:attrs :name] [v/required v/string]
+   [:attrs :properties] [v/required [v/member #{"all", "user-distinct", "listed"}]]
+   [:attrs :canadd] [[v/member #{"true", "false"}]]
+   :content [[v/every #(disjunct-validate %
+                          documentation-validations
+                          head-validations
+                          top-validations
+                          foot-validations
+                          field-validations
+                          fieldgroup-validations
+                          auxlist-validations
+                          verb-validations
+                          permission-validations
+                          pragma-validations)]]})
+
+(def page-validations
+  "a page on which an entity may be displayed"
+  {:tag [v/required [#(= % :page)]]
+   [:attrs :name] [v/required v/string]
+   [:attrs :properties] [v/required [v/member #{"all", "user-distinct", "listed"}]]
+   :content [[v/every #(disjunct-validate %
+                          documentation-validations
+                          head-validations
+                          top-validations
+                          foot-validations
+                          field-validations
+                          fieldgroup-validations
+                          auxlist-validations
+                          verb-validations
+                          permission-validations
+                          pragma-validations)]]})
+
+(def list-validations
+  "a list on which entities of a given type are listed
+
+	* `onselect`:		name of form/page/list to go to when
+					    a selection is made from the list"
+  {:tag [v/required [#(= % :list)]]
+   [:attrs :name] [v/required v/string]
+   [:attrs :properties] [v/required [v/member #{"all", "user-distinct", "listed"}]]
+   [:attrs :onselect] v/string
+   :content [[v/every #(disjunct-validate %
+                          documentation-validations
+                          head-validations
+                          top-validations
+                          foot-validations
+                          field-validations
+                          fieldgroup-validations
+                          auxlist-validations
+                          verb-validations
+                          permission-validations
+                          pragma-validations
+                          order-validations)]]})
+
+(def key-validations
+  {:tag [v/required [#(= % :key)]]
+   :content [[v/every property-validations]]})
+
+
+(def entity-validations
+  "an entity which has properties and relationships; maps onto a database
+	table or a Java serialisable class - or, of course, various other things
+
+  * `name`:         obviously, the name of this entity
+  * `natural-key`:  if present, the name of a property of this entity which forms
+                a natural primary key [NOTE: Only partly implemented. NOTE: much of
+                the present implementation assumes all primary keys will be
+                integers. This needs to be fixed!] DEPRECATED: remove; replace with the
+                'key' element, below.
+  * `table`:        the name of the table in which this entity is stored. Defaults to same
+                as name of entity. Strongly recommend this is not used unless it needs
+                to be different from the name of the entity
+  * `foreign`:      this entity is part of some other system; no code will be generated
+                for it, although code which links to it will be generated"
+  {:tag [v/required [#(= % :entity)]]
+   [:attrs :name] [v/required v/string]
+   [:attrs :natural-key] v/string
+   [:attrs :table] v/string
+   [:attrs :foreign] [[v/member #{"true", "false"}]]
+   :content [[v/every #(disjunct-validate %
+                         documentation-validations
+                         prompt-validations
+                         content-validations
+                         key-validations
+                         property-validations
+                         permission-validations
+                         form-validations
+                         page-validations
+                         list-validations)]]})
+
+(def application-validations
+  {:tag [v/required [#(= % :application)]]
+   [:attrs :name] [v/required v/string]
+   [:attrs :version] v/string
+   [:attrs :revision] v/string
+   [:attrs :currency] v/string
+   :content [[v/every #(disjunct-validate %
+                         specification-validations
+                         documentation-validations
+                         content-validations
+                         typedef-validations
+                         group-validations
+                         entity-validations)]]})
+
+;; the good news: it's complete.
+;; the bad news: it doesn't yet work.
+;; TODO: write a function which takes the output of bouncer.core.validate and filters out the paths to those bits which failed.
+
+(defn find-keys
+  [o p]
+  (cond
+   (map? o)
+   (reduce
+    merge
+    {}
+    (map
+     (fn [k]
+       (let [tail (find-keys (o k) p)] ;; error is here
+        (cond
+         (not (empty? tail))
+         {k tail}
+         (p k)
+         {k (o k)}
+         true
+         {})))
+     (keys o)))
+   (coll? o)
+   (remove empty? (map #(find-keys % p) o))))
+
+(defn walk-find-keys
+  [o p]
+  (walk
+   #(do %)
+   #(cond
+     (map? %)
+     (reduce
+      {}
+      (remove
+        empty?
+       (map
+        (fn [k]
+          (cond
+           (p k)
+           {k (% k)}
+           (walk-find-keys (% k) p)
+           {k (walk-find-keys (% k) p)}))
+        (keys %))))
+     (coll? %)
+     (remove
+      empty?
+      (map
+       (fn [e]
+         (walk-find-keys e p))
+       %)))
+   o))