simon/squirrel-parse
1
0
Fork 0
Code Issues Pull requests Actions Packages Projects Releases Wiki Activity

Now generating useful hugsql queries for link tables.

Browse source
This commit is contained in:
Simon Brooke 2018-03-16 16:21:29 +00:00
parent 80940dab06
commit f22781edf3
4 changed files with 123 additions and 22 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
project.clj
View file

@ -4,5 +4,6 @@
: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"]
[clj-time "0.14.2"]
[instaparse "1.4.8"]])

3
src/squirrel_parse/to_adl.clj
View file

@ -222,12 +222,13 @@
(map #(apply function (list entity-map %)) statements))))
;; TODO: link tables are not entities, and should be removed from the entities map.
;; (defn fixup-many-to-many
;; [entities-map]
;; (let [entities (filter #(not (is-link-table? %)) (vals entities-map))
;; link-tables (filter is-link-table? (vals entities-map))]
;; (reduce #() entities-map)))
;; (reduce #() entities-map link-tables)))
(defn table-definitions-to-entities

113
src/squirrel_parse/to_hugsql_queries.clj
View file

@ -2,8 +2,10 @@
:author "Simon Brooke"}
squirrel-parse.to-hugsql-queries
(:require [clojure.java.io :refer [file]]
[clojure.math.combinatorics :refer [combinations]]
[clojure.string :as s]
[squirrel-parse.to-adl :refer [migrations-to-xml]]))
[squirrel-parse.to-adl :refer [migrations-to-xml]]
[squirrel-parse.utils :refer [is-link-table? singularise]]))
(defn key-names [entity-map]
@ -25,9 +27,27 @@
(defn where-clause [entity-map]
(let
[entity-name (:name (:attrs entity-map))]
(str
"WHERE "
(s/join " AND\n\t" (map #(str % " = " (keyword %)) (key-names entity-map)))))
"WHERE " entity-name "."
(s/join
(str " AND\n\t" entity-name ".")
(map #(str % " = " (keyword %)) (key-names entity-map))))))
(defn order-by-clause [entity-map]
(let
[entity-name (:name (:attrs entity-map))
preferred (map
#(:name (:attrs %))
(filter #(= (-> % :attrs :distinct) "user")
(-> entity-map :content :properties vals)))]
(str
"ORDER BY " entity-name "."
(s/join
(str ",\n\t" entity-name ".")
(doall (flatten (cons preferred (key-names entity-map))))))))
(defn insert-query [entity-map]
@ -76,12 +96,83 @@
(let [entity-name (:name (:attrs entity-map))
pretty-name (s/replace (s/replace entity-name #"_" "-") #"s$" "")]
(str "-- :name get-" pretty-name " :? :1\n"
"-- :doc updates an existing " pretty-name " record\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"))))
(defn list-query [entity-map]
(let [entity-name (:name (:attrs entity-map))
pretty-name (s/replace (s/replace entity-name #"_" "-") #"s$" "")]
(str "-- :name list-" pretty-name " :? :*\n"
"-- :doc lists all existing " pretty-name " records\n"
"SELECT * FROM " entity-name "\n"
(order-by-clause entity-map)
"\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$" "")
links (filter #(-> % :attrs :entity) (-> entity-map :content :properties vals))]
(apply
str
(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)]
(str "-- :name list-" entity-name "-by-" pretty-far " :? :*\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"))
links))))
(defn link-table-query [near link far]
(let [properties (-> link :content :properties vals)
links (apply
merge
(map
#(hash-map (keyword (-> % :attrs :entity)) %)
(filter #(-> % :attrs :entity) properties)))
near-name (-> near :attrs :name)
link-name (-> link :attrs :name)
far-name (-> far :attrs :name)
pretty-far (singularise far-name)]
(println links)
(str "-- :name list-" link-name "-" near-name "-by-" pretty-far " :? :*\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")))
(defn link-table-queries [entity-map entities-map]
(let
[entities (map
#((keyword %) entities-map)
(remove nil? (map #(-> % :attrs :entity) (-> entity-map :content :properties vals))))
pairs (combinations entities 2)]
(apply
str
(map
#(str
(link-table-query (nth % 0) entity-map (nth % 1))
(link-table-query (nth % 1) entity-map (nth % 0)))
pairs))))
(defn delete-query [entity-map]
(if
(has-primary-key? entity-map)
@ -95,20 +186,26 @@
(defn queries
[entity-map]
[entity-map entities-map]
(str
(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
(select-query entity-map)
(delete-query entity-map)))
(list-query entity-map)
(foreign-queries entity-map entities-map)))))
(defn migrations-to-queries-sql
([migrations-path]
(migrations-to-queries-sql migrations-path "queries.sql"))
(migrations-to-queries-sql migrations-path "queries.auto.sql"))
([migrations-path output]
(let
[adl-struct (migrations-to-xml migrations-path "Ignored")
file-content (apply str (map queries (vals adl-struct)))]
file-content (apply str (map #(queries % adl-struct) (vals adl-struct)))]
(spit output file-content)
file-content)))

24
src/squirrel_parse/utils.clj
View file

@ -1,7 +1,7 @@
(ns ^{:doc "A parser for SQL: utility functions."
:author "Simon Brooke"}
squirrel-parse.utils
(:require [clojure.string :refer [join split trim triml upper-case]]))
(:require [clojure.string :as s]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -45,14 +45,14 @@
without the terminal semi-colon. Keywords may always optionally be preceded
by whitespace and are usually succeeded by whitespace."
[token]
(let [subtokens (split token #"\s+")
name (join "-" subtokens)]
(let [subtokens (s/split token #"\s+")
name (s/join "-" subtokens)]
(apply str
(flatten
(list
(upper-case name)
(s/upper-case name)
" := OPT-SPACE "
(join " SPACE " (map #(str "#'(?i)" % "'") subtokens))
(s/join " SPACE " (map #(str "#'(?i)" % "'") subtokens))
" OPT-SPACE ")))))
@ -79,7 +79,7 @@
(defn- make-timezone-clause
[match with-tz? with-precision?]
(join
(s/join
" "
(list
(if with-precision? (str match " LPAR INT-VAL RPAR") match)
@ -92,16 +92,16 @@
"Make a rule which matches this `datatype`, for datatypes which may optionally take
'with (or without) time zone'."
[token]
(let [subtokens (split token #"\s+")
name (join "-" subtokens)
match (join " SPACE " (map #(str "#'(?i)" % "'") subtokens))]
(let [subtokens (s/split token #"\s+")
name (s/join "-" subtokens)
match (s/join " SPACE " (map #(str "#'(?i)" % "'") subtokens))]
(apply str
(flatten
(list
"DT-"
(upper-case name)
(s/upper-case name)
" := "
(join
(s/join
" | "
(list
match
@ -212,4 +212,6 @@
(if name-elt (second name-elt))))
(defn singularise [string]
(s/replace (s/replace string #"_" "-") #"s$" ""))