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.

6 files changed, 273 insertions, 170 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
+  )
diff --git a/src/clojure_sql/core.clj b/src/clojure_sql/core.clj
index cdfa1c9..4f88a53 100644
--- a/src/clojure_sql/core.clj
+++ b/src/clojure_sql/core.clj
@@ -3,58 +3,72 @@
   (:require [clojure.set :as set]
             [clojure-sql.compiler :as c]
             [clojure-sql.dsl :as d]
+            [clojure-sql.query :as q]
             [clojure-sql.util :as u]
             [clojure.walk]))
 
-(def table d/table)
-(def project d/project)
-(def rename d/rename)
-(def join d/join)
-(def select d/select)
-(def sort-by d/sort-by)
+(def ^:private ^:dynamic *database-type* nil)
+(defn set-database-type! [new-type]
+  (alter-var-root #'*database-type* (constantly new-type))
+  nil)
+
+(q/set-query-deref-behaviour! #(c/compile *database-type* %))
+(defmethod print-method clojure_sql.query.Query [query writer]
+  (binding [*out* writer]
+    (pr (c/compile nil query))))
+
+(def table #'d/table)
+(def project #'d/project)
+(def rename #'d/rename)
+(def join #'d/join)
+(def select #'d/select)
+(def sort-by #'d/sort-by)
+
+(def insert! #'c/insert!)
+(def update! #'c/update!)
+(def delete! #'c/delete!)
+
+
 
-(def insert! d/insert!)
-(def update! d/update!)
-(def delete! d/delete!)
 
 
 
 (comment
 
-  (binding [*database-type* :mysql]
-    (let [users (-> (table :users)
-                    (project [:id :username :password])
-                    (select '(= :deleted false)))
-          people (-> (table :people)
-                     (project [:id :fname :sname])
-                     (select '(= :deleted false)))
-          uid-pid-match '(= :uid :pid)
-          is-carlo `(= :fname "Carlo'; SELECT * FROM users --")]
-      (-> (join (-> users
-                    (rename {:id :uid}))
-                (join (-> people
-                          (rename {:id :pid}))
-                      (-> (table {:others :o})
-                          (project {:id :oid}))
-                      :on '(= :pid :oid))
-                :on uid-pid-match)
-          (select is-carlo)
-          (project [:fname :sname :oid]))))
+  (let [users (-> (table :users)
+                  (project [:id :username :password])
+                  (select '(= :deleted false)))
+        people (-> (table :people)
+                   (project [:id :fname :sname])
+                   (select '(= :deleted false)))
+        uid-pid-match '(= :uid :pid)
+        is-carlo `(= :fname "Carlo'; SELECT * FROM users --")]
+    (-> (join (-> users
+                  (rename {:id :uid}))
+              (join (-> people
+                        (rename {:id :pid}))
+                    (-> (table {:others :o})
+                        (project {:id :oid}))
+                    :on '(= :pid :oid))
+              :on uid-pid-match)
+        (select is-carlo)
+        (project [:fname :sname :oid])))
 
   (-> (table :users)
-      (join (table :something-else-with-a-username)
-            :on true)
+      (project [:username])
+      (join (table :something-else-with-a-username))
       (select '(or (= :username "john")
                    (not (= :username "carlo"))))
       (project [:username]))
 
   (-> (table {:nodes :child})
       (project [:parent-id, :name])
-      (rename {:name :child.name})
+      (rename {:name :child.name
+               :parent-id :pid})
       (join (-> (table {:nodes :parent})
                 (project [:id, :name])
                 (rename {:name :parent.name}))
-            :on '(= :parent-id :id))
+            :on '(= :pid :id))
       (project [:child.name :parent.name]))
 
   (-> (table :users)
@@ -67,12 +81,19 @@
                :name :id}))
   (-> (table :users)
       (project {:id :name
-                :name :id}))
+                :name :id})
+      (select '(= :id 10)))
 
   (-> (table :anotherStack)
       (project [:anotherNumber])
       (join (-> (table :collection)
                 (project [:number]))))
 
+  (-> (table :anotherStack)
+      (project [:anotherNumber])
+      (join (-> (table :collection)
+                (project [:number])))
+      (select '(is-okay 10)))
+
   (-> (table :users)
       (select '(= (left :username 1) "bloo"))))
diff --git a/src/clojure_sql/dsl.clj b/src/clojure_sql/dsl.clj
index 006e637..996b55c 100644
--- a/src/clojure_sql/dsl.clj
+++ b/src/clojure_sql/dsl.clj
@@ -37,17 +37,24 @@
                   {:field field
                    :query query})))
 
+(defn ^:private resolve-field [table aliases field]
+  (let [field-alias-lookup (u/flip-map aliases)]
+    (or (field-alias-lookup field)
+        (if table
+          [table field]
+          (ambiguous-error field)))))
+
+(defn ^:private resolve-fields [table aliases expression]
+  (cond (list? expression) (map (partial table aliases) expression)
+        (vector? expression) (mapv (partial table aliases) expression)
+        (keyword? expression) (resolve-field table aliases expression)
+        :else expression))
+
 (defn project [query fields]
   (let [table (if-not (:joins query)
                 (-> query :table first val))
         alias-lookup (u/flip-map (:fields query))
-        original-name (fn [field]
-                        (if (vector? field)
-                          field
-                          (or (get alias-lookup field nil)
-                              (if table
-                                [table field] 
-                                (ambiguous-error field query)))))]
+        original-name #(resolve-fields table (:fields query) %)]
     (assoc query
       :fields (->> (for [[key val] (if (map? fields)
                                      fields
@@ -77,20 +84,6 @@
                                  [(original-name key) val])
                                (into %)))))
 
-(defn ^:private resolve-field [table aliases field]
-  (let [field-alias-lookup (u/flip-map aliases)]
-    (or (field-alias-lookup field)
-        (if table
-          [table field]
-          (ambiguous-error field)))))
-
-(defn ^:private resolve-fields [table aliases expression]
-  (clojure.walk/postwalk (fn [expr]
-                           (cond
-                            (keyword? expr) (resolve-field table aliases expr)
-                            :else expr))
-                         expression))
-
 (defn ^:private combine-wheres [& wheres]
   (reduce (fn [acc where]
             (cond (nil? acc) where
@@ -153,17 +146,3 @@
                  (if (vector? field)
                    (resolve-field table-name (:fields query) field)
                    [(resolve-field table-name (:fields query) field) :asc])))))
-
-
-(defn insert! [query & records]
-  {:pre [(empty? (:joins query))]}
-  ;; some code here
-  )
-
-(defn update! [query & partial-records]
-  ;; some code here
-  )
-
-(defn delete! [query]
-  ;; some code here
-  )
diff --git a/src/clojure_sql/query.clj b/src/clojure_sql/query.clj
index 239aab4..00eb212 100644
--- a/src/clojure_sql/query.clj
+++ b/src/clojure_sql/query.clj
@@ -1,20 +1,13 @@
-(ns clojure-sql.query
-  (:require [clojure-sql.compiler :as c]))
+(ns clojure-sql.query)
 
-
-(def ^:private ^:dynamic *database-type* nil)
-(defn set-database-type! [new-type]
-  (alter-var-root #'*database-type* (constantly new-type))
-  nil)
-
-(def ^:private ^:dynamic *query-deref-behaviour* #(c/compile-query *database-type* %))
+(def ^:private ^:dynamic *query-deref-behaviour* identity)
 (defn set-query-deref-behaviour! [f]
   (alter-var-root #'*query-deref-behaviour* (constantly f))
   nil)
 
-(defrecord ^:private Query []
+(defrecord ^:private Query [] 
   clojure.lang.IDeref
   (deref [this] (*query-deref-behaviour* this)))
-(defmethod print-method Query [query writer]
-  (binding [*out* writer]
-    (pr (c/compile-query nil query))))
+
+(def query? (partial instance? (class (->Query))))
+
diff --git a/src/clojure_sql/util.clj b/src/clojure_sql/util.clj
index 03c90f1..cd8e8b6 100644
--- a/src/clojure_sql/util.clj
+++ b/src/clojure_sql/util.clj
@@ -1,5 +1,8 @@
 (ns clojure-sql.util)
 
+(defn funcall [f & args]
+  (apply f args))
+
 (defn flip [f]
   (fn [& args]
     (apply f (reverse args))))
diff --git a/src/clojure_sql/writer.clj b/src/clojure_sql/writer.clj
new file mode 100644
index 0000000..5f4250b
--- /dev/null
+++ b/src/clojure_sql/writer.clj
@@ -0,0 +1,69 @@
+(ns clojure-sql.writer 
+  (:refer-clojure :exclude [sequence]))
+
+
+;; A small writer monad implementation, for what we need
+(defn return [x]
+  (fn [s] [x s]))
+
+(defn bind [mv f]
+  {:pre [(not (nil? mv))]}
+  (fn [s]
+    (let [[x s2] (mv s)]
+      ((f x) s2))))
+
+(defn tell [val]
+  (fn [s] [nil (conj s val)]))
+
+(defn join [mv]
+  (bind mv identity))
+
+(defn sequence
+  ([] (return nil))
+  ([mv & mvs]
+     {:pre [(not (nil? mv))]}
+     (bind mv
+           (fn [x]
+             (bind (apply sequence mvs)
+                   (fn [xs]
+                     (return (cons x xs))))))))
+
+(defn lift [f]
+  (fn [& args]
+    (bind (apply sequence args)
+          (fn [s]
+            (return (apply f s))))))
+
+(defn p-lift [f & args]
+  (lift (apply partial f args)))
+
+(defn >> 
+  ([arg]
+     arg)
+  ([arg1 & args]
+     (bind arg1
+           (fn [x]
+             (apply >> args)))))
+
+(defn do-m*
+  ([] (throw (ex-info "No." {})))
+  ([& args]
+     (or (if (nil? (next args))
+           (first args))
+         (if (= (first args) :let)
+           `(let ~(second args)
+              ~(apply do-m* (nnext args))))
+         (if (= (name (second args)) "<-")
+           (let [[var <- val & others] args]
+             `(bind ~val
+                    (fn [~var]
+                      ~(apply do-m* others)))))
+         `(bind ~(first args)
+                (fn [_#]
+                  ~(apply do-m* (next args)))))))
+
+(defmacro do-m [& args]
+  (apply do-m* args))
+
+(defmacro do [& args]
+  (apply do-m* args))