No longer actually generates XML, but structure is more usable

src/squirrel_parse/parser.clj

@@ -244,7 +244,8 @@
 
     "PERMISSIONS-STMT := REVOKE-STMT | GRANT-STMT;"
     "REVOKE-STMT := KW-REVOKE PERMISSIONS KW-ON OPT-KW-SCHEMA QUAL-NAME KW-FROM NAMES TERMINATOR;"
-    "GRANT-STMT := KW-GRANT PERMISSIONS KW-ON OPT-KW-SCHEMA QUAL-NAME KW-TO NAMES TERMINATOR;"
+    "GRANT-STMT := KW-GRANT PERMISSIONS KW-ON OPT-KW-SCHEMA QUAL-NAME KW-TO OPT-ROLE NAMES TERMINATOR;"
+    "OPT-ROLE := ROLE | '';"
 
     "PERMISSIONS := PERMISSION-COMMA * PERMISSION ;"
     "PERMISSION-COMMA := PERMISSION COMMA ;"

src/squirrel_parse/simplify.clj

@@ -36,10 +36,12 @@
   [x]
   (and
     (coll? x)(contains? #{:COMMENT
-                          :SPACE
+                          :LPAR
                           :OPT-KW-DATA
                           :OPT-SPACE
                           :QUOTE-MK
+                          :RPAR
+                          :SPACE
                           :TERMINATOR} (first x))))
 
 
@@ -88,6 +90,8 @@
         :ALTER-SEQ-ELEMENT
         :ALTER-STMT
         :ALTER-TABLE-ELEMENT
+        :CREATE-STMT
+        :EXPRESSION
         :MATCH-TYPE
         :ONLY
         :OPT-KW-SCHEMA
@@ -107,7 +111,8 @@
         :TABLE-SPEC-ELEMENT
         :TC-ELEMENT
         :VALUE) (simplify-second-of-two tree)
-      (:PERMISSION-COMMA) (in-simplify (nth tree 1))
+      (:PERMISSION-COMMA
+        :TABLE-SPEC-ELT-COMMA) (in-simplify (nth tree 1))
       (:ROLE) (first tree)
       (remove nil? (map in-simplify tree)))
     tree))

src/squirrel_parse/to_adl.clj

@@ -5,7 +5,8 @@
             [clj-time.core :refer [now]]
             [clj-time.format :refer [formatters unparse]]
             [squirrel-parse.parser :refer [parse]]
-            [squirrel-parse.simplify :refer [simplify]]))
+            [squirrel-parse.simplify :refer [simplify]]
+            [squirrel-parse.utils :refer [deep-merge]]))
 
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -68,10 +69,43 @@
   [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 map-to-xml
+  [m]
+  (if
+    (map? m)
+    (interleave (keys m) (map map-to-xml (vals m)))
+    m))
+
+
+
 (defn is-create-table-statement?
   "Is this statement a create table statement?"
   [statement]
-  (is-subtree-of-type? statement :TABLE-DECL))
+  (is-subtree-of-type? statement :CREATE-TABLE-STMT))
 
 (defn get-children-of-type [subtree type]
   (if
@@ -84,15 +118,18 @@
              %)
           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."
   [column-spec]
@@ -100,27 +137,32 @@
         sql-datatype (first (second datatype-spec))]
     (sql-datatype-to-adl-datatype sql-datatype)))
 
