This doesn't work, but it's in the right direction

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-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-INTEGER           "integer"
-   :DT-MONEY             :money
+   :DT-MONEY             "money"
-   :DT-NUMERIC           :real
+   :DT-NUMERIC           "real"
-   :DT-REAL              :real
+   :DT-REAL              "real"
-   :DT-SERIAL            :integer
+   :DT-SERIAL            "integer"
-   :DT-TEXT              :text
+   :DT-TEXT              "text"
-   :DT-CHAR              :string
+   :DT-CHAR              "string"
-   :DT-CHARACTER         :string
+   :DT-CHARACTER         "string"
-   :DT-CHARACTER-VARYING :string
+   :DT-CHARACTER-VARYING "string"
-   :DT-VARCHAR           :string
+   :DT-VARCHAR           "string"
-   :DT-TIME              :string
+   :DT-TIME              "string"
-   :DT-TIMESTAMP         :timestamp
+   :DT-TIMESTAMP         "timestamp"
-   :DT-INTERVAL          :unsupported
+   :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)
+        (merge
-         :type (get-column-datatype column-spec)}}})))
+          (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'
+  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
@@ -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)))
+