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

Merge branch 'release/0.1.1'

Browse source
This commit is contained in:
Simon Brooke 2018-03-16 16:37:12 +00:00
parent 0be87038f0 8f84b14e01
commit a43e10c49b
6 changed files with 470 additions and 139 deletions

6
README.md
View file

@ -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

3
project.clj
View file

@ -1,8 +1,9 @@
(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"
: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"]])

5
src/squirrel_parse/core.clj
View file

@ -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)))

259
src/squirrel_parse/to_adl.clj
View file

@ -1,12 +1,14 @@
(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.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]
))
@ -42,85 +44,30 @@
(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-INT "integer"
: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?
"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."
@ -131,17 +78,44 @@
(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)
(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 (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
{: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})
(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})
:content
{:prompts
{:en-GB
{:tag :prompt
:attrs
{:prompt name
:local "en-GB"}}}}}})))
(defn make-entity-map [table-decl]
@ -150,7 +124,8 @@
:attrs
{:name (get-name table-decl)}
:content
{:properties
{:key {:content {}}
:properties
(apply
merge
(map
@ -176,40 +151,6 @@
entities-map))
(defn is-column-constraint-statement-of-type?
[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"
@ -237,25 +178,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
@ -269,6 +222,15 @@
(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 link-tables)))
(defn table-definitions-to-entities
"Extract table definitions from these `statements` as a map of ADL
entities indexed by name."
@ -307,6 +269,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 +302,37 @@
(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` (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]
(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)))

211
src/squirrel_parse/to_hugsql_queries.clj Normal file
View file

@ -0,0 +1,211 @@
(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.math.combinatorics :refer [combinations]]
[clojure.string :as s]
[squirrel-parse.to-adl :refer [migrations-to-xml]]
[squirrel-parse.utils :refer [is-link-table? singularise]]))
(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]
(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]
(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"
"-- :doc creates a new " pretty-name " record\n"
"INSERT INTO " entity-name " ("
(s/join ",\n\t" all-property-names)
")\nVALUES ("
(s/join ",\n\t" (map keyword all-property-names))
")"
(if
(has-primary-key? entity-map)
(str "\nreturning " (s/join ",\n\t" (key-names entity-map))))
"\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 " :? :1\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)
(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 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)
(list-query entity-map)
(foreign-queries entity-map entities-map)))))
(defn migrations-to-queries-sql
([migrations-path]
(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 % adl-struct) (vals adl-struct)))]
(spit output file-content)
file-content)))

125
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
@ -112,3 +112,106 @@
(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))))
(defn singularise [string]
(s/replace (s/replace string #"_" "-") #"s$" ""))