+
 (defn make-property
   "Make an ADL property representing this column specification."
   [column-spec]
   (if
     (is-subtree-of-type? (second column-spec) :COLUMN-SPEC)
     (make-property (second column-spec))
-    {:tag :property
+    (let [name (get-name column-spec)]
-     :attrs
+      {(keyword name)
-     {
+       {:tag :property
-       :name (get-name column-spec)
+        :attrs
-       :type (get-column-datatype column-spec)
+        {
-       }}
+          :name (get-name column-spec)
-    ))
+          :type (get-column-datatype column-spec)
+          }}}
+      )))
+
 
 (defn make-entity [table-decl]
   "Make an ADL entity representing this table declaration"
   {:tag :entity
-    :name (get-name table-decl)
+   :name (get-name table-decl)
-    :content
+   :content
+   {:properties
     (apply
-      vector
+      merge
       (map
         make-property
         (remove
@@ -129,10 +171,11 @@
             #(if
                (is-subtree-of-type? % :COLUMN-SPEC)
                %)
-            (get-first-child-of-type table-decl :TABLE-SPEC-ELEMENTS)))))})
+            (get-first-child-of-type table-decl
+                                     :TABLE-SPEC-ELEMENTS)))))}})
 
 
-(defn table-definition-to-entity
+(defn table-definition-to-map
   "Return a map like this `map` with, if this `statement` is a table declaration,
   an ADL entity representing that table added to it."
   [entity-map statement]
@@ -142,15 +185,119 @@
       (merge entity-map {table-name (make-entity statement)}))
     entity-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?
+  [statement]
+  (is-column-constraint-statement-of-type? statement :PRIMARY-CC))
+
+
+(defn decorate-with-relationship
+  [entity-map statement]
+  (if
+    (is-foreign-key-statement? statement)
+    (let [sm (subtree-to-map (is-foreign-key-statement? statement))
+          table (:name entity-map)
+          ns-table (:NAME (:QUAL-NAME (:ALTER-TABLE (subtree-to-map statement))))
+          ns-cols (:NAME (:NAMES sm))
+          fs-table (:NAME (:REFERENCES-CC sm))
+          fs-cols (:NAME (:NAMES (:REFERENCES-CC sm)))]
+      (println (str
+                 "table:    " table
+                 "\n\tns-table: " ns-table
+                 "\n\tns-cols:  " ns-cols
+                 "\n\tfs-table: " fs-table
+                 "\n\tfs-cols:  " fs-cols))
+      (cond
+        (not
+          (= table ns-table))
+        ;; this statement doesn't refer to us...
+        entity-map
+        true
+        (deep-merge
+          entity-map
+          {:content
+           {:properties
+            {(keyword ns-cols)
+             {:attrs
+              {:type "entity" :entity fs-table :farkey fs-cols}}}}})))))
+
+
+(defn decorate-with-primary-key
+  [entity-map statement]
+  (if
+    (is-primary-key-statement? statement)
+    (let [sm (subtree-to-map (is-primary-key-statement? statement))
+          table (:name 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))]
+      (if
+        (= table st-table)
+        (merge
+          entity-map
+          {:content
+           (merge
+             (:content entity-map)
+             {:key {col (properties col)}
+              :properties (dissoc properties col)})})
+        entity-map))
+    entity-map))
+
+
+(defn decorate-with-all
+  [entity-map statements function]
+  (reduce
+    deep-merge
+    entity-map
+    (remove
+      nil?
+      (map function statements))))
+
+
 (defn table-definitions-to-entities
   "Extract table definitions from these `statements` as a map of ADL
-   entities indexed by name."
+  entities indexed by name."
-  ([statements]
-   (reduce table-definition-to-entity {} statements)))
-
-(defn extract-security-groups-from-statements
   [statements]
-  nil)
+  (let
+    [base-map (reduce table-definition-to-map {} statements)]
+    (apply
+      merge
+      (map
+        (fn [x]
+          (let [entity-map (base-map x)]
+          {x
+           (decorate-with-all
+             (decorate-with-all entity-map statements #(decorate-with-relationship entity-map %))
+             statements
+             #(decorate-with-primary-key entity-map %))}))
+        (keys base-map)))))
 
 
 (defn to-adl
@@ -165,8 +312,7 @@
      {:tag :application
       :attrs {:name application-name
               :version version }
-      :content (vals entities)}
+      :content (vals entities)}))
-     ))
   ([input application-name version output]
    (let [adl (to-adl input application-name version)]
      (spit output (str xml-header "\n" (with-out-str (emit-element adl))))

src/squirrel_parse/utils.clj

@@ -28,6 +28,22 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 
+(defn deep-merge [v & vs]
+  "Filched from https://gist.github.com/danielpcox/c70a8aa2c36766200a95"
+  (letfn [(rec-merge [v1 v2]
+                     (if (and (map? v1) (map? v2))
+                       (merge-with deep-merge v1 v2)
+                       v2))]
+    (when (some identity vs)
+      (reduce #(rec-merge %1 %2) v vs))))
+;;   (letfn [(rec-merge [v1 v2]
+;;             (if (and (map? v1) (map? v2))
+;;               (merge-with deep-merge v1 v2)
+;;               v2))]
+;;     (if (some identity vs)
+;;       (reduce #(rec-merge %1 %2) v vs)
+;;       v)))
+
 (defn- make-unterminated-case-insensitive-match-rule
   "Make a grammar rule which matches this `token` case-insensitively,
   without the terminal semi-colon. Keywords may always optionally be preceded