Postgres generation is now very close to good.

src/adl/main.clj

@@ -4,6 +4,7 @@
   (:require [adl.utils :refer :all]
             [adl.to-hugsql-queries :as h]
             [adl.to-json-routes :as j]
+            [adl.to-psql :as p]
             [adl.to-selmer-routes :as s]
             [adl.to-selmer-templates :as t]
             [clojure.xml :as x])
@@ -36,7 +37,7 @@
   (println "Argument should be a pathname to an ADL file"))
 
 (defn -main
-  "Expects as arg the name of the git hook to be handled, followed by the arguments to it"
+  "Expects as arg the path-name of an ADL file."
   [& args]
   (cond
     (empty? args)
@@ -45,6 +46,9 @@
     (let [application (x/parse (first args))]
       (h/to-hugsql-queries application)
       (j/to-json-routes application)
+      (p/to-psql application)
       (s/to-selmer-routes application)
       (t/to-selmer-templates application))))
 
+
+

src/adl/to_psql.clj

@@ -35,7 +35,16 @@
 
 
 ;;; this is a pretty straight translation of adl2psql.xslt, and was written because
-;;; Clojure is easier to debug
+;;; Clojure is easier to debug.
+
+;;; TODO: the order in which we generate tables is critical, because tables
+;;; can only reference other tables which already exist. We could get around
+;;; this by generating referential integrity constraints post-hoc, which is
+;;; what the xslt version did.
+
+(defn sort-by-name
+  [elements]
+  (sort #(.compareTo (:name (:attrs %1)) (:name (:attrs %2))) elements))
 
 (declare emit-field-type emit-property)
 
@@ -46,7 +55,49 @@
   (let [typedef (typedef property application)]
     ;; this is a hack based on the fact that emit-field-type doesn't check
     ;; that the argument passed as `property` is indeed a property.
-    (emit-field-type typedef nil application false)))
+    (str (emit-field-type typedef nil application false)
+         (cond
+          (:pattern (:attrs typedef))
+          (str
+           " CONSTRAINT "
+           (gensym "c-")
+           " CHECK ("
+           (:name (:attrs property))
+           " ~* '"
+           (:pattern (:attrs typedef))
+           "')")
+          (and (:maximum (:attrs typedef))(:minimum (:attrs typedef)))
+          ;; TODO: if base type is date, time or timestamp, values should be quoted.
+          (str
+           " CONSTRAINT "
+           (gensym "c-")
+           " CHECK ("
+           (:minimum (:attrs typedef))
+           " < "
+           (:name (:attrs property))
+           " AND "
+           (:name (:attrs property))
+           " < "
+           (:maximum (:attrs typedef))
+           ")")
+          (:maximum (:attrs typedef))
+          (str
+           " CONSTRAINT "
+           (gensym "c-")
+           " CHECK ("
+           (:name (:attrs property))
+           " < "
+           (:maximum (:attrs typedef))
+           ")")
+          (:minimum (:attrs typedef))
+          (str
+           " CONSTRAINT "
+           (gensym "c-")
+           " CHECK ("
+           (:minimum (:attrs typedef))
+           " < "
+           (:name (:attrs property)))))))
+
 
 (defn emit-entity-field-type
   [property application]
@@ -68,7 +119,7 @@
        (emit-field-type (first key-properties) farside application false)
        "REFERENCES"
        (str
-          (:table (:attrs farside)) "(" (:name (:attrs (first key-properties))) ) ")"
+        (:table (:attrs farside)) "(" (:name (:attrs (first key-properties)))) ")"
        ;; TODO: ought to handle the `cascade` attribute, even though it's rarely used
        ))))
 
@@ -76,12 +127,14 @@
 (defn emit-field-type
   [property entity application key?]
   (case (:type (:attrs property))
-    "integer" (if key? "serial" "INTEGER")
+    "integer" (if key? "SERIAL" "INTEGER")
     "real" "DOUBLE PRECISION"
-    ("string" "image" "uploadable") (str "VARCHAR(" (:size (:attrs property)) ")")
+    ("string" "image" "uploadable")
+              (str "VARCHAR(" (:size (:attrs property)) ")")
     "defined" (emit-defined-field-type property application)
     "entity" (emit-entity-field-type property application)
-    ("date" "time" "timestamp" "boolean" "text" "money") (.toUpperCase (:type (:attrs property)))
+    ("date" "time" "timestamp" "boolean" "text" "money")
+              (.toUpperCase (:type (:attrs property)))
     (str "-- ERROR: unknown type " (:type (:attrs property)))
     ))
 
