Much improved

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))))
-       (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
-       ))))
 
 
 (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
+        (emit-header
-        (str "--\tconvenience view " view-name " of entity " (:name (:attrs entity)) " for lists, et cetera")
+         "--"
-        comment-rule
+         (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
+        (emit-header
-       (str "--\tprimary table " table-name " for entity " (:name (:attrs entity)))
+         "--"
-       comment-rule
+         (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
+   (emit-header
-    (str "--\tsecurity group " (:name (:attrs group)))
+    "--"
-    comment-rule
+    (str "security group " (:name (:attrs group))))
-    (str "CREATE GROUP " (:name (:attrs group)) ";"))))
+   (str "CREATE GROUP " (:name (:attrs group)) ";")))
 
 
 (defn emit-file-header
   [application]
-  (s/join
+  (emit-header
-   "\n"
+   "--"
-   (list
+   "Database definition for application "
-    comment-rule
+   (str (:name (:attrs application))
-    (str
-     "--\tDatabase definition for application "
-     (:name (:attrs application))
         " version "
         (:version (:attrs application)))
-    (str
+   "auto-generated by [Application Description Language framework]"
-     "--\tauto-generated by [Application Description Language framework](https://github.com/simon-brooke/adl) at "
+   (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

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