ADL now successfully generates the whole db definition for YouYesYet

src/adl/to_hugsql_queries.clj

@@ -1,7 +1,7 @@
 (ns ^{:doc "Application Description Language - generate HUGSQL queries file."
       :author "Simon Brooke"}
   adl.to-hugsql-queries
-  (:require [clojure.java.io :refer [file]]
+  (:require [clojure.java.io :refer [file make-parents]]
             [clojure.math.combinatorics :refer [combinations]]
             [clojure.string :as s]
             [clojure.xml :as x]
@@ -416,22 +416,22 @@
 (defn to-hugsql-queries
   "Generate all [HugSQL](https://www.hugsql.org/) queries implied by this ADL `application` spec."
   [application]
+  (let [file-path (str *output-path* "resources/sql/queries.sql")]
+    (make-parents file-path)
     (spit
-    (str *output-path* "queries.sql")
+      file-path
       (s/join
         "\n\n"
         (cons
-        (s/join
+          (emit-header
-          "\n-- "
+            "--"
-          (list
+            "File queries.sql"
-            "-- File queries.sql"
+            (str "autogenerated by adl.to-hugsql-queries at " (t/now))
-            "autogenerated by adl.to-hugsql-queries at"
+            "See [Application Description Language](https://github.com/simon-brooke/adl).")
-            (t/now)
-            "See [Application Description Language](https://github.com/simon-brooke/adl).\n\n"))
           (map
             #(:query %)
             (sort
               #(compare (:name %1) (:name %2))
               (vals
-                (queries application))))))))
+                (queries application)))))))))
 

src/adl/to_psql.clj

@@ -37,16 +37,6 @@
 ;;; this is a pretty straight translation of adl2psql.xslt, and was written because
 ;;; 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)
 
 
@@ -60,7 +50,7 @@
           (:pattern (:attrs typedef))
           (str
            " CONSTRAINT "
-           (gensym "c-")
+           (gensym "pattern_")
            " CHECK ("
            (:name (:attrs property))
            " ~* '"
@@ -70,7 +60,7 @@
           ;; TODO: if base type is date, time or timestamp, values should be quoted.
           (str
            " CONSTRAINT "
-           (gensym "c-")
+           (gensym "minmax_")
            " CHECK ("
            (:minimum (:attrs typedef))
            " < "
@@ -83,7 +73,7 @@
           (:maximum (:attrs typedef))
           (str
            " CONSTRAINT "
-           (gensym "c-")
+           (gensym "max_")
            " CHECK ("
            (:name (:attrs property))
            " < "
@@ -92,7 +82,7 @@
           (:minimum (:attrs typedef))
           (str
            " CONSTRAINT "
-           (gensym "c-")
+           (gensym "min_")
            " CHECK ("
            (:minimum (:attrs typedef))
            " < "
@@ -158,11 +148,31 @@
             nil?
             (map
               #(if (selector (:permission (:attrs %)))
-              (:group (:attrs %)))
+                 (safe-name (:group (:attrs %)) :sql))
               permissions)))]
     (if
       (not (empty? group-names))
-      (s/join " " (list "GRANT" (name privilege) "ON"  table-name "TO" (s/join ",\n\t" (sort group-names)) ";")))))
+      (s/join
+        " "
+        (list
+          "GRANT"
+          (name privilege)
+          "ON"
+          (safe-name table-name :sql)
+          "TO"
+          (s/join
+            ",\n\t"
+            (sort group-names))
+          ";")))))
+
+
+(defn field-name
+  [property]
+  (safe-name
+    (or
+      (:column (:attrs property))
+      (:name (:attrs property)))
+    :sql))
 
 
 (defn emit-property
@@ -181,9 +191,17 @@
          (flatten
           (list
            "\t"
-           (:name (:attrs property))
+           (field-name property)
            (emit-field-type property entity application key?)
-           (if default (list "DEFAULT" default))
+           (if
+             default
+             (list
+               "DEFAULT"
+               (if
+                 (is-quotable-type? property application)
+                 (str "'" default "'") ;; TODO: but if the default value seems to be a function invocation, should it be quoted?
+                                       ;; it's quite common for 'now()' to be the default for a date, time or timestamp field.
+                 default)))
            (if
              key?
              "NOT NULL PRIMARY KEY"
@@ -203,7 +221,7 @@
         (if
           (= (:type (:attrs f)) "entity")
           (compose-convenience-entity-field f farside application)
-          (str (:table (:attrs farside)) "." (:name (:attrs f)))))
+          (str (safe-name (:table (:attrs farside))) "." (field-name f))))
       (user-distinct-properties farside)))))
 
 