@@ -112,11 +165,11 @@
           nil?
           (map
            #(if (selector (:permission (:attrs %)))
-                 (:name (:attrs %)))
+              (:group (:attrs %)))
            permissions)))]
     (if
       (not (empty? group-names))
-      (s/join " " (list "GRANT" (name privilege) "ON"  table-name "TO" (s/join "," group-names) ";")))))
+      (s/join " " (list "GRANT" (name privilege) "ON"  table-name "TO" (s/join ",\n\t" (sort group-names)) ";")))))
 
 
 (defn emit-link-table
@@ -132,16 +185,16 @@
                       (children-with-tag e1 :permission)
                       (children-with-tag e1 :permission)))]
     (if
-      true ;;(not (@emitted-link-tables link-table-name))
+      (not (@emitted-link-tables link-table-name))
       (do
-        ;; (swap! emitted-link-tables (conj @emitted-link-tables link-table-name))
+        (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" link-table-name))
+          (s/join " " (list "CREATE TABLE IF NOT EXISTS" link-table-name))
           "("
           (emit-link-field property e1 application)
           (emit-link-field property e2 application)
@@ -154,7 +207,10 @@
   [entity application emitted-link-tables]
   (map
    #(emit-link-table % entity application emitted-link-tables)
-    (children entity #(and (= (:tag %) :property) (= (:type (:attrs %)) "link")))))
+   (sort-by-name
+    (filter
+     #(= (:type (:attrs %)) "link")
+     (properties entity)))))
 
 
 (defn emit-property
@@ -168,6 +224,8 @@
         (not (#{"link"} (:type (:attrs property)))))
        (s/join
         " "
+        (remove
+         nil?
          (flatten
           (list
            "\t"
@@ -177,11 +235,10 @@
            (if
              key?
              "NOT NULL PRIMARY KEY"
-               (if (= (:required (:attrs property)) "true") "NOT NULL")))))))))
+             (if (= (:required (:attrs property)) "true") "NOT NULL"))))))))))
 
 
 (defn compose-convenience-entity-field
-  ;; TODO: this is not recursing properly
   [field entity application]
   (let [farside (child
                  application
@@ -220,6 +277,8 @@
 
 
 (defn compose-convenience-where-clause
+  ;; TODO: does not correctly compose links at one stage down the tree.
+  ;; See lv_electors, lv_followuprequests for examples of the problem.
   [entity application top-level?]
   (remove
    nil?
@@ -245,7 +304,6 @@
        (user-distinct-properties entity))))))
 
 
-
 (defn emit-convenience-entity-field
   [field entity application]
   (str
@@ -318,7 +376,7 @@
 
 
 (defn emit-table
-  [entity application emitted-link-tables]
+  [entity application]
   (let [table-name (:table (:attrs entity))
         permissions (children-with-tag entity :permission)]
     (s/join
@@ -330,24 +388,35 @@
        comment-rule
        (s/join
         " "
-            (list "CREATE TABLE " table-name))
+        (list "CREATE TABLE" table-name))
        "("
+       (str
+        (s/join
+         ",\n"
+         (flatten
+          (remove
+           nil?
+           (list
             (map
              #(emit-property % entity application true)
              (children-with-tag (child-with-tag entity :key) :property))
             (map
              #(emit-property % entity application false)
-            (children-with-tag entity :property))
+             (filter
-          ");"
+              #(not (= (:type (:attrs %)) "link"))
+              (children-with-tag entity :property)))))))
+         "\n);")
         (map
          #(emit-permissions-grant table-name % permissions)
          '(:SELECT :INSERT :UPDATE :DELETE)))))))
 
 
 (defn emit-entity
-  [entity application emitted-link-tables]
+  [entity application]
-  (emit-table entity application emitted-link-tables)
+  (doall
-  (emit-convenience-view entity application))
+   (list
+    (emit-table entity application)
+    (emit-convenience-view entity application))))
 
 
 (defn emit-group-declaration
@@ -358,7 +427,7 @@
     comment-rule
     (str "--\tsecurity group " (:name (:attrs group)))
     comment-rule
-      (str "CREATE GROUP IF NOT EXISTS " (:name (:attrs group))))))
+    (str "CREATE GROUP " (:name (:attrs group)) ";"))))
 
 
 (defn emit-file-header
@@ -386,14 +455,27 @@
      (flatten
       (list
        (emit-file-header application)
-          (map #(emit-group-declaration % application) (children-with-tag application :group))
+       (map
-          (map #(emit-entity % application emitted-link-tables) (children-with-tag application :entity))
+        #(emit-group-declaration % application)
-          (map #(emit-link-tables % application emitted-link-tables) (children-with-tag application :entity)))))))
+        (sort-by-name
+         (children-with-tag application :group)))
+       (map
+        #(emit-entity % application)
+        (sort-by-name
+         (children-with-tag application :entity)))
+       (map
+        #(emit-link-tables % application emitted-link-tables)
+        (sort-by-name
+         (children-with-tag application :entity))))))))
 
 
 (defn to-psql
   [application]
-  (let [filepath (str *output-path* "/resources/sql/" (:name (:attrs application)) ".postgres.sql")]
+  (let [filepath (str
+                  *output-path*
+                  "/resources/sql/"
+                  (:name (:attrs application))
+                  ".postgres.sql")]
     (make-parents filepath)
     (spit filepath (emit-application application))))
 

src/adl/utils.clj

@@ -88,12 +88,11 @@
   [property application]
   (if
     (= (:type (:attrs property)) "defined")
-    (first
+    (child
-      (children
      application
      #(and
        (= (:tag %) :typedef)
-           (= (:name (:attrs %)) (:typedef (:attrs property))))))))
+       (= (:name (:attrs %)) (:typedef (:attrs property)))))))
 
 
 (defn permissions
@@ -352,20 +351,13 @@
     (keyword? form)
     (path-part (first (children-with-tag entity form)) entity application)))
 
+
 (defn editor-name
   "Return the path-part of the editor form for this `entity`. Note:
   assumes the editor form is the first form listed for the entity."
   [entity application]
   (path-part :form entity application))
 
-(defn typedef
-  [property application]
-  (first
-    (children application
-              #(and
-                 (= (:tag %) :typedef)
-                 (= (:name (:attrs %))
-                    (:definition (:attrs property)))))))
 
 (defn type-for-defined
   [property application]