From 8af1ceaa3808cc7d6c436f07a54c1169cc7d1e23 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 7 Mar 2018 13:46:55 +0000 Subject: [PATCH] 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))) +