Queries improved, all tests in adl.to-hugsql-queries-test pass.

resources/schemas/adl-1.4.dtd

@@ -152,7 +152,7 @@ that we can allow HTML block level entities within content elements -->
                       to this property before it is persisted.
   guid:               The system will supply a unique GUid value to this field
                       before it is persisted.
-  mannual:            You contract to supply a generatos class in manually maintained
+  mannual:            You contract to supply a generator class in manually maintained
                       code.
   native:             The database will supply a unique value to this field when it
                       is persisted; the value will be an integer. RECOMMENDED!

src/adl/to_hugsql_queries.clj

@@ -6,7 +6,7 @@
             [clojure.string :as s]
             [clj-time.core :as t]
             [clj-time.format :as f]
-            [adl.utils :refer [singularise is-link-table?]]))
+            [adl.utils :refer :all]))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;;
@@ -32,24 +32,6 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 
-(defn key-names [entity-map]
-  (let [k (first (filter #(= (:tag %) :key) (:content entity-map)))]
-  (remove
-    nil?
-    (map
-      #(:name (:attrs %))
-      (filter #(= (:tag %) :property) (:content k))))))
-
-
-(defn has-primary-key? [entity-map]
-  (not (empty? (key-names entity-map))))
-
-
-(defn has-non-key-properties? [entity-map]
-  (not
-   (empty? (filter #(= (:tag %) :property) (:content entity-map)))))
-
-
 (defn where-clause [entity-map]
   (let
     [entity-name (:name (:attrs entity-map))]
@@ -57,7 +39,15 @@
      "WHERE " entity-name "."
      (s/join
       (str " AND\n\t" entity-name ".")
-        (map #(str % " = " (keyword %)) (key-names entity-map))))))
+      (map
+       #(let [target (keyword (-> % :attrs :name))]
+          (str
+           (name target) " = "
+           (if
+            (quoted-type? %)
+            (str "'" target "'")
+            target)))
+       (key-properties entity-map))))))
 
 
 (defn order-by-clause [entity-map]
@@ -66,22 +56,23 @@
      preferred (map
                 #(:name (:attrs %))
                 (filter #(and
-                          (= (-> % :attrs :distinct) "user")
+                          (#{"all", "user"} (-> % :attrs :distinct))
                           (= (-> % :tag) :property))
-                        (-> entity-map :content)))]
+                        (concat (properties entity-map)(key-properties entity-map))))]
     (str
      "ORDER BY " entity-name "."
      (s/join
       (str ",\n\t" entity-name ".")
-      (doall (flatten (cons preferred (key-names entity-map))))))))
+      (doall (flatten (cons preferred (filter
+                                       #(not (#{"all", "user"} %))
+                                       (key-names entity-map)))))))))
 
-(defn property-names [entity-map]
-  (map #(:name (:attrs %)) (filter #(= (-> % :tag) :property) (:content entity-map))))
 
 (defn insert-query [entity-map]
   (let [entity-name (:name (:attrs entity-map))
         pretty-name (singularise entity-name)
-        all-property-names (property-names entity-map)
+        props (concat (properties entity-map) (insertable-key-properties entity-map))
+        pnames (map #(-> % :attrs :name) props)
         query-name (str "create-" pretty-name "!")
         signature ":! :n"]
     (hash-map
@@ -94,9 +85,16 @@
       (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)
+           (s/join ",\n\t" pnames)
            ")\nVALUES ("
-            (s/join ",\n\t" (map keyword all-property-names))
+           (s/join ",\n\t"
+                   (map
+                    #(let [target (keyword (-> % :attrs :name))]
+                       (if
+                         (quoted-type? %)
+                         (str "'" target "'")
+                         target))
+                    props))
            ")"
            (if
              (has-primary-key? entity-map)
@@ -137,11 +135,11 @@
         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
-                       #(and
+                       ;; TODO: should also allow typdefed fields which typedef to string.
-                         (= (-> % :attrs :type) "string")
+                       #(= (-> % :attrs :type) "string")
-                         (= (:tag %) :property))
+                       props)]
-                       (-> entity-map :content))]
     (if
       (empty? string-fields)
       {}

src/adl/utils.clj

@@ -1,11 +1,126 @@
 (ns adl.utils
   (:require [clojure.string :as s]))
 
-(defn singularise [string]
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;
+;;;; adl.utils: utility functions generally useful to generators.
+;;;;
+;;;; 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
+;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; **Argument name conventions**: arguments with names of the form `*-map`
+;;; represent elements extracted from an ADL XML file as parsed by
+;;; `clojure.xml/parse`. Thus `entity-map` represents an ADL entity,
+;;; `property-map` a property, and so on.
+;;;
+;;; Generally, `(:tag x-map) => "x"`, and for every such object
+;;; `(:attrs x-map)` should return a map of attributes whose keys
+;;; are keywords and whose values are strings.
+
+(defn singularise
+  "Assuming this string represents an English language plural noun,
+  construct a Clojure symbol name which represents the singular."
+  [string]
   (s/replace (s/replace (s/replace string #"_" "-") #"s$" "") #"ie$" "y"))
 
+(defn entities
+  [application-map]
+  (filter #(= (-> % :tag) :entity) (:content application-map)))
+
 (defn is-link-table?
+  "Does this `entity-map` represent a pure link table?"
   [entity-map]
   (let [properties (-> entity-map :content :properties vals)
         links (filter #(-> % :attrs :entity) properties)]
     (= (count properties) (count links))))
+
+
+(defn key-properties
+  "Return a list of all properties in the primary key of this `entity-map`."
+  [entity-map]
+  (filter
+   #(= (:tag %) :property)
+   (:content
+    ;; there's required to be only one key element in and entity element
+    (first
+     (filter
+      #(= (:tag %) :key)
+      (:content entity-map))))))
+
+
+(defn insertable-key-properties
+  "List properties in the key of the entity indicated by this `entity-map`
+  which should be inserted.
+  A key property is insertable it it is not `system` (database) generated.
+  But note that `system` is the default."
+  [entity-map]
+  (filter
+   #(let
+      [generator (-> % :attrs :generator)]
+      (not
+       (or (nil? generator)
+           (= generator "system"))))
+      (key-properties entity-map)))
+
+
+(defn key-names
+  "List the names of all properties in the primary key of this `entity-map`."
+  [entity-map]
+  (remove
+    nil?
+    (map
+      #(:name (:attrs %))
+      (key-properties entity-map))))
+
+
+(defn has-primary-key?
+  "True if this `entity-map` has a primary key."
+  [entity-map]
+  (not (empty? (key-names entity-map))))
+
+
+(defn properties
+  "List the non-primary-key properties of this `entity-map`."
+  [entity-map]
+  (filter #(= (-> % :tag) :property) (:content entity-map)))
+
+
+(defn has-non-key-properties?
+  "True if this `entity-map` has properties which do not form part of the
+  primary key."
+  [entity-map]
+  (not
+   (empty? (properties entity-map))))
+
+
+(defn property-names
+  "List the names of non-primary-key properties of this `entity-map`."
+  [entity-map]
+  (map #(:name (:attrs %)) (properties entity-map)))
+
+
+(defn quoted-type?
+  "Is the type of the property represented by this `property-map` one whose
+  values should be quoted in SQL queries?
+  TODO: this won't work for typedef types, which means we need to pass the
+  entire parsed ADL down the chain to here (and probably, generally) so that
+  we can resolve issues like that."
+  [property-map]
+  (#{"string", "text", "date", "time", "timestamp"} (-> property-map :attrs :type)))
+

test/adl/to_hugsql_queries_test.clj

@@ -1,6 +1,22 @@
 (ns adl.to-hugsql-queries-test
-  (:require [clojure.test :refer :all]
+  (:require [clojure.string :as s]
-            [adl.to-hugsql-queries :refer :all]))
+            [clojure.test :refer :all]
+            [adl.to-hugsql-queries :refer :all]
+            [adl.utils :refer :all]))
+
+(defn string-equal-ignore-whitespace
+  "I don't want unit tests to fail just because emitted whitespace changes."
+  [a b]
+  (if
+  (and
+   (string? a)
+   (string? b))
+   (let
+     [pattern #"[\s]+"
+      aa (s/replace a pattern " ")
+      bb (s/replace b pattern " ")]
+     (= aa bb))
+    (= a b)))
 
 (deftest entity-tests
   (let [xml {:tag :entity,
@@ -32,67 +48,120 @@
     (testing "user distinct properties should provide the default ordering"
       (let [expected "ORDER BY address.street,\n\taddress.postcode,\n\taddress.id"
             actual (order-by-clause xml)]
-        (is (= actual expected))))
+        (is (string-equal-ignore-whitespace actual expected))))
     (testing "keys name extraction"
       (let [expected '("id")
             actual (key-names xml)]
-        (is (= actual expected))))
+        (is (string-equal-ignore-whitespace actual expected))))
     (testing "primary key test"
       (let [expected true
             actual (has-primary-key? xml)]
-        (is (= actual expected))))
+        (is (string-equal-ignore-whitespace actual expected))))
     (testing "non-key properties test"
       (let [expected true
             actual (has-non-key-properties? xml)]
-        (is (= actual expected))))
+        (is (string-equal-ignore-whitespace actual expected))))
     (testing "insert query generation"
-      (let [expected "-- :name create-addres! :! :n\n-- :doc creates a new addres record\nINSERT INTO address (street,\n\ttown,\n\tpostcode)\nVALUES (:street,\n\t:town,\n\t:postcode)\nreturning id\n\n"
+      (let [expected "-- :name create-addres! :! :n\n-- :doc creates a new addres record\nINSERT INTO address (street,\n\ttown,\n\tpostcode)\nVALUES (':street',\n\t':town',\n\t':postcode')\nreturning id\n\n"
             actual (:query (first (vals (insert-query xml))))]
-        (is (= actual expected))))
+        (is (string-equal-ignore-whitespace actual expected))))
     (testing "insert query signature"
       (let [expected ":! :n"
             actual (:signature (first (vals (insert-query xml))))]
-        (is (= actual expected))))
+        (is (string-equal-ignore-whitespace actual expected))))
     (testing "update query generation"
       (let [expected "-- :name update-addres! :! :n\n-- :doc updates an existing addres record\nUPDATE address\nSET street = :street,\n\ttown = :town,\n\tpostcode = :postcode\nWHERE address.id = :id\n\n"
             actual (:query (first (vals (update-query xml))))]
-        (is (= actual expected))))
+        (is (string-equal-ignore-whitespace actual expected))))
     (testing "update query signature"
       (let [expected ":! :n"
             actual (:signature (first (vals (update-query xml))))]
-        (is (= actual expected))))
+        (is (string-equal-ignore-whitespace actual expected))))
     (testing "search query generation"
       (let [expected "-- :name search-strings-addres :? :1\n-- :doc selects existing address records having any string field matching `:pattern` by substring match\nSELECT * FROM address\nWHERE street LIKE '%:pattern%'\n\tOR town LIKE '%:pattern%'\n\tOR postcode LIKE '%:pattern%'\nORDER BY address.street,\n\taddress.postcode,\n\taddress.id\n--~ (if (:offset params) \"OFFSET :offset \") \n--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")\n\n"
             actual (:query (first (vals (search-query xml))))]
-        (is (= actual expected))))
+        (is (string-equal-ignore-whitespace actual expected))))
     (testing "search query signature"
       (let [expected ":? :1"
             actual (:signature (first (vals (search-query xml))))]
-        (is (= actual expected))))
+        (is (string-equal-ignore-whitespace actual expected))))
     (testing "select query generation"
       (let [expected "-- :name get-addres :? :1\n-- :doc selects an existing addres record\nSELECT * FROM address\nWHERE address.id = :id\n\n"
             actual (:query (first (vals (select-query xml))))]
-        (is (= actual expected))))
+        (is (string-equal-ignore-whitespace actual expected))))
     (testing "select query signature"
       (let [expected ":? :1"
             actual (:signature (first (vals (select-query xml))))]
-        (is (= actual expected))))
+        (is (string-equal-ignore-whitespace actual expected))))
     (testing "list query generation"
       (let [expected "-- :name list-address :? :*\n-- :doc lists all existing addres records\nSELECT * FROM address\nORDER BY address.street,\n\taddress.postcode,\n\taddress.id\n--~ (if (:offset params) \"OFFSET :offset \") \n--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")\n\n"
             actual (:query (first (vals (list-query xml))))]
-        (is (= actual expected))))
+        (is (string-equal-ignore-whitespace actual expected))))
     (testing "list query signature"
       (let [expected ":? :*"
             actual (:signature (first (vals (list-query xml))))]
-        (is (= actual expected))))
+        (is (string-equal-ignore-whitespace actual expected))))
     (testing "delete query generation"
       (let [expected "-- :name delete-addres! :! :n\n-- :doc updates an existing addres record\nDELETE FROM address\nWHERE address.id = :id\n\n"
             actual (:query (first (vals (delete-query xml))))]
-        (is (= actual expected))))
+        (is (string-equal-ignore-whitespace actual expected))))
     (testing "delete query signature"
       (let [expected ":! :n"
             actual (:signature (first (vals (delete-query xml))))]
-        (is (= actual expected))))
+        (is (string-equal-ignore-whitespace actual expected))))
 
   ))
 
+(deftest complex-key-tests
+  (let [xml {:tag :entity,
+             :attrs {:name "address"},
+             :content
+             [{:tag :key,
+               :attrs nil,
+               :content
+               [{:tag :property,
+                 :attrs
+                 {:immutable "true",
+                  :required "true",
+                  :distinct "system",
+                  :type "integer",
+                  :name "id"},
+                 :content
+                 [{:tag :generator, :attrs {:action "native"}, :content nil}]}
+                {:tag :property,
+                 :attrs
+                 {:immutable "true",
+                  :required "true",
+                  :distinct "all",
+                  :generator "assigned"
+                  :type "string",
+                  :size "12"
+                  :name "postcode"},
+                 :content
+                 [{:tag :generator, :attrs {:action "native"}, :content nil}]}
+                ]}
+              {:tag :property,
+               :attrs
+               {:distinct "user", :size "128", :type "string", :name "street"},
+               :content nil}
+              {:tag :property,
+               :attrs {:size "64", :type "string", :name "town"},
+               :content nil}
+              ]}]
+    (testing "insert query generation - compound key, non system generated field in key"
+      (let [expected "-- :name create-addres! :! :n\n-- :doc creates a new addres record\nINSERT INTO address (street,\n\ttown,\n\tpostcode)\nVALUES (':street',\n\t':town',\n\t':postcode')\nreturning id,\n\tpostcode\n\n"
+            actual (:query (first (vals (insert-query xml))))]
+        (is (string-equal-ignore-whitespace actual expected))))
+    (testing "update query generation - compound key"
+      (let [expected "-- :name update-addres! :! :n\n-- :doc updates an existing addres record\nUPDATE address\nSET street = :street,\n\ttown = :town\nWHERE address.id = :id AND\n\taddress.postcode = ':postcode'\n\n"
+            actual (:query (first (vals (update-query xml))))]
+        (is (string-equal-ignore-whitespace actual expected))))
+    (testing "search query generation - user-distinct field in key"
+      (let [expected  "-- :name search-strings-addres :? :1\n-- :doc selects existing address records having any string field matching `:pattern` by substring match\nSELECT * FROM address\nWHERE street LIKE '%:pattern%'\n\tOR town LIKE '%:pattern%'\n\tOR postcode LIKE '%:pattern%'\nORDER BY address.street,\n\taddress.postcode,\n\taddress.id,\n\taddress.postcode\n--~ (if (:offset params) \"OFFSET :offset \") \n--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")\n\n"
+            actual (:query (first (vals (search-query xml))))]
+        (is (string-equal-ignore-whitespace actual expected))))
+    (testing "delete query generation - compound key"
+      (let [expected "-- :name delete-addres! :! :n\n-- :doc updates an existing addres record\nDELETE FROM address\nWHERE address.id = :id AND\n\taddress.postcode = ':postcode'\n\n"
+            actual (:query (first (vals (delete-query xml))))]
+        (is (string-equal-ignore-whitespace actual expected))))))
+