Much improved

2018-06-14 09:52:18 +01:00 · 2018-06-14 09:52:18 +01:00 · 055eac8092
parent 66ab4a2bc1
commit 055eac8092
2 changed files with 210 additions and 103 deletions
--- a/src/adl/to_psql.clj
+++ b/src/adl/to_psql.clj
@ -46,9 +46,9 @@
  [elements]
  (sort #(.compareTo (:name (:attrs %1)) (:name (:attrs %2))) elements))

+
 (declare emit-field-type emit-property)

-(def comment-rule (apply str (repeat 79 "-")))

 (defn emit-defined-field-type
  [property application]
@ -115,13 +115,7 @@
       "-- ERROR: cannot generate link to entity "
       (:name (:attrs farside))
       " with compound primary key\n")
-      (list
-       (emit-field-type (first key-properties) farside application false)
-       "REFERENCES"
-       (str
-        (:table (:attrs farside)) "(" (:name (:attrs (first key-properties)))) ")"
-       ;; TODO: ought to handle the `cascade` attribute, even though it's rarely used
-       ))))
+       (emit-field-type (first key-properties) farside application false))))


 (defn emit-field-type
@ -135,8 +129,7 @@
    "entity" (emit-entity-field-type property application)
    ("date" "time" "timestamp" "boolean" "text" "money")
              (.toUpperCase (:type (:attrs property)))
-    (str "-- ERROR: unknown type " (:type (:attrs property)))
-    ))
+    (str "-- ERROR: unknown type " (:type (:attrs property)))))


 (defn emit-link-field
@ -172,47 +165,6 @@
      (s/join " " (list "GRANT" (name privilege) "ON"  table-name "TO" (s/join ",\n\t" (sort group-names)) ";")))))


-(defn emit-link-table
-  [property e1 application emitted-link-tables]
-  (let [e2 (child
-            application
-            #(and
-              (entity? %)
-              (= (:name (:attrs %)) (:entity (:attrs property)))))
-        link-table-name (link-table-name e1 e2)
-        permissions (flatten
-                     (list
-                      (children-with-tag e1 :permission)
-                      (children-with-tag e1 :permission)))]
-    (if
-      (not (@emitted-link-tables link-table-name))
-      (do
-        (swap! emitted-link-tables conj link-table-name)
-        (s/join
-         "\n"
-         (list
-          comment-rule
-          (str "--\tlink table joining " (:name (:attrs e1)) " with " (:name (:attrs e2)))
-          comment-rule
-          (s/join " " (list "CREATE TABLE IF NOT EXISTS" link-table-name))
-          "("
-          (emit-link-field property e1 application)
-          (emit-link-field property e2 application)
-          ");"
-          (emit-permissions-grant link-table-name :SELECT permissions)
-          (emit-permissions-grant link-table-name :INSERT permissions)))))))
-
-
-(defn emit-link-tables
-  [entity application emitted-link-tables]
-  (map
-   #(emit-link-table % entity application emitted-link-tables)
-   (sort-by-name
-    (filter
-     #(= (:type (:attrs %)) "link")
-     (properties entity)))))
-
-
 (defn emit-property
  ([property entity application]
   (emit-property property entity application false))
@ -328,9 +280,9 @@
      nil?
      (flatten
       (list
-        comment-rule
-        (str "--\tconvenience view " view-name " of entity " (:name (:attrs entity)) " for lists, et cetera")
-        comment-rule
+        (emit-header
+         "--"
+         (str "convenience view " view-name " of entity " (:name (:attrs entity)) " for lists, et cetera"))
        (s/join
         " "
         (list "CREATE VIEW" view-name "AS"))
@ -375,17 +327,65 @@
        (emit-permissions-grant view-name :SELECT (permissions entity application))))))))