@@ -213,7 +231,7 @@
    nil?
    (flatten
     (cons
-     (:name (:attrs entity))
+     (safe-name (:table (:attrs entity)) :sql)
      (map
       (fn [f]
         (if
@@ -242,13 +260,13 @@
          (let [farside (entity-for-property f application)]
            (cons
             (str
-             (:table (:attrs entity))
+             (safe-name (:table (:attrs entity)) :sql)
              "."
-             (:name (:attrs f))
+             (field-name f)
              " = "
-             (:table (:attrs farside))
+             (safe-name (:table (:attrs farside)) :sql)
              "."
-             (first (key-names farside)))
+             (safe-name (first (key-names farside)) :sql))
             #(compose-convenience-where-clause farside application false)))))
      (if
        top-level?
@@ -260,17 +278,17 @@
   [field entity application]
   (str
    (s/join
-    " |', '| "
+    " ||', '|| "
     (compose-convenience-entity-field field entity application))
    " AS "
-   (:name (:attrs field))))
+   (field-name field)))
 
 
 (defn emit-convenience-view
   "Emit a convenience view of this `entity` of this `application` for use in generating lists,
   menus, et cetera."
   [entity application]
-  (let [view-name (str "lv_" (:table (:attrs entity)))
+  (let [view-name (safe-name (str "lv_" (:table (:attrs entity))) :sql)
         entity-fields (filter
                        #(= (:type (:attrs %)) "entity")
                        (properties entity))]
@@ -294,12 +312,12 @@
            #(if
               (= (:type (:attrs %)) "entity")
               (emit-convenience-entity-field % entity application)
-              (:name (:attrs %)))
+              (str (safe-name entity) "." (field-name %)))
            (filter
-            #(and (= (:tag %) :property) (not (= (:type (:attrs %)) "link")))
+            #(not (= (:type (:attrs %)) "link"))
             (all-properties entity) ))))
         (str
-         "FROM " (s/join ", " (compose-convenience-view-select-list entity application true)))
+         "FROM " (s/join ", " (set (compose-convenience-view-select-list entity application true))))
         (if
           (not (empty? entity-fields))
           (str
@@ -315,13 +333,13 @@
                              (entity? %)
                              (= (:name (:attrs %)) (:entity (:attrs f)))))]
                  (str
-                  (:table (:attrs entity))
+                  (safe-name (:table (:attrs entity)) :sql)
                   "."
-                  (:name (:attrs f))
+                  (field-name f)
                   " = "
-                  (:table (:attrs farside))
+                  (safe-name (:table (:attrs farside)) :sql)
                   "."
-                  (first (key-names farside)))))
+                  (safe-name (first (key-names farside)) :sql))))
              entity-fields))))
         ";"
         (emit-permissions-grant view-name :SELECT (permissions entity application))))))))
@@ -335,14 +353,15 @@
      " "
      (list
       "ALTER TABLE"
-      (:name (:attrs nearside))
+      (safe-name (:name (:attrs nearside)) :sql)
-      "ADD CONSTRINT"
+      "ADD CONSTRAINT"
-      (str "ri_" (:name (:attrs nearside)) "_" (:name (:attrs farside)) "_" (:name (:attrs property)))
+      (safe-name (str "ri_" (:name (:attrs nearside)) "_" (:name (:attrs farside)) "_" (:name (:attrs property))) :sql)
       "\n\tFOREIGN KEY("
-      (:name (:attrs property))
+      (field-name property)
       ") \n\tREFERENCES"
       (str
-       (:table (:attrs farside)) "(" (:name (:attrs (first (key-properties farside)))) ")")
+       (safe-name (:table (:attrs farside)) :sql)
+        "(" (field-name (first (key-properties farside))) ")")
       ;; TODO: ought to handle the `cascade` attribute, even though it's rarely used
       "\n\tON DELETE"
       (case
@@ -365,7 +384,7 @@
     (list
      (emit-header
       "--"
-      (str "--\treferential integrity links for first-class tables"))
+      "referential integrity links for primary tables")
      (map
       #(emit-referential-integrity-links % application)
       (children-with-tag application :entity))))))
