Simplify the compiler, better subquery support

The compiler's been simplified a bit by breaking out the `writer` stuff into
its own namespace and by generally making the monadic stuff better. It's all
hidden behind a nice, simple, `clojure-sql.compiler/compile` function now. Call
that and you'll get back what you need. (Internally it's a writer monad which
is really modelled as a state monad with the only operation able to be
performed on the state being `tell`.)

Subqueries are now handled by the DSL in such a way as to not blow up
everything. Subqueries have no support for referencing values in the
superquery, though, so their utility is quite limited at present. Thinking
about how to do subqueries properly may be difficult.

1 files changed, 127 insertions, 89 deletions

diff --git a/src/clojure_sql/compiler.clj b/src/clojure_sql/compiler.clj
index ca8d2d9..7ded112 100644
--- a/src/clojure_sql/compiler.clj
+++ b/src/clojure_sql/compiler.clj
@@ -1,7 +1,9 @@
 (ns clojure-sql.compiler
-  (:require [clojure.string :as string]))
-
-
+  (:refer-clojure :exclude [compile sequence])
+  (:require [clojure.string :as string]
+            [clojure-sql.query :refer [query?]]
+            [clojure-sql.util :as u]
+            [clojure-sql.writer :as w :refer [return lift p-lift sequence do-m tell >>]]))
 
 (defn add-parentheses [s]
   (str \( s \)))
@@ -26,121 +28,129 @@
 
 
 
+;; we use the $ prefix to denote a lifted function
+(def $add-parentheses (lift add-parentheses))
+(def $str (lift str))
+
+
+
 
 ;; ==============================================================
 ;; Utility functions for the compile-* functions
 ;; ==============================================================
 
-;; compile-* multimethods are of the signature:
-;;  (db, expr) -> [SQL & replacements]
-
-(def is-unary? (comp boolean '#{"not"} name))
-(def is-binary? (comp boolean '#{"=" "<" ">" "<=" ">=" "is" "in" "+" "-" "/" "*"} name))
-(def is-operator? (comp boolean '#{"and" "or"} name))
 
-(defn c-return [val] [val])
-(defn c-lift [f & orig-args]
-  (fn [& c-args] 
-    (apply vector 
-           (apply f (concat orig-args
-                            (map first c-args)))
-           (apply concat (map rest c-args)))))
-(def c-str (c-lift str))
-(def c-join (fn [sep args]
-              (apply vector
-                     (string/join sep (map first args))
-                     (apply concat (map rest args)))))
-(def c-add-parentheses (c-lift add-parentheses))
+(def ^:private named? (some-fn string? symbol? keyword?))
 
+(def quote? (comp boolean '#{"quote"} name))
+(def unary? (comp boolean '#{"not" "exists"} name))
+(def binary? (comp boolean '#{"=" "<" ">" "<=" ">=" "is" "in"} name))
+(def operator? (comp boolean '#{"and" "or" "+" "-" "/" "*"} name))
 
 
 ;; ==============================================================
 ;; compile-* functions (turning a map into a query string)
 ;; ==============================================================
 
+;; compile-* multimethods are of the signature:
+;;  (db, expr) -> (fn [s] [sql])
+
+(declare compile-query compile-expression)
+
+(defmulti compile-expression-sequential (fn [db ex]))
+(defmethod compile-expression-sequential :default [db ex]
+  (let [compile-exprs #(map (partial compile-expression db) %)
+        op (name (first ex))
+        num-args (dec (count ex))]
+    (-> (condp u/funcall (first ex)
+          quote?    (do (assert (= num-args 1) "`quote` must only take one argument")
+                        (>> (tell (second ex)) (return "?")))
+          unary?    (do (assert (= num-args 1) (str "Unary operator `" op "` must take one argument"))
+                        (do-m :let [exprs (compile-exprs ex)]
+                              vals <- (apply sequence exprs)
+                              (return (string/join "" vals))))
+          binary?   (do (assert (= num-args 2) (str "Binary operator `" op "` must take two arguments"))
+                        (do-m :let [[op left right] (compile-exprs ex)]
+                              vals <- (sequence left op right)
+                              (return (string/join " " vals))))
+          operator? (do-m :let [[op & exprs] (compile-exprs ex)]
+                          vals <- (apply sequence (interpose op exprs))
+                          (return (string/join " " vals)))
+          (do-m :let [fn-name (function-name db (first ex))
+                      exprs (compile-exprs (rest ex))]
+                vals <- (apply sequence exprs)
+                (return (str fn-name
+                             (add-parentheses (string/join "," vals))))))
+        $add-parentheses)))
+
 (defmulti compile-expression (fn [db _] db))
 (defmethod compile-expression :default [db ex]
-  (condp #(%1 %2) ex
-    nil? (c-return "NULL")
-    vector? (c-return (str (table-name db (first ex)) \. (field-name db (second ex))))
-    keyword? (c-return (field-name db ex))
-    string? ["?" ex] ;;(sql-string db ex)
-    symbol? (c-return (string/upper-case (name ex)))
-    sequential? (-> (condp #(%1 %2) (first  ex)
-                      is-unary? (if (= (count ex) 2)
-                                  (->> ex
-                                       (map (partial compile-expression db))
-                                       (c-join " "))
-                                  (throw (ex-info "Unary operators can only take one argument."
-                                                  {:operator (first ex)
-                                                   :arguments (rest ex)})))
-                      is-binary? (if (= (count ex) 3)
-                                   (->> (rest ex)
-                                        (map (partial compile-expression db))
-                                        (interpose (compile-expression db (first ex)))
-                                        (c-join " "))
-                                   (throw (ex-info "Binary operators must take two arguments."
-                                                   {:operator (first ex)
-                                                    :arguments (rest ex)})))
-                      is-operator? (->> (rest ex)
-                                        (map (partial compile-expression db))
-                                        (interpose (compile-expression db (first ex)))
-                                        (c-join " "))
-                      (->> (rest ex)
-                           (map (partial compile-expression db))
-                           (c-join ", ")
-                           c-add-parentheses
-                           (c-str (c-return (function-name db (first ex))))))
-                    c-add-parentheses)
-    (c-return ex)))
+  (condp u/funcall ex
+    query?       ($add-parentheses (compile-query db ex))
+    nil?         (return "NULL")
+    vector?      (return (str (table-name db (first ex)) \. (field-name db (second ex))))
+    keyword?     (return (field-name db ex))
+    string?      (>> (tell ex) (return "?")) ;;(sql-string db ex)
+    symbol?      (return (string/upper-case (name ex)))
+    sequential?  (compile-expression-sequential db ex)
+    (return ex)))
 
 (defn ^:private make-table-name [db table & [alias]]
   (if (or (= table alias) (nil? alias))
-    (table-name db table)
-    (str (table-name db table) " AS " (field-name db alias)))  )
-
-(defn ^:private make-field-name [db table field & [alias]]
-  (if (or (= field alias) (nil? alias))
-    (str (table-name db table) \. (field-name db field))
-    (str (table-name db table) \. (field-name db field) " AS " (field-name db alias))))
+    (return (table-name db table))
+    ($str (condp #(%1 %2) table
+                 query? ($add-parentheses (compile-query db table))
+                 named? (return (table-name db table))
+                 (compile-expression db table))
+          (return " AS ")
+          (return (table-name db alias)))))
+
+(defn ^:private make-field-name [db field & [alias]]
+  (if (and (vector? field) (or (= field alias) (nil? alias)))
+    (compile-expression db field)
+    ($str (compile-expression db field)
+          (return " AS ")
+          (return (field-name db alias)))))
 
 (defmulti compile-fields (fn [db _] db))
 (defmethod compile-fields :default [db fields-map]
   (if (seq fields-map)
-    (->> (for [[[table field] alias] fields-map]
-           (make-field-name db table field alias))
-         (string/join ", ")
-         c-return)
-    (c-return "*")))
+    (->> (for [[field alias] fields-map]
+           (make-field-name db field alias))
+         (apply sequence)
+         ((p-lift string/join ", ")))
+    (return "*")))
 
 (defmulti compile-tables (fn [db _] db))
 (defmethod compile-tables :default [db tables-map]
   (->> (for [[table alias] tables-map]
          (make-table-name db table alias))
-       (string/join ", ")
-       c-return))
+       (apply sequence)
+       ((p-lift string/join ", "))))
 
 (defmulti compile-join (fn [db _] db))
 (defmethod compile-join :default [db [type table-map on]]
-  (c-str (c-return (case type
-                     :left " LEFT OUTER"
-                     :right " RIGHT OUTER"
-                     " INNER"))
-         (c-return " JOIN ")
-         (compile-tables db table-map)
-         (c-return " ON ")
-         (compile-expression db on)))
+  ($str (return (case type
+                  :left " LEFT OUTER"
+                  :right " RIGHT OUTER"
+                  " INNER"))
+        (return " JOIN ")
+        (compile-tables db table-map)
+        (return " ON ")
+        (compile-expression db on)))
 
 (defmulti compile-joins (fn [db _] db))
 (defmethod compile-joins :default [db joins]
   (->> joins
        (map (partial compile-join db))
-       (c-join "")))
+       (apply sequence)
+       ((p-lift string/join ""))))
 
 (defmulti compile-where (fn [db _] db))
 (defmethod compile-where :default [db expr]
   (if expr
-    (c-str (c-return " WHERE ") (compile-expression db expr))))
+    ($str (return " WHERE ") (compile-expression db expr))
+    (return nil)))
 
 (defmulti compile-sort-by (fn [db _] db))
 (defmethod compile-sort-by :default [db fields]
@@ -148,22 +158,29 @@
     (->> (for [[[table field] dir] fields]
            (str (make-field-name db table field) \space (string/upper-case (name dir))))
          (string/join ",")
-         (apply str " ORDER BY ")
-         c-return)))
+         (apply $str (return " ORDER BY "))
+         return)
+    (return nil)))
 
 (defmulti compile-query (fn [db _] db))
 (defmethod compile-query :default [db {:keys [table fields joins where sort-by]}]
-  (c-str (c-return "SELECT ")
-         (compile-fields db fields)
-         (if table
-           (c-return " FROM "))
-         (compile-tables db table)
-         (compile-joins db joins)
-         (compile-where db where)
-         (compile-sort-by db sort-by)))
+  ($str (return "SELECT ")
+        (compile-fields db fields)
+        (if table
+          (return " FROM "))
+        (compile-tables db table)
+        (compile-joins db joins)
+        (compile-where db where)
+        (compile-sort-by db sort-by)))
 
 
 
+
+(defn compile [db query]
+  (let [[sql vars] ((compile-query db query) [])]
+    (vec (cons sql vars))))
+
+
 ;; ==============================================================
 ;; A few DB specific overrides
 ;; ==============================================================
@@ -184,4 +201,25 @@
   (str \` (name table) \`))
 
 
+;;(compile nil {:table {:u :u}, :fields {[:v :x] :w}})
+
+
+
+
+;; Utility functions
+
+(defn insert! [db query & records]
+  {:pre [(empty? (:joins query))]}
+  ;; some code here
+  ($str (return "Carlo"))
+  )
+
+(defn update! [db query & partial-records]
+  {:pre [(empty? (:joins query))]}
+  ;; some code here
+  )
 
+(defn delete! [db query]
+  {:pre [(empty? (:joins query))]}
+  ;; some code here
+  )