From 8af1ceaa3808cc7d6c436f07a54c1169cc7d1e23 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 7 Mar 2018 13:46:55 +0000 Subject: [PATCH 1/7] This doesn't work, but it's in the right direction --- src/squirrel_parse/to_adl.clj | 149 ++++++++++++++++++++++++++-------- 1 file changed, 113 insertions(+), 36 deletions(-) diff --git a/src/squirrel_parse/to_adl.clj b/src/squirrel_parse/to_adl.clj index d3d4652..456185d 100644 --- a/src/squirrel_parse/to_adl.clj +++ b/src/squirrel_parse/to_adl.clj @@ -1,7 +1,8 @@ (ns ^{:doc "A parser for SQL: generate Application Description Language." :author "Simon Brooke"} squirrel-parse.to-adl - (:require [clojure.xml :refer [emit-element]] + (:require [clojure.java.io :refer [file]] + [clojure.xml :refer [emit-element]] [clj-time.core :refer [now]] [clj-time.format :refer [formatters unparse]] [squirrel-parse.parser :refer [parse]] @@ -42,27 +43,27 @@ (def sql-datatype-to-adl-datatype "Map to convert SQL datatypes to the nearest ADL equivalent." - {:DT-BIGINT :integer - :DT-BIGSERIAL :integer - :DT-BIT :integer - :DT-BOOLEAN :boolean - :DT-BYTEA :unsupported - :DT-DATE :date - :DT-DOUBLE-PRECISION :real - :DT-FLOAT :real - :DT-INTEGER :integer - :DT-MONEY :money - :DT-NUMERIC :real - :DT-REAL :real - :DT-SERIAL :integer - :DT-TEXT :text - :DT-CHAR :string - :DT-CHARACTER :string - :DT-CHARACTER-VARYING :string - :DT-VARCHAR :string - :DT-TIME :string - :DT-TIMESTAMP :timestamp - :DT-INTERVAL :unsupported + {:DT-BIGINT "integer" + :DT-BIGSERIAL "integer" + :DT-BIT "integer" + :DT-BOOLEAN "boolean" + :DT-BYTEA "unsupported" + :DT-DATE "date" + :DT-DOUBLE-PRECISION "real" + :DT-FLOAT "real" + :DT-INTEGER "integer" + :DT-MONEY "money" + :DT-NUMERIC "real" + :DT-REAL "real" + :DT-SERIAL "integer" + :DT-TEXT "text" + :DT-CHAR "string" + :DT-CHARACTER "string" + :DT-CHARACTER-VARYING "string" + :DT-VARCHAR "string" + :DT-TIME "string" + :DT-TIMESTAMP "timestamp" + :DT-INTERVAL "unsupported" }) (defn is-subtree-of-type? @@ -136,12 +137,30 @@ (if (is-subtree-of-type? (second column-spec) :COLUMN-SPEC) (make-property (second column-spec)) - (let [name (get-name column-spec)] + (let [name (get-name column-spec) + size-spec (get-first-child-of-type column-spec :INT-VAL) + size (if size-spec (nth size-spec 1)) + constraints (get-first-child-of-type column-spec :COLUMN-CONSTRAINTS) + required? (get-first-child-of-type constraints :NOT-NULL-CC) + default? (get-first-child-of-type constraints :DEFAULT-CC) + dflt-val (if default? (nth default? 2))] {(keyword name) {:tag :property :attrs - {:name (get-name column-spec) - :type (get-column-datatype column-spec)}}}))) + (merge + (if size {:size size} {}) + (if required? {:required "true"} {}) + (if default? {:default dflt-val}) + {:name name + :column name + :type (get-column-datatype column-spec)}) + :content + {:prompts + {:en-GB + {:tag :prompt + :attrs + {:prompt name + :local "en-GB"}}}}}}))) (defn make-entity-map [table-decl] @@ -150,7 +169,8 @@ :attrs {:name (get-name table-decl)} :content - {:properties + {:key {:content {}} + :properties (apply merge (map @@ -177,6 +197,8 @@ (defn is-column-constraint-statement-of-type? + "Returns non-nil (actually the relevant fragment) if `statement` is an + 'alter table... add column constraint' statement with the specified `key`" [statement key] (and (is-subtree-of-type? statement :ALTER-TABLE) @@ -192,8 +214,7 @@ (:COLUMN-CONSTRAINT (:ADD-CONSTRAINT (:ALTER-TABLE-ELEMENTS - (:ALTER-TABLE sm)))))) - )))) + (:ALTER-TABLE sm)))))))))) (defn is-foreign-key-statement? @@ -237,25 +258,37 @@ (defn decorate-with-primary-key "If this `statement` is a primary key statement, return an entity-map like this `entity-map` - but with the relevant property removed from the 'content' sub-element and added to the 'key' - sub-element." + but with the relevant property moved into 'keys'." [entity-map statement] (if (is-primary-key-statement? statement) (let [sm (subtree-to-map (is-primary-key-statement? statement)) - table (:name (:attrs entity-map)) + em-table (:name (:attrs entity-map)) st-table (:NAME (:QUAL-NAME (:ALTER-TABLE (subtree-to-map statement)))) col (keyword (:NAME (:NAMES (:INDEX-PARAMS sm)))) - properties (:properties (:content entity-map))] + properties (:properties (:content entity-map)) + property (col properties) + remaining-properties (dissoc properties col) + pk (merge + (:content (:key (:content entity-map))) + {:content + {col + (merge + property + {:attrs + (merge (:attrs property) + {:distinct "system" :immutable "true" :required "true"})})}})] (if - (= table st-table) - (deep-merge + (= em-table st-table) + (merge entity-map {:content - {:properties - {col {:tag :key}}}}))))) + {:key pk + :properties remaining-properties }}))))) +;; (merge electors {:content (merge (:content electors) {:properties (dissoc (:properties (:content electors)) :id :email)})}) + (defn decorate-with-all "Apply this `function` to this `entity-map` and each of these statements in sequence, and return a merge of the map with each of the statements @@ -307,6 +340,17 @@ (map to-adl-xml (vals (:properties (:content object))))}) + (:property :key) + (merge + object + {:content + (map + to-adl-xml + (apply + concat + (map + #(vals (% (:content object))) + '(:permissions :options :prompts :helps :ifmissings))))}) (apply assoc (cons {} (interleave (keys object) (map to-adl-xml (vals object)))))) true object)) @@ -329,3 +373,36 @@ (let [adl (to-adl input application-name version)] (spit output (str xml-header "\n" (with-out-str (emit-element adl)))) adl))) + +(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 application-name] + (migrations-to-xml migrations-path application-name (unparse (formatters :basic-date) (now)))) + ([migrations-path application-name version] + (migrations-to-xml migrations-path application-name version nil)) + ([migrations-path application-name version output] + (let + [filenames + (filter + #(re-matches #".*\.up\.sql" %) + (map + #(.getAbsolutePath %) + (filter + #(.isFile %) + (file-seq (file migrations-path))))) + statements (simplify + (apply concat (map #(parse (slurp %)) filenames))) + entities + (table-definitions-to-entities + statements) + adl {:tag :application + :attrs {:name application-name + :version version } + :content (to-adl-xml (vals entities))}] + (if + output + (spit output (str xml-header "\n" (with-out-str (emit-element adl))))) + entities))) + From fdef14c0f564e1850ec2f9a4cb252a6c0292c9d7 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 12 Mar 2018 18:41:27 +0000 Subject: [PATCH 2/7] Added a fairly simple-minded HugSQL query file generator --- src/squirrel_parse/to_adl.clj | 5 +- src/squirrel_parse/to_hugsql_queries.clj | 110 +++++++++++++++++++++++ 2 files changed, 113 insertions(+), 2 deletions(-) create mode 100644 src/squirrel_parse/to_hugsql_queries.clj 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))) From 8acfc0038d086da2000b199ceb065619936d2eb8 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Tue, 13 Mar 2018 18:48:16 +0000 Subject: [PATCH 3/7] Minor improvements to generated HugSQL queries. --- src/squirrel_parse/to_hugsql_queries.clj | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) diff --git a/src/squirrel_parse/to_hugsql_queries.clj b/src/squirrel_parse/to_hugsql_queries.clj index d2b19e8..d82bd94 100644 --- a/src/squirrel_parse/to_hugsql_queries.clj +++ b/src/squirrel_parse/to_hugsql_queries.clj @@ -35,13 +35,17 @@ 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" + (str "-- :name create-" pretty-name "! : Date: Fri, 16 Mar 2018 12:53:55 +0000 Subject: [PATCH 4/7] Moved utility fns into utils; fixed resolving links. --- src/squirrel_parse/to_adl.clj | 126 ++++++++-------------------------- src/squirrel_parse/utils.clj | 101 +++++++++++++++++++++++++++ 2 files changed, 128 insertions(+), 99 deletions(-) diff --git a/src/squirrel_parse/to_adl.clj b/src/squirrel_parse/to_adl.clj index 832d457..c3ca709 100644 --- a/src/squirrel_parse/to_adl.clj +++ b/src/squirrel_parse/to_adl.clj @@ -2,12 +2,13 @@ :author "Simon Brooke"} squirrel-parse.to-adl (:require [clojure.java.io :refer [file]] + [clojure.string :as s] [clojure.xml :refer [emit-element]] [clj-time.core :refer [now]] [clj-time.format :refer [formatters unparse]] [squirrel-parse.parser :refer [parse]] [squirrel-parse.simplify :refer [simplify]] - [squirrel-parse.utils :refer [deep-merge]] + [squirrel-parse.utils :refer :all] )) @@ -51,6 +52,7 @@ :DT-DATE "date" :DT-DOUBLE-PRECISION "real" :DT-FLOAT "real" + :DT-INT "integer" :DT-INTEGER "integer" :DT-MONEY "money" :DT-NUMERIC "real" @@ -66,62 +68,6 @@ :DT-INTERVAL "unsupported" }) -(defn is-subtree-of-type? - "Is this `subtree` a parser subtree of the specified `type`, expected to be a keyword?" - [subtree type] - (and (coll? subtree) (= (first subtree) type))) - - -(defn subtree? - "Does this `subtree` appear to be a subtree of a parse tree?" - [subtree] - (and (seq? subtree) (keyword? (first subtree)))) - - -(defn subtree-to-map - "Converts `subtree` to a map. **Note** that this will return unexpected - results if the subtree contains repeating entries of the same type - (i.e. having the same initial keyword), as only the last of such - a sequence will be retained. Use with care." - [subtree] - (if - (subtree? subtree) - (if - (and - (> (count subtree) 1) - (reduce #(and %1 %2) (map seq? (rest subtree)))) - {(first subtree) (reduce merge {} (map subtree-to-map (rest subtree)))} - {(first subtree) (first (rest subtree))}) - subtree)) - - -(defn is-create-table-statement? - "Is this statement a create table statement?" - [statement] - (is-subtree-of-type? statement :CREATE-TABLE-STMT)) - -(defn get-children-of-type [subtree type] - (if - (coll? subtree) - (remove - nil? - (map - #(if - (and (coll? %) (= (first %) type)) - %) - subtree)))) - - -(defn get-first-child-of-type [subtree type] - (first (get-children-of-type subtree type))) - - -(defn get-name - "Return the value the first top-level :NAME element of this `subtree`." - [subtree] - (let [name-elt (get-first-child-of-type subtree :NAME)] - (if name-elt (second name-elt)))) - (defn get-column-datatype "Get the datatype of this column specification." @@ -132,7 +78,9 @@ (defn make-property - "Make an ADL property representing this column specification." + "Make an ADL property representing this column specification. + TODO: many things, but does not cope with multi-column foreign keys. + TODO: default value is not extracted correctly." [column-spec] (if (is-subtree-of-type? (second column-spec) :COLUMN-SPEC) @@ -140,10 +88,11 @@ (let [name (get-name column-spec) size-spec (get-first-child-of-type column-spec :INT-VAL) size (if size-spec (nth size-spec 1)) - constraints (get-first-child-of-type column-spec :COLUMN-CONSTRAINTS) - required? (get-first-child-of-type constraints :NOT-NULL-CC) - default? (get-first-child-of-type constraints :DEFAULT-CC) - dflt-val (if default? (nth default? 2))] + constraints (rest (get-first-child-of-type column-spec :COLUMN-CONSTRAINTS)) + required? (first (filter #(get-first-child-of-type % :NOT-NULL-CC) constraints)) + default? (first (filter #(get-first-child-of-type % :DEFAULT-CC) constraints)) + foreign? (first (filter #(get-first-child-of-type % :REFERENCES-CC) constraints)) + dflt-val (if (and default? (> (count default?) 2)) (nth (nth default? 1) 2))] {(keyword name) {:tag :property :attrs @@ -151,9 +100,15 @@ (if size {:size size} {}) (if required? {:required "true"} {}) (if default? {:default dflt-val}) + (if + foreign? + (let [subtree-map (subtree-to-map foreign?)] + {:type "entity" + :entity (-> subtree-map :COLUMN-CONSTRAINT :REFERENCES-CC :NAME) + :farkey (-> subtree-map :COLUMN-CONSTRAINT :REFERENCES-CC :NAMES :NAME)}) + {:type (get-column-datatype column-spec)}) {:name name - :column name - :type (get-column-datatype column-spec)}) + :column name}) :content {:prompts {:en-GB @@ -196,41 +151,6 @@ entities-map)) -(defn is-column-constraint-statement-of-type? - "Returns non-nil (actually the relevant fragment) if `statement` is an - 'alter table... add column constraint' statement with the specified `key`" - [statement key] - (and - (is-subtree-of-type? statement :ALTER-TABLE) - (let [sm (subtree-to-map statement)] - (or - (key - (:COLUMN-CONSTRAINT - (:ADD-CONSTRAINT - (:ALTER-TABLE-ELEMENTS - (:ALTER-TABLE sm))))) - (key - (:COLUMN-CONSTRAINT - (:COLUMN-CONSTRAINT - (:ADD-CONSTRAINT - (:ALTER-TABLE-ELEMENTS - (:ALTER-TABLE sm)))))))))) - - -(defn is-foreign-key-statement? - "Returns non-nil (actually the relevant fragment) if `statement` is an - 'alter table... add foreign key' statement" - [statement] - (is-column-constraint-statement-of-type? statement :REFERENCES-CC)) - - -(defn is-primary-key-statement? - "Returns non-nil (actually the relevant fragment) if `statement` is an - 'alter table... add primary key' statement" - [statement] - (is-column-constraint-statement-of-type? statement :PRIMARY-CC)) - - (defn decorate-with-relationship "If this `statement` is a foreign key statement, return an entity-map like this `entity-map` but with the relevant property decorated with the appropriate foreign key details" @@ -302,6 +222,14 @@ (map #(apply function (list entity-map %)) statements)))) +;; (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))) + + (defn table-definitions-to-entities "Extract table definitions from these `statements` as a map of ADL entities indexed by name." diff --git a/src/squirrel_parse/utils.clj b/src/squirrel_parse/utils.clj index c794313..f0ead6d 100644 --- a/src/squirrel_parse/utils.clj +++ b/src/squirrel_parse/utils.clj @@ -112,3 +112,104 @@ (make-timezone-clause match false true)))))))) +(defn is-subtree-of-type? + "Is this `subtree` a parser subtree of the specified `type`, expected to be a keyword?" + [subtree type] + (and (coll? subtree) (= (first subtree) type))) + + +(defn subtree? + "Does this `subtree` appear to be a subtree of a parse tree?" + [subtree] + (and (seq? subtree) (keyword? (first subtree)))) + + +(defn subtree-to-map + "Converts `subtree` to a map. **Note** that this will return unexpected + results if the subtree contains repeating entries of the same type + (i.e. having the same initial keyword), as only the last of such + a sequence will be retained. Use with care." + [subtree] + (if + (subtree? subtree) + (if + (and + (> (count subtree) 1) + (reduce #(and %1 %2) (map seq? (rest subtree)))) + {(first subtree) (reduce merge {} (map subtree-to-map (rest subtree)))} + {(first subtree) (first (rest subtree))}) + subtree)) + + +(defn is-column-constraint-statement-of-type? + "Returns non-nil (actually the relevant fragment) if `statement` is an + 'alter table... add column constraint' statement with the specified `key`" + [statement key] + (and + (is-subtree-of-type? statement :ALTER-TABLE) + (let [sm (subtree-to-map statement)] + (or + (key + (:COLUMN-CONSTRAINT + (:ADD-CONSTRAINT + (:ALTER-TABLE-ELEMENTS + (:ALTER-TABLE sm))))) + (key + (:COLUMN-CONSTRAINT + (:COLUMN-CONSTRAINT + (:ADD-CONSTRAINT + (:ALTER-TABLE-ELEMENTS + (:ALTER-TABLE sm)))))))))) + + +(defn is-create-table-statement? + "Is this statement a create table statement?" + [statement] + (is-subtree-of-type? statement :CREATE-TABLE-STMT)) + + +(defn is-foreign-key-statement? + "Returns non-nil (actually the relevant fragment) if `statement` is an + 'alter table... add foreign key' statement" + [statement] + (is-column-constraint-statement-of-type? statement :REFERENCES-CC)) + + +(defn is-primary-key-statement? + "Returns non-nil (actually the relevant fragment) if `statement` is an + 'alter table... add primary key' statement" + [statement] + (is-column-constraint-statement-of-type? statement :PRIMARY-CC)) + + +(defn is-link-table? + [entity-map] + (let [properties (-> entity-map :content :properties vals) + links (filter #(-> % :attrs :entity) properties)] + (= (count properties) (count links)))) + + +(defn get-children-of-type [subtree type] + (if + (coll? subtree) + (remove + nil? + (map + #(if + (and (coll? %) (= (first %) type)) + %) + subtree)))) + + +(defn get-first-child-of-type [subtree type] + (first (get-children-of-type subtree type))) + + +(defn get-name + "Return the value the first top-level :NAME element of this `subtree`." + [subtree] + (let [name-elt (get-first-child-of-type subtree :NAME)] + (if name-elt (second name-elt)))) + + + From f22781edf3d62ed1175c7448c99fcc106bb58fe0 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Fri, 16 Mar 2018 16:21:29 +0000 Subject: [PATCH 5/7] Now generating useful hugsql queries for link tables. --- project.clj | 1 + src/squirrel_parse/to_adl.clj | 3 +- src/squirrel_parse/to_hugsql_queries.clj | 117 +++++++++++++++++++++-- src/squirrel_parse/utils.clj | 24 ++--- 4 files changed, 123 insertions(+), 22 deletions(-) diff --git a/project.clj b/project.clj index 8e9329a..8479349 100644 --- a/project.clj +++ b/project.clj @@ -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"]]) diff --git a/src/squirrel_parse/to_adl.clj b/src/squirrel_parse/to_adl.clj index c3ca709..937cc91 100644 --- a/src/squirrel_parse/to_adl.clj +++ b/src/squirrel_parse/to_adl.clj @@ -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 diff --git a/src/squirrel_parse/to_hugsql_queries.clj b/src/squirrel_parse/to_hugsql_queries.clj index d82bd94..9518016 100644 --- a/src/squirrel_parse/to_hugsql_queries.clj +++ b/src/squirrel_parse/to_hugsql_queries.clj @@ -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] - (str - "WHERE " - (s/join " AND\n\t" (map #(str % " = " (keyword %)) (key-names entity-map))))) + (let + [entity-name (:name (:attrs entity-map))] + (str + "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) - (select-query entity-map) - (delete-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) + (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))) diff --git a/src/squirrel_parse/utils.clj b/src/squirrel_parse/utils.clj index f0ead6d..a23d2a9 100644 --- a/src/squirrel_parse/utils.clj +++ b/src/squirrel_parse/utils.clj @@ -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$" "")) From 63a2d0f9a99c8fa1cb9d1e763a2eccbbff226c3a Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Fri, 16 Mar 2018 16:35:35 +0000 Subject: [PATCH 6/7] A sort of alpha release --- README.md | 6 ++++++ src/squirrel_parse/core.clj | 5 ++++- 2 files changed, 10 insertions(+), 1 deletion(-) diff --git a/README.md b/README.md index ad6450e..80a1356 100644 --- a/README.md +++ b/README.md @@ -10,7 +10,13 @@ structures, for automatic generation of things like This is not production ready code as yet. Nevertheless if you want a sensible entry point, look at the two example functions in `squirrel-parse.core`. +If you want to do something actually a bit useful, try the function +`squirrel-parse.to-hugsql-queries/migrations-to-queries-sql` + +This, given a [Migratus](https://github.com/yogthos/migratus) migrations directory will generate a +[HugSQL](https://www.hugsql.org/) `queries.sql` file which, while it's not +perfect, gets you a very long way. ## Status diff --git a/src/squirrel_parse/core.clj b/src/squirrel_parse/core.clj index d27c830..00e124d 100644 --- a/src/squirrel_parse/core.clj +++ b/src/squirrel_parse/core.clj @@ -1,7 +1,8 @@ (ns squirrel-parse.core (:require [squirrel-parse.parser :refer [parse]] [squirrel-parse.simplify :refer [simplify]] - [squirrel-parse.to-adl :refer [table-definitions-to-entities]])) + [squirrel-parse.to-adl :refer [table-definitions-to-entities]] + [squirrel-parse.to-hugsql-queries :refer [migrations-to-queries-sql]])) ;;; This is get-you-started code. @@ -14,3 +15,5 @@ "Parses the file of SQL commands indicated by `filename`, and returns a more useful map of maps." [filename] (table-definitions-to-entities (parsed-statements-from-file filename))) + + From 8f84b14e01269cd9e8f24b90f878f8262b996be8 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Fri, 16 Mar 2018 16:37:01 +0000 Subject: [PATCH 7/7] Upversioned to 0.1.1 --- project.clj | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/project.clj b/project.clj index 8479349..5efe509 100644 --- a/project.clj +++ b/project.clj @@ -1,4 +1,4 @@ -(defproject squirrel-parse "0.1.0-SNAPSHOT" +(defproject squirrel-parse "0.1.1" :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"