@@ -373,7 +392,7 @@
 
 (defn emit-table
   ([entity application doc-comment]
-   (let [table-name (:table (:attrs entity))
+   (let [table-name (safe-name (:table (:attrs entity)) :sql)
          permissions (children-with-tag entity :permission)]
      (s/join
       "\n"
@@ -423,11 +442,11 @@
 (defn construct-link-property
   [entity]
   {:tag :property
-   :attrs {:name (str (:name (:attrs entity)) "_id")
+   :attrs {:name (safe-name (str (:name (:attrs entity)) "_id") :sql)
-           :column (str (:name (:attrs entity)) "_id")
+           :column (safe-name (str (:name (:attrs entity)) "_id") :sql)
            :type "entity"
            :entity (:name (:attrs entity))
-           :farkey (first (key-names entity))}})
+           :farkey (safe-name (first (key-names entity)) :sql)}})
 
 
 (defn emit-link-table
@@ -480,21 +499,13 @@
      (properties entity)))))
 
 
-(defn emit-entity
-  [entity application]
-  (doall
-   (list
-    (emit-table entity application)
-    (emit-convenience-view entity application))))
-
-
 (defn emit-group-declaration
   [group application]
   (list
    (emit-header
     "--"
     (str "security group " (:name (:attrs group))))
-   (str "CREATE GROUP " (:name (:attrs group)) ";")))
+   (str "CREATE GROUP " (safe-name (:name (:attrs group)) :sql) ";")))
 
 
 (defn emit-file-header
@@ -526,7 +537,11 @@
         (sort-by-name
          (children-with-tag application :group)))
        (map
-        #(emit-entity % application)
+        #(emit-table % application)
+        (sort-by-name
+         (children-with-tag application :entity)))
+       (map
+        #(emit-convenience-view % application)
         (sort-by-name
          (children-with-tag application :entity)))
        (emit-referential-integrity-links application)

src/adl/utils.clj

@@ -39,6 +39,12 @@
   "resources/auto/")
 
 
+(defn element?
+  "True if `o` is a Clojure representation of an XML element."
+  [o]
+  (and (map? o) (:tag o) (:attrs o)))
+
+
 (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
@@ -73,6 +79,11 @@
      comment-rule)))
 
 
+(defn sort-by-name
+  [elements]
+  (sort #(compare (:name (:attrs %1)) (:name (:attrs %2))) elements))
+
+
 (defn link-table-name
   "Canonical name of a link table between entity `e1` and entity `e2`."
   [e1 e2]
@@ -249,16 +260,25 @@
 
 
 (defn safe-name
-  ([string]
+  "Return a safe name for the object `o`, given the specified `convention`.
-    (s/replace string #"[^a-zA-Z0-9-]" ""))
+  `o` is expected to be either a string or an entity."
-  ([string convention]
+  ([o]
+   (if
+     (element? o)
+     (safe-name (:name (:attrs o)))
+     (s/replace (str o) #"[^a-zA-Z0-9-]" "")))
+  ([o convention]
+   (if
+     (element? o)
+     (safe-name (:name (:attrs o)) convention)
+     (let [string (str o)]
        (case convention
          (:sql :c) (s/replace string #"[^a-zA-Z0-9_]" "_")
          :c-sharp (s/replace (capitalise string) #"[^a-zA-Z0-9]" "")
          :java (let
                  [camel (s/replace (capitalise string) #"[^a-zA-Z0-9]" "")]
-             (apply str (cons (Character/toUpperCase (first camel)) (rest camel))))
+                 (apply str (cons (Character/toLowerCase (first camel)) (rest camel))))
-     (safe-name string))))
+         (safe-name string))))))
 
 
 (defn link-table?
@@ -359,6 +379,37 @@
       (key-properties entity))))
 
 
+(defn base-type
+  [property application]
+  (cond
+    (:typedef (:attrs property))
+    (:type
+      (:attrs
+        (child
+          application
+          #(and
+             (= (:tag %) :typedef)
+             (= (:name (:attrs %)) (:typedef (:attrs property)))))))
+    (:entity (:attrs property))
+    (:type
+      (:attrs
+        (first
+          (key-properties
+            (child
+              application
+              #(and
+                 (= (:tag %) :entity)
+                 (= (:name (:attrs %)) (:entity (:attrs property)))))))))
+    true
+    (:type (:attrs property))))
+
+
+(defn is-quotable-type?
+  "True if the value for this field should be quoted."
+  [property application]
+  (#{"date" "image" "string" "text" "time" "timestamp" "uploadable"} (base-type property application)))
+
+
 (defn has-primary-key? [entity]
   (> (count (key-names entity)) 0))