+(defn emit-referential-integrity-link
+  [property nearside application]
+  (let
+    [farside (entity-for-property property application)]
+    (s/join
+     " "
+     (list
+      "ALTER TABLE"
+      (:name (:attrs nearside))
+      "ADD CONSTRINT"
+      (str "ri_" (:name (:attrs nearside)) "_" (:name (:attrs farside)) "_" (:name (:attrs property)))
+      "\n\tFOREIGN KEY("
+      (:name (:attrs property))
+      ") \n\tREFERENCES"
+      (str
+       (:table (:attrs farside)) "(" (:name (:attrs (first (key-properties farside)))) ")")
+      ;; TODO: ought to handle the `cascade` attribute, even though it's rarely used
+      "\n\tON DELETE"
+      (case
+        (:cascade (:attrs property))
+        "orphan" "SET NULL"
+        "delete" "CASCADE"
+        "NO ACTION")
+      ";"))))
+
+
+(defn emit-referential-integrity-links
+  ([entity application]
+   (map
+    #(emit-referential-integrity-link % entity application)
+    (filter
+     #(= (:type (:attrs %)) "entity")
+     (properties entity))))
+  ([application]
+   (flatten
+    (list
+     (emit-header
+      "--"
+      (str "--\treferential integrity links for first-class tables"))
+     (map
+      #(emit-referential-integrity-links % application)
+      (children-with-tag application :entity))))))
+
+
 (defn emit-table
-  [entity application]
+  ([entity application doc-comment]
   (let [table-name (:table (:attrs entity))
         permissions (children-with-tag entity :permission)]
     (s/join
      "\n"
      (flatten
       (list
-       comment-rule
-       (str "--\tprimary table " table-name " for entity " (:name (:attrs entity)))
-       comment-rule
+        (emit-header
+         "--"
+         (list
+          doc-comment
+          (map
+           #(:content %)
+           (children-with-tag entity :documentation))))
        (s/join
         " "
         (list "CREATE TABLE" table-name))
@ -409,6 +409,75 @@
        (map
         #(emit-permissions-grant table-name % permissions)
         '(:SELECT :INSERT :UPDATE :DELETE)))))))
+  ([entity application]
+   (emit-table
+    entity
+    application
+    (str
+     "primary table "
+     (:table (:attrs entity))
+     " for entity "
+     (:name (:attrs entity))))))
+
+
+(defn construct-link-property
+  [entity]
+  {:tag :property
+   :attrs {:name (str (:name (:attrs entity)) "_id")
+           :column (str (:name (:attrs entity)) "_id")
+           :type "entity"
+           :entity (:name (:attrs entity))
+           :farkey (first (key-names entity))}})
+
+
+(defn emit-link-table
+  [property e1 application emitted-link-tables]
+  (let [e2 (child
+            application
+            #(and
+              (entity? %)
+              (= (:name (:attrs %)) (:entity (:attrs property)))))
+        link-table-name (link-table-name e1 e2)]
+    (if
+      ;; we haven't already emitted this one...
+      (not (@emitted-link-tables link-table-name))
+      (let [permissions (flatten
+                         (list
+                          (children-with-tag e1 :permission)
+                          (children-with-tag e1 :permission)))
+            ;; construct a dummy entity
+            link-entity {:tag :entity
+                         :attrs {:name link-table-name
+                                 :table link-table-name}
+                         :content
+                         (vector
+                          (concat
+                           [(construct-link-property e1)
+                            (construct-link-property e2)]
+                           permissions))}]
+        ;; mark it as emitted
+        (swap! emitted-link-tables conj link-table-name)
+        ;; emit it
+        (emit-table
+         link-entity
+         application
+         (str
+          "link table joining "
+          (:name (:attrs e1))
+          " with "
+          (:name (:attrs e2))))
+        ;; and immediately emit its referential integrity links
+        (emit-referential-integrity-links link-entity application)))))
+
+
+(defn emit-link-tables
+  [entity application emitted-link-tables]
+  (map
+   #(emit-link-table % entity application emitted-link-tables)
+   (sort-by-name
+    (filter
+     #(= (:type (:attrs %)) "link")
+     (properties entity)))))


 (defn emit-entity
@ -421,30 +490,27 @@

 (defn emit-group-declaration
  [group application]
-  (s/join
-   "\n"
  (list
-    comment-rule
-    (str "--\tsecurity group " (:name (:attrs group)))
-    comment-rule
-    (str "CREATE GROUP " (:name (:attrs group)) ";"))))
+   (emit-header
+    "--"
+    (str "security group " (:name (:attrs group))))
+   (str "CREATE GROUP " (:name (:attrs group)) ";")))


 (defn emit-file-header
  [application]
-  (s/join
-   "\n"
-   (list
-    comment-rule
-    (str
-     "--\tDatabase definition for application "
-     (:name (:attrs application))
+  (emit-header
+   "--"
+   "Database definition for application "
+   (str (:name (:attrs application))
        " version "
        (:version (:attrs application)))
-    (str
-     "--\tauto-generated by [Application Description Language framework](https://github.com/simon-brooke/adl) at "
+   "auto-generated by [Application Description Language framework]"
+   (str "(https://github.com/simon-brooke/adl) at "
        (f/unparse (f/formatters :basic-date-time) (t/now)))
-    comment-rule)))
+   (map
+    #(:content %)
+    (children-with-tag application :documentation))))


 (defn emit-application
@ -463,6 +529,7 @@
        #(emit-entity % application)
        (sort-by-name
         (children-with-tag application :entity)))
+       (emit-referential-integrity-links application)
       (map
        #(emit-link-tables % application emitted-link-tables)
        (sort-by-name
--- a/src/adl/utils.clj
+++ b/src/adl/utils.clj
@ -2,6 +2,7 @@
      :author "Simon Brooke"}
  adl.utils
  (:require [clojure.string :as s]
+            [clojure.pprint :as p]
            [clojure.xml :as x]
            [adl.validator :refer [valid-adl? validate-adl]]))

@ -38,6 +39,40 @@
  "resources/auto/")


+(defn wrap-lines
+  "Wrap lines in this `text` to this `width`; return a list of lines."
+  ;; Shamelessly adapted from https://www.rosettacode.org/wiki/Word_wrap#Clojure
+  [width text]
+  (s/split-lines
+   (p/cl-format
+    nil
+    (str "~{~<~%~1," width ":;~A~> ~}")
+    (clojure.string/split text #" "))))
+
+
+(defn emit-header
+  "Emit this `content` as a sequence of wrapped lines each prefixed with
+  `prefix`, and the whole delimited by rules."
+  [prefix & content]
+  (let [comment-rule (apply str (repeat 70 (last prefix)))
+        p (str "\n" prefix "\t") ]
+    (str
+     prefix
+     comment-rule
+     p
+     (s/join
+      p
+      (flatten
+       (interpose
+        ""
+         (map
+          #(wrap-lines 70 (str %))
+          (flatten content)))))
+     "\n"
+     prefix
+     comment-rule)))
+
+
 (defn link-table-name
  "Canonical name of a link table between entity `e1` and entity `e2`."
  [e1 e2]
@ -213,7 +248,6 @@
  (capitalise (singularise (:name (:attrs entity)))))


-
 (defn safe-name
  ([string]
    (s/replace string #"[^a-zA-Z0-9-]" ""))
@ -234,6 +268,7 @@
        links (filter #(-> % :attrs :entity) properties)]
    (= (count properties) (count links))))

+
 (defn read-adl [url]
  (let [adl (x/parse url)
        valid? (valid-adl? adl)]
@ -249,17 +284,20 @@
    element
    (children element #(= (:tag %) tag))))

+
 (defn child-with-tag
  "Return the first child of this `element` which has this `tag`;
  if `element` is `nil`, return `nil`."
  [element tag]
  (first (children-with-tag element tag)))

+
 (defmacro properties
  "Return all the properties of this `entity`."
  [entity]
  `(children-with-tag ~entity :property))

+
 (defn descendants-with-tag
  "Return all descendants of this `element`, recursively, which have this `tag`."
  [element tag]
@ -302,10 +340,12 @@
     insertable?
     (all-properties ~entity)))

+
 (defmacro key-properties
  [entity]
  `(children-with-tag (first (children-with-tag ~entity :key)) :property))

+
 (defmacro insertable-key-properties
  [entity]
  `(filter insertable? (key-properties entity)))