Now generating useful hugsql queries for link tables.

project.clj

@@ -4,5 +4,6 @@
   :license {:name "GNU General Public License,version 2.0 or (at your option) any later version"
             :url "https://www.gnu.org/licenses/old-licenses/gpl-2.0.en.html"}
   :dependencies [[org.clojure/clojure "1.8.0"]
+                 [org.clojure/math.combinatorics "0.1.4"]
                  [clj-time "0.14.2"]
                  [instaparse "1.4.8"]])

src/squirrel_parse/to_adl.clj

@@ -222,12 +222,13 @@
       (map #(apply function (list entity-map %)) statements))))
 
 
+;; TODO: link tables are not entities, and should be removed from the entities map.
 ;; (defn fixup-many-to-many
 
 ;;   [entities-map]
 ;;   (let [entities (filter #(not (is-link-table? %)) (vals entities-map))
 ;;         link-tables (filter is-link-table? (vals entities-map))]
-;;     (reduce #() entities-map)))
+;;     (reduce #() entities-map link-tables)))
 
 
 (defn table-definitions-to-entities

src/squirrel_parse/to_hugsql_queries.clj

@@ -2,8 +2,10 @@
       :author "Simon Brooke"}
   squirrel-parse.to-hugsql-queries
   (:require [clojure.java.io :refer [file]]
+            [clojure.math.combinatorics :refer [combinations]]
             [clojure.string :as s]
-            [squirrel-parse.to-adl :refer [migrations-to-xml]]))
+            [squirrel-parse.to-adl :refer [migrations-to-xml]]
+            [squirrel-parse.utils :refer [is-link-table? singularise]]))
 
 
 (defn key-names [entity-map]
@@ -25,9 +27,27 @@
 
 
 (defn where-clause [entity-map]
+  (let
+    [entity-name (:name (:attrs entity-map))]
     (str
-    "WHERE "
+      "WHERE " entity-name "."
-    (s/join " AND\n\t" (map #(str % " = " (keyword %)) (key-names entity-map)))))
+      (s/join
+        (str " AND\n\t" entity-name ".")
+        (map #(str % " = " (keyword %)) (key-names entity-map))))))
+
+
+(defn order-by-clause [entity-map]
+  (let
+    [entity-name (:name (:attrs entity-map))
+        preferred (map
+                  #(:name (:attrs %))
+                  (filter #(= (-> % :attrs :distinct) "user")
+                          (-> entity-map :content :properties vals)))]
+    (str
+      "ORDER BY " entity-name "."
+      (s/join
+        (str ",\n\t" entity-name ".")
+        (doall (flatten (cons preferred (key-names entity-map))))))))
 
 
 (defn insert-query [entity-map]
@@ -76,12 +96,83 @@
     (let [entity-name (:name (:attrs entity-map))
           pretty-name (s/replace (s/replace entity-name #"_" "-") #"s$" "")]
       (str "-- :name get-" pretty-name " :? :1\n"
-           "-- :doc updates an existing " pretty-name " record\n"
+           "-- :doc selects an existing " pretty-name " record\n"
            "SELECT * FROM " entity-name "\n"
            (where-clause entity-map)
+           "\n"
+           (order-by-clause entity-map)
            "\n\n"))))
 
 
+(defn list-query [entity-map]
+  (let [entity-name (:name (:attrs entity-map))
+        pretty-name (s/replace (s/replace entity-name #"_" "-") #"s$" "")]
+    (str "-- :name list-" pretty-name " :? :*\n"
+         "-- :doc lists all existing " pretty-name " records\n"
+         "SELECT * FROM " entity-name "\n"
+         (order-by-clause entity-map)
+         "\n\n")))
+
+
+(defn foreign-queries [entity-map entities-map]
+  (let [entity-name (:name (:attrs entity-map))
+        pretty-name (s/replace (s/replace entity-name #"_" "-") #"s$" "")
+        links (filter #(-> % :attrs :entity) (-> entity-map :content :properties vals))]
+    (apply
+      str
+      (map
+        #(let [far-name (-> % :attrs :entity)
+               far-entity ((keyword far-name) entities-map)
+               pretty-far (s/replace (s/replace far-name #"_" "-") #"s$" "")
+               farkey (-> % :attrs :farkey)
+               link-field (-> % :attrs :name)]
+           (str "-- :name list-" entity-name "-by-" pretty-far " :? :*\n"
+                "-- :doc lists all existing " pretty-name " records related to a given " pretty-far "\n"
+                "SELECT * \nFROM " entity-name "\n"
+                "WHERE " entity-name "." link-field " = :id\n"
+                (order-by-clause entity-map)
+                "\n\n"))
+        links))))
+
+
+(defn link-table-query [near link far]
+  (let [properties (-> link :content :properties vals)
+        links (apply
+                merge
+                (map
+                  #(hash-map (keyword (-> % :attrs :entity)) %)
+                  (filter #(-> % :attrs :entity) properties)))
+        near-name (-> near :attrs :name)
+        link-name (-> link :attrs :name)
+        far-name (-> far :attrs :name)
+        pretty-far (singularise far-name)]
+    (println links)
+    (str "-- :name list-" link-name "-" near-name "-by-" pretty-far " :? :*\n"
+         "-- :doc lists all existing " near-name " records related through " link-name " to a given " pretty-far "\n"
+         "SELECT "near-name ".*\n"
+         "FROM " near-name ", " link-name "\n"
+         "WHERE " near-name "." (first (key-names near)) " = " link-name "." (-> (links (keyword near-name)) :attrs :name) "\n\t"
+         "AND " link-name "." (-> (links (keyword far-name)) :attrs :name) " = :id\n"
+         (order-by-clause near)
+         "\n\n")))
+
+
+(defn link-table-queries [entity-map entities-map]
+  (let
+    [entities (map
+                #((keyword %) entities-map)
+                (remove nil? (map #(-> % :attrs :entity) (-> entity-map :content :properties vals))))
+     pairs (combinations entities 2)]
+    (apply
+      str
+      (map
+        #(str
+           (link-table-query (nth % 0) entity-map (nth % 1))
+           (link-table-query (nth % 1) entity-map (nth % 0)))
+        pairs))))
+
+
+
 (defn delete-query [entity-map]
   (if
     (has-primary-key? entity-map)
@@ -95,20 +186,26 @@
 
 
 (defn queries
-  [entity-map]
+  [entity-map entities-map]
   (str
     (insert-query entity-map)
     (update-query entity-map)
+    (delete-query entity-map)
+    (if
+      (is-link-table? entity-map)
+      (link-table-queries entity-map entities-map)
+      (str
         (select-query entity-map)
-    (delete-query entity-map)))
+        (list-query entity-map)
+        (foreign-queries entity-map entities-map)))))
 
 
 (defn migrations-to-queries-sql
   ([migrations-path]
-   (migrations-to-queries-sql migrations-path "queries.sql"))
+   (migrations-to-queries-sql migrations-path "queries.auto.sql"))
   ([migrations-path output]
    (let
      [adl-struct (migrations-to-xml migrations-path "Ignored")
-      file-content (apply str (map queries (vals adl-struct)))]
+      file-content (apply str (map #(queries % adl-struct) (vals adl-struct)))]
      (spit output file-content)
      file-content)))

src/squirrel_parse/utils.clj

@@ -1,7 +1,7 @@
 (ns ^{:doc "A parser for SQL: utility functions."
       :author "Simon Brooke"}
   squirrel-parse.utils
-  (:require [clojure.string :refer [join split trim triml upper-case]]))
+  (:require [clojure.string :as s]))
 
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -45,14 +45,14 @@
   without the terminal semi-colon. Keywords may always optionally be preceded
   by whitespace and are usually succeeded by whitespace."
   [token]
-  (let [subtokens (split token #"\s+")
+  (let [subtokens (s/split token #"\s+")
-        name (join "-" subtokens)]
+        name (s/join "-" subtokens)]
     (apply str
            (flatten
              (list
-               (upper-case name)
+               (s/upper-case name)
                " := OPT-SPACE "
-               (join " SPACE " (map #(str "#'(?i)" % "'") subtokens))
+               (s/join " SPACE " (map #(str "#'(?i)" % "'") subtokens))
                " OPT-SPACE ")))))
 
 
@@ -79,7 +79,7 @@
 
 (defn- make-timezone-clause
   [match with-tz? with-precision?]
-  (join
+  (s/join
     " "
     (list
       (if with-precision? (str match " LPAR INT-VAL RPAR") match)
@@ -92,16 +92,16 @@
   "Make a rule which matches this `datatype`, for datatypes which may optionally take
   'with (or without) time zone'."
   [token]
-  (let [subtokens (split token #"\s+")
+  (let [subtokens (s/split token #"\s+")
-        name (join "-" subtokens)
+        name (s/join "-" subtokens)
-        match (join " SPACE " (map #(str "#'(?i)" % "'") subtokens))]
+        match (s/join " SPACE " (map #(str "#'(?i)" % "'") subtokens))]
     (apply str
            (flatten
              (list
                "DT-"
-               (upper-case name)
+               (s/upper-case name)
                " := "
-               (join
+               (s/join
                  " | "
                  (list
                    match
@@ -212,4 +212,6 @@
     (if name-elt (second name-elt))))
 
 
+(defn singularise [string]
+  (s/replace (s/replace string #"_" "-") #"s$" ""))