simon/adl
1
0
Fork 0
Code Issues Pull requests Actions Packages Projects Releases Wiki Activity

Much improved query generation.

Browse source
This commit is contained in:
Simon Brooke 2018-05-13 17:49:15 +01:00
parent e3dfbb5343
commit 481743ff2d
2 changed files with 276 additions and 169 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

333
src/adl/to_hugsql_queries.clj
View file

@ -6,7 +6,7 @@
[clojure.string :as s] [clojure.string :as s]
[clj-time.core :as t] [clj-time.core :as t]
[clj-time.format :as f] [clj-time.format :as f]
[adl.utils :refer [has-non-key-properties? has-primary-key? link-table? key-names singularise]])) [adl.utils :refer :all]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; ;;;;
@ -32,75 +32,96 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn where-clause [entity-map] (def ^:dynamic *output-path*
"The path to which generated files will be written."
"resources/auto/")
(defn where-clause
"Generate an appropriate `where` clause for queries on this `entity`"
[entity]
(let (let
[entity-name (:name (:attrs entity-map))] [entity-name (:name (:attrs entity))]
(str (str
"WHERE " entity-name "." "WHERE " entity-name "."
(s/join (s/join
(str " AND\n\t" entity-name ".") (str " AND\n\t" entity-name ".")
(map #(str % " = " (keyword %)) (key-names entity-map)))))) (map #(str % " = " (keyword %)) (key-names entity))))))
(defn order-by-clause [entity-map] (defn order-by-clause
"Generate an appropriate `order by` clause for queries on this `entity`"
[entity]
(let (let
[entity-name (:name (:attrs entity-map)) [entity-name (:name (:attrs entity))
preferred (map preferred (map
#(:name (:attrs %)) #(:name (:attrs %))
(filter #(= (-> % :attrs :distinct) "user") (filter #(#{"user" "all"} (-> % :attrs :distinct))
(-> entity-map :content :properties vals)))] (children entity #(= (:tag %) :property))))]
(if
(empty? preferred)
""
(str (str
"ORDER BY " entity-name "." "ORDER BY " entity-name "."
(s/join (s/join
(str ",\n\t" entity-name ".") (str ",\n\t" entity-name ".")
(doall (flatten (cons preferred (key-names entity-map)))))))) (flatten (cons preferred (key-names entity))))))))
(defn insert-query [entity-map] (defn insert-query
(let [entity-name (:name (:attrs entity-map)) "Generate an appropriate `insert` query for this `entity`.
TODO: this depends on the idea that system-unique properties
are not insertable, which is... dodgy."
[entity]
(let [entity-name (:name (:attrs entity))
pretty-name (singularise entity-name) pretty-name (singularise entity-name)
all-property-names (map #(:name (:attrs %)) (vals (:properties (:content entity-map)))) insertable-property-names (map
#(:name (:attrs %))
(filter
#(not (= (:distinct (:attrs %)) "system"))
(all-properties entity)))
query-name (str "create-" pretty-name "!") query-name (str "create-" pretty-name "!")
signature " :! :n"] signature " :! :n"]
(hash-map (hash-map
(keyword query-name) (keyword query-name)
{:name query-name {:name query-name
:signature signature :signature signature
:entity entity-map :entity entity
:type :insert-1 :type :insert-1
:query :query
(str "-- :name " query-name " " signature "\n" (str "-- :name " query-name " " signature "\n"
"-- :doc creates a new " pretty-name " record\n" "-- :doc creates a new " pretty-name " record\n"
"INSERT INTO " entity-name " (" "INSERT INTO " entity-name " ("
(s/join ",\n\t" all-property-names) (s/join ",\n\t" insertable-property-names)
")\nVALUES (" ")\nVALUES ("
(s/join ",\n\t" (map keyword all-property-names)) (s/join ",\n\t" (map keyword insertable-property-names))
")" ")"
(if (if
(has-primary-key? entity-map) (has-primary-key? entity)
(str "\nreturning " (s/join ",\n\t" (key-names entity-map)))) (str "\nreturning " (s/join ",\n\t" (key-names entity)))))})))
"\n\n")})))
(defn update-query [entity-map] (defn update-query
"Generate an appropriate `update` query for this `entity`"
[entity]
(if (if
(and (and
(has-primary-key? entity-map) (has-primary-key? entity)
(has-non-key-properties? entity-map)) (has-non-key-properties? entity))
(let [entity-name (:name (:attrs entity-map)) (let [entity-name (:name (:attrs entity))
pretty-name (singularise entity-name) pretty-name (singularise entity-name)
property-names (remove property-names (remove
nil? nil?
(map (map
#(if (= (:tag %) :property) (:name (:attrs %))) #(if (= (:tag %) :property) (:name (:attrs %)))
(vals (:properties (:content entity-map))))) (vals (:properties (:content entity)))))
query-name (str "update-" pretty-name "!") query-name (str "update-" pretty-name "!")
signature ":! :n"] signature ":! :n"]
(hash-map (hash-map
(keyword query-name) (keyword query-name)
{:name query-name {:name query-name
:signature signature :signature signature
:entity entity-map :entity entity
:type :update-1 :type :update-1
:query :query
(str "-- :name " query-name " " signature "\n" (str "-- :name " query-name " " signature "\n"
@ -109,19 +130,19 @@
"SET " "SET "
(s/join ",\n\t" (map #(str % " = " (keyword %)) property-names)) (s/join ",\n\t" (map #(str % " = " (keyword %)) property-names))
"\n" "\n"
(where-clause entity-map) (where-clause entity))}))
"\n\n")}))
{})) {}))
(defn search-query [entity-map] (defn search-query [entity]
(let [entity-name (:name (:attrs entity-map)) "Generate an appropriate search query for this `entity`"
(let [entity-name (:name (:attrs entity))
pretty-name (singularise entity-name) pretty-name (singularise entity-name)
query-name (str "search-strings-" pretty-name) query-name (str "search-strings-" pretty-name)
signature ":? :1" signature ":? :1"
string-fields (filter string-fields (filter
#(= (-> % :attrs :type) "string") #(= (-> % :attrs :type) "string")
(-> entity-map :content :properties vals))] (children entity #(= (:tag %) :property)))]
(if (if
(empty? string-fields) (empty? string-fields)
{} {}
@ -129,30 +150,36 @@
(keyword query-name) (keyword query-name)
{:name query-name {:name query-name
:signature signature :signature signature
:entity entity-map :entity entity
:type :text-search :type :text-search
:query :query
(str "-- :name " query-name " " signature "\n" (s/join
"-- :doc selects existing " entity-name " records having any string field matching `:pattern` by substring match\n" "\n"
"SELECT * FROM " entity-name "\n" (remove
empty?
(list
(str "-- :name " query-name " " signature)
(str
"-- :doc selects existing "
pretty-name
" records having any string field matching `:pattern` by substring match")
(str "SELECT * FROM " entity-name)
"WHERE " "WHERE "
(s/join (s/join
"\n\tOR " "\n\tOR "
(map (map
#(str (-> % :attrs :name) " LIKE '%:pattern%'") #(str (-> % :attrs :name) " LIKE '%:pattern%'")
string-fields)) string-fields))
"\n" (order-by-clause entity)
(order-by-clause entity-map) "--~ (if (:offset params) \"OFFSET :offset \")"
"\n" "--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")")))}))))
"--~ (if (:offset params) \"OFFSET :offset \") \n"
"--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")"
"\n\n")}))))
(defn select-query [entity-map] (defn select-query [entity]
"Generate an appropriate `select` query for this `entity`"
(if (if
(has-primary-key? entity-map) (has-primary-key? entity)
(let [entity-name (:name (:attrs entity-map)) (let [entity-name (:name (:attrs entity))
pretty-name (singularise entity-name) pretty-name (singularise entity-name)
query-name (str "get-" pretty-name) query-name (str "get-" pretty-name)
signature ":? :1"] signature ":? :1"]
@ -160,25 +187,28 @@
(keyword query-name) (keyword query-name)
{:name query-name {:name query-name
:signature signature :signature signature
:entity entity-map :entity entity
:type :select-1 :type :select-1
:query :query
(str "-- :name " query-name " " signature "\n" (s/join
"-- :doc selects an existing " pretty-name " record\n"
"SELECT * FROM " entity-name "\n"
(where-clause entity-map)
"\n" "\n"
(order-by-clause entity-map) (remove
"\n\n")})) empty?
(list
(str "-- :name " query-name " " signature)
(str "-- :doc selects an existing " pretty-name " record")
(str "SELECT * FROM " entity-name)
(where-clause entity)
(order-by-clause entity))))}))
{})) {}))
(defn list-query (defn list-query
"Generate a query to list records in the table represented by this `entity-map`. "Generate a query to list records in the table represented by this `entity`.
Parameters `:limit` and `:offset` may be supplied. If not present limit defaults Parameters `:limit` and `:offset` may be supplied. If not present limit defaults
to 100 and offset to 0." to 100 and offset to 0."
[entity-map] [entity]
(let [entity-name (:name (:attrs entity-map)) (let [entity-name (:name (:attrs entity))
pretty-name (singularise entity-name) pretty-name (singularise entity-name)
query-name (str "list-" entity-name) query-name (str "list-" entity-name)
signature ":? :*"] signature ":? :*"]
@ -186,28 +216,40 @@
(keyword query-name) (keyword query-name)
{:name query-name {:name query-name
:signature signature :signature signature
:entity entity-map :entity entity
:type :select-many :type :select-many
:query :query
(str "-- :name " query-name " " signature "\n" (s/join
"-- :doc lists all existing " pretty-name " records\n" "\n"
"SELECT * FROM " entity-name "\n" (remove
(order-by-clause entity-map) "\n" empty?
"--~ (if (:offset params) \"OFFSET :offset \") \n" (list
"--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")" (str "-- :name " query-name " " signature)
"\n\n")}))) (str "-- :doc lists all existing " pretty-name " records")
(str "SELECT * FROM " entity-name)
(order-by-clause entity)
"--~ (if (:offset params) \"OFFSET :offset \")"
"--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")")))})))
(defn foreign-queries [entity-map entities-map] (defn foreign-queries
(let [entity-name (:name (:attrs entity-map))
[entity application]
(let [entity-name (:name (:attrs entity))
pretty-name (singularise entity-name) pretty-name (singularise entity-name)
links (filter #(-> % :attrs :entity) (-> entity-map :content :properties vals))] links (filter #(-> % :attrs :entity) (children entity #(= (:tag %) :property)))]
(apply (apply
merge merge
(map (map
#(let [far-name (-> % :attrs :entity) #(let [far-name (-> % :attrs :entity)
far-entity ((keyword far-name) entities-map) far-entity (first
pretty-far (s/replace (s/replace far-name #"_" "-") #"s$" "") (children
application
(fn [x]
(and
(= (:tag x) :entity)
(= (:name (:attrs x)) far-name)))))
pretty-far (singularise far-name)
farkey (-> % :attrs :farkey) farkey (-> % :attrs :farkey)
link-field (-> % :attrs :name) link-field (-> % :attrs :name)
query-name (str "list-" entity-name "-by-" pretty-far) query-name (str "list-" entity-name "-by-" pretty-far)
@ -216,20 +258,33 @@
(keyword query-name) (keyword query-name)
{:name query-name {:name query-name
:signature signature :signature signature
:entity entity-map :entity entity
:type :select-one-to-many :type :select-one-to-many
:far-entity far-entity :far-entity far-entity
:query :query
(str "-- :name " query-name " " signature "\n" (s/join
"-- :doc lists all existing " pretty-name " records related to a given " pretty-far "\n" "\n"
"SELECT * \nFROM " entity-name "\n" (remove
"WHERE " entity-name "." link-field " = :id\n" empty?
(order-by-clause entity-map) (list
"\n\n")})) (str "-- :name " query-name " " signature)
(str "-- :doc lists all existing " pretty-name " records related to a given " pretty-far)
(str "SELECT * \nFROM " entity-name)
(str "WHERE " entity-name "." link-field " = :id")
(order-by-clause entity))))}))
links)))) links))))
(defn link-table-query [near link far] (defn link-table-query
"Generate a query which links across the entity passed as `link`
from the entity passed as `near` to the entity passed as `far`.
TODO: not working?"
[near link far]
(if
(and
(entity? near)
(entity? link)
(entity? far))
(let [properties (-> link :content :properties vals) (let [properties (-> link :content :properties vals)
links (apply links (apply
merge merge
@ -251,36 +306,55 @@
:near-entity near :near-entity near
:far-entity far :far-entity far
:query :query
(str "-- :name " query-name " " signature " \n" (s/join
"-- :doc lists all existing " near-name " records related through " link-name " to a given " pretty-far "\n" "\n"
"SELECT "near-name ".*\n" (remove
"FROM " near-name ", " link-name "\n" empty?
"WHERE " near-name "." (first (key-names near)) " = " link-name "." (-> (links (keyword near-name)) :attrs :name) "\n\t" (list
"AND " link-name "." (-> (links (keyword far-name)) :attrs :name) " = :id\n" (str "-- :name " query-name " " signature)
(order-by-clause near) (str "-- :doc lists all existing " near-name " records related through " link-name " to a given " pretty-far )
"\n\n")}))) (str "SELECT "near-name ".*")
(str "FROM " near-name ", " link-name )
(str "WHERE " near-name "." (first (key-names near)) " = " link-name "." (-> (links (keyword near-name)) :attrs :name) )
("\tAND " link-name "." (-> (links (keyword far-name)) :attrs :name) " = :id")
(order-by-clause near))))}))))
(defn link-table-queries [entity-map entities-map] (defn link-table-queries [entity application]
"Generate all the link queries in this `application` which link via this `entity`."
(let (let
[entities (map [entities (map
#((keyword %) entities-map) ;; find the far-side entities
(remove nil? (map #(-> % :attrs :entity) (-> entity-map :content :properties vals)))) (fn
[far-name]
(children
application
(fn [x]
(and
(= (:tag x) :entity)
(= (:name (:attrs x)) far-name)))))
;; of those properties of this `entity` which are of type `entity`
(remove
nil?
(map
#(-> % :attrs :entity)
(children entity #(= (:tag %) :property)))))
pairs (combinations entities 2)] pairs (combinations entities 2)]
(apply (apply
merge merge
(map (map
#(merge #(merge
(link-table-query (nth % 0) entity-map (nth % 1)) (link-table-query (nth % 0) entity (nth % 1))
(link-table-query (nth % 1) entity-map (nth % 0))) (link-table-query (nth % 1) entity (nth % 0)))
pairs)))) pairs))))
(defn delete-query [entity-map] (defn delete-query [entity]
"Generate an appropriate `delete` query for this `entity`"
(if (if
(has-primary-key? entity-map) (has-primary-key? entity)
(let [entity-name (:name (:attrs entity-map)) (let [entity-name (:name (:attrs entity))
pretty-name (singularise entity-name) pretty-name (singularise entity-name)
query-name (str "delete-" pretty-name "!") query-name (str "delete-" pretty-name "!")
signature ":! :n"] signature ":! :n"]
@ -288,57 +362,58 @@
(keyword query-name) (keyword query-name)
{:name query-name {:name query-name
:signature signature :signature signature
:entity entity-map :entity entity
:type :delete-1 :type :delete-1
:query :query
(str "-- :name " query-name " " signature "\n" (str "-- :name " query-name " " signature "\n"
"-- :doc updates an existing " pretty-name " record\n" "-- :doc updates an existing " pretty-name " record\n"
"DELETE FROM " entity-name "\n" "DELETE FROM " entity-name "\n"
(where-clause entity-map) (where-clause entity))}))))
"\n\n")}))))
(defn queries (defn queries
[entity-map entities-map] "Generate all standard queries for this `entity` in this `application`."
[entity application]
(merge (merge
{} {}
(insert-query entity-map) (insert-query entity)
(update-query entity-map) (update-query entity)
(delete-query entity-map) (delete-query entity)
(if (if
(link-table? entity-map) (link-table? entity)
(link-table-queries entity-map entities-map) (link-table-queries entity application)
(merge (merge
(select-query entity-map) (select-query entity)
(list-query entity-map) (list-query entity)
(search-query entity-map) (search-query entity)
(foreign-queries entity-map entities-map))))) (foreign-queries entity application)))))
;; (defn migrations-to-queries-sql (defn to-hugsql-queries
;; ([migrations-path] "Generate all [HugSQL](https://www.hugsql.org/) queries implied by this ADL `application` spec."
;; (migrations-to-queries-sql migrations-path "queries.auto.sql")) [application]
;; ([migrations-path output] (spit
;; (let (str *output-path* "queries.sql")
;; [adl-struct (migrations-to-xml migrations-path "Ignored") (s/join
;; file-content (apply "\n\n"
;; str (cons
;; (cons (s/join
;; (str "-- " "\n-- "
;; output (list
;; " autogenerated by \n-- [squirrel-parse](https://github.com/simon-brooke/squirrel-parse)\n-- at " "-- File queries.sql"
;; (f/unparse (f/formatters :basic-date-time) (t/now)) "autogenerated by adl.to-hugsql-queries at"
;; "\n\n") (t/now)
;; (doall "See [Application Description Language](https://github.com/simon-brooke/adl).\n\n"))
;; (map (map
;; #(:query %) #(:query %)
;; (sort (sort
;; #(compare (:name %1) (:name %2)) #(compare (:name %1) (:name %2))
;; (vals (vals
;; (apply (apply
;; merge merge
;; (map (map
;; #(queries % adl-struct) #(queries % application)
;; (vals adl-struct)))))))))] (children
;; (spit output file-content) application
;; file-content))) (fn [child] (= (:tag child) :entity))))))))))))

36
src/adl/utils.clj
View file

@ -117,6 +117,12 @@
(= (:distinct (:attrs property)) "system")))) (= (:distinct (:attrs property)) "system"))))
(defn entity?
"Return true if `x` is an ADL entity."
[x]
(= (:tag x) :entity))
(defn visible-to (defn visible-to
"Return a list of names of groups to which are granted read access, "Return a list of names of groups to which are granted read access,
given these `permissions`, else nil." given these `permissions`, else nil."
@ -134,7 +140,13 @@
(defn singularise (defn singularise
"Attempt to construct an idiomatic English-language singular of this string." "Attempt to construct an idiomatic English-language singular of this string."
[string] [string]
(s/replace (s/replace (s/replace string #"_" "-") #"s$" "") #"ie$" "y")) (s/replace
(s/replace
(s/replace
(s/replace string #"_" "-")
#"s$" "")
#"se$" "s")
#"ie$" "y"))
(defn link-table? (defn link-table?
@ -169,6 +181,26 @@
(count (key-names entity-map)))) (count (key-names entity-map))))
(defn children-with-tag
"Return all children of this `element` which have this `tag`."
[element tag]
(children element #(= (:tag %) tag)))
(defn descendants-with-tag
"Return all descendants of this `element`, recursively, which have this `tag`."
[element tag]
(flatten
(remove
empty?
(cons
(children element #(= (:tag %) tag))
(map
#(descendants-with-tag % tag)
(children element))))))
;; (read-adl "../youyesyet/stripped.adl.xml") (defn all-properties
"Return all properties of this entity (including key properties)."
[entity]
(descendants-with-tag entity :property))