Merge branch 'release/0.1.1'

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
 

project.clj

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

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

src/squirrel_parse/to_adl.clj

@@ -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-BIGINT            "integer"
-   :DT-BIGSERIAL         :integer
+   :DT-BIGSERIAL         "integer"
-   :DT-BIT               :integer
+   :DT-BIT               "integer"
-   :DT-BOOLEAN           :boolean
+   :DT-BOOLEAN           "boolean"
-   :DT-BYTEA             :unsupported
+   :DT-BYTEA             "unsupported"
-   :DT-DATE              :date
+   :DT-DATE              "date"
-   :DT-DOUBLE-PRECISION  :real
+   :DT-DOUBLE-PRECISION  "real"
-   :DT-FLOAT             :real
+   :DT-FLOAT             "real"
-   :DT-INTEGER           :integer
+   :DT-INT               "integer"
-   :DT-MONEY             :money
+   :DT-INTEGER           "integer"
-   :DT-NUMERIC           :real
+   :DT-MONEY             "money"
-   :DT-REAL              :real
+   :DT-NUMERIC           "real"
-   :DT-SERIAL            :integer
+   :DT-REAL              "real"
-   :DT-TEXT              :text
+   :DT-SERIAL            "integer"
-   :DT-CHAR              :string
+   :DT-TEXT              "text"
-   :DT-CHARACTER         :string
+   :DT-CHAR              "string"
-   :DT-CHARACTER-VARYING :string
+   :DT-CHARACTER         "string"
-   :DT-VARCHAR           :string
+   :DT-CHARACTER-VARYING "string"
-   :DT-TIME              :string
+   :DT-VARCHAR           "string"
-   :DT-TIMESTAMP         :timestamp
+   :DT-TIME              "string"
-   :DT-INTERVAL          :unsupported
+   :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)
+        (merge
-         :type (get-column-datatype column-spec)}}})))
+          (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'
+  but with the relevant property moved into 'keys'."
-  sub-element."
   [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)
+        (= em-table st-table)
-        (deep-merge
+        (merge
           entity-map
           {:content
-           {:properties
+           {:key pk
-            {col {:tag :key}}}})))))
+            :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)))
+

src/squirrel_parse/to_hugsql_queries.clj

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

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+")
+  (let [subtokens (s/split token #"\s+")
-        name (join "-" subtokens)]
+        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+")
+  (let [subtokens (s/split token #"\s+")
-        name (join "-" subtokens)
+        name (s/join "-" subtokens)
-        match (join " SPACE " (map #(str "#'(?i)" % "'") 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$" ""))
+