diff --git a/src/squirrel_parse/to_adl.clj b/src/squirrel_parse/to_adl.clj index 456185d..832d457 100644 --- a/src/squirrel_parse/to_adl.clj +++ b/src/squirrel_parse/to_adl.clj @@ -376,8 +376,9 @@ (defn migrations-to-xml "As above, but for all 'up' migrations in the migrations directory specified by - `migrations-path`. Writes XML to `output`, but returns, instead of the serialisable XML - structure, the intermediate mappy structure, because that is more tractable in Clojure." + `migrations-path`. Writes XML to `output` (if specified), but returns, instead + of the serialisable XML structure, the intermediate mappy structure, because + that is more tractable in Clojure." ([migrations-path application-name] (migrations-to-xml migrations-path application-name (unparse (formatters :basic-date) (now)))) ([migrations-path application-name version] diff --git a/src/squirrel_parse/to_hugsql_queries.clj b/src/squirrel_parse/to_hugsql_queries.clj new file mode 100644 index 0000000..d2b19e8 --- /dev/null +++ b/src/squirrel_parse/to_hugsql_queries.clj @@ -0,0 +1,110 @@ +(ns ^{:doc "A parser for SQL: generate HUGSQL queries file." + :author "Simon Brooke"} + squirrel-parse.to-hugsql-queries + (:require [clojure.java.io :refer [file]] + [clojure.string :as s] + [squirrel-parse.to-adl :refer [migrations-to-xml]])) + + +(defn key-names [entity-map] + (remove + nil? + (map + #(:name (:attrs %)) + (vals (:content (:key (:content entity-map))))))) + + +(defn has-primary-key? [entity-map] + (> (count (key-names entity-map)) 0)) + + +(defn has-non-key-properties? [entity-map] + (> + (count (vals (:properties (:content entity-map)))) + (count (key-names entity-map)))) + + +(defn where-clause [entity-map] + (str + "WHERE " + (s/join " AND\n\t" (map #(str % " = " (keyword %)) (key-names entity-map))))) + + +(defn insert-query [entity-map] + (let [entity-name (:name (:attrs entity-map)) + pretty-name (s/replace (s/replace entity-name #"_" "-") #"s$" "") + all-property-names (map #(:name (:attrs %)) (vals (:properties (:content entity-map)))) + ] + (str "-- :name create-" pretty-name "! :! :n\n" + "-- :doc creates a new " pretty-name " record\n" + "INSERT INTO " entity-name "\n(" + (s/join ", " all-property-names) + ")\nVALUES (" + (s/join ", " (map keyword all-property-names)) + ")\n\n"))) + + +(defn update-query [entity-map] + (if + (and + (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$" "") + property-names (remove + nil? + (map + #(if (= (:tag %) :property) (:name (:attrs %))) + (vals (:properties (:content entity-map)))))] + (str "-- :name update-" pretty-name "! :! :n\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")))) + + +(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$" "")] + (str "-- :name get-" pretty-name "! :! :n\n" + "-- :doc updates an existing " pretty-name " record\n" + "SELECT * FROM " entity-name "\n" + (where-clause entity-map) + "\n\n")))) + + +(defn delete-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$" "")] + (str "-- :name delete-" pretty-name "! :! :n\n" + "-- :doc updates an existing " pretty-name " record\n" + "DELETE FROM " entity-name "\n" + (where-clause entity-map) + "\n\n")))) + + +(defn queries + [entity-map] + (str + (insert-query entity-map) + (update-query entity-map) + (select-query entity-map) + (delete-query entity-map))) + + +(defn migrations-to-queries-sql + ([migrations-path] + (migrations-to-queries-sql migrations-path "queries.sql")) + ([migrations-path output] + (let + [adl-struct (migrations-to-xml migrations-path "Ignored") + file-content (apply str (map queries (vals adl-struct)))] + (spit output file-content) + file-content)))