Split out core into compiler/dsl/query.

The query namespace really only exists because I didn't want to put it in dsl,
but I couldn't put it in core without a circular dependency.

Users should only have to :require core to do things, though. It just aliases
other stuff to make that work.

1 files changed, 16 insertions, 376 deletions

diff --git a/src/clojure_sql/core.clj b/src/clojure_sql/core.clj
index ae0eb75..cdfa1c9 100644
--- a/src/clojure_sql/core.clj
+++ b/src/clojure_sql/core.clj
@@ -1,381 +1,22 @@
 (ns clojure-sql.core
   (:refer-clojure :exclude [sort-by])
   (:require [clojure.set :as set]
-            [clojure.string :as string]
+            [clojure-sql.compiler :as c]
+            [clojure-sql.dsl :as d]
             [clojure-sql.util :as u]
             [clojure.walk]))
 
-(declare compile-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! d/insert!)
+(def update! d/update!)
+(def delete! d/delete!)
 
-(def ^:private ^:dynamic *database-type* nil)
-(defn set-database-type! [new-type]
-  (alter-var-root #'*database-type* (constantly new-type)))
-
-(def ^:private ^:dynamic *query-deref-behaviour* #(compile-query *database-type* %))
-(defn set-query-deref-behaviour! [f]
-  (alter-var-root #'*query-deref-behaviour* (constantly f)))
-
-(defrecord ^:private Query []
-  clojure.lang.IDeref
-  (deref [this] (*query-deref-behaviour* this)))
-(defmethod print-method Query [query writer]
-  (binding [*out* writer]
-    (pr (compile-query nil query))))
-
-
-
-
-(defn add-parentheses [s]
-  (str \( s \)))
-
-;; ==============================================================
-;; DB specific escaping methods
-;; ==============================================================
-
-(defmulti field-name (fn [db _] db))
-(defmethod field-name :default [_ field]
-  (str \" (name field) \"))
-
-(defmulti table-name (fn [db _] db))
-(defmethod table-name :default [_ table]
-  (str \" (name table) \"))
-
-(defmulti function-name (fn [db _] db))
-(defmethod function-name :default [_ function]
-  (str \" (name function) \"))
-
-
-
-
-
-;; ==============================================================
-;; 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))
-
-
-
-;; ==============================================================
-;; compile-* functions (turning a map into a query string)
-;; ==============================================================
-
-(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)))
-
-(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))))
-
-(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 "*")))
-
-(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))
-
-(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)))
-
-(defmulti compile-joins (fn [db _] db))
-(defmethod compile-joins :default [db joins]
-  (->> joins
-       (map (partial compile-join db))
-       (c-join " ")))
-
-(defmulti compile-where (fn [db _] db))
-(defmethod compile-where :default [db expr]
-  (if expr
-    (c-str (c-return " WHERE ") (compile-expression db expr))))
-
-(defmulti compile-sort-by (fn [db _] db))
-(defmethod compile-sort-by :default [db fields]
-  (if fields
-    (->> (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)))
-
-(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)))
-
-
-
-;; SQL SERVER
-(defmethod field-name :sql-server [_ field]
-  (str \[ (name field) \]))
-
-(defmethod table-name :sql-server [_ table]
-  (str \[ (name table) \]))
-
-;; mySQL
-(defmethod field-name :mysql [_ field]
-  (str \` (name field) \`))
-
-(defmethod table-name :mysql [_ table]
-  (str \` (name table) \`))
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-;; ==============================================================
-;; The DSL for making query maps
-;; ==============================================================
-
-;; important sections:
-;;   -PROJECTION-
-;;   -TABLES-
-;;   -FILTERS-
-;;   GROUPING
-;;   GROUPED FILTERS
-;;   -SORTING-
-
-;; {
-;;  :table => tablename -> table_alias,
-;;  :fields => (table_alias, fieldname) -> field_alias
-;;  :joins => [tablename -> (type, table_alias, on)]
-;;  :where => expression
-;;  :sort-by => [(field, direction)]
-;; }
-
-(defn table [arg]
-  (into (->Query)
-        (if (map? arg)
-          {:table arg}
-          {:table {arg arg}})))
-
-(defn ambiguous-error [field & [query]]
-  (throw (ex-info (str "Ambiguous field " field " in query with more than one table")
-                  {:field field
-                   :query query})))
-
-(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)))))]
-    (assoc query
-      :fields (->> (for [[key val] (if (map? fields)
-                                     fields
-                                     (zipmap fields fields))]
-                     [(original-name key) val])
-                   (into {})))))
-
-(defn rename [query field-renames]
-  {:pre [(map? field-renames)
-         ;; the intersection of the new aliases with the old aliases NOT renamed by this operation
-         (empty? (set/intersection (set (vals field-renames))
-                                   (set/difference (set (vals (:fields query)))
-                                                   (set (keys field-renames)))))]}
-  (let [fields (:fields query)
-        alias-lookup (u/flip-map (:fields query)) 
-        original-name (fn [field]
-                        (cond (vector? field) field
-                              (contains? alias-lookup field) (get alias-lookup field)
-                              :else (throw (ex-info (str "Cannot rename field " (pr-str field) ". Field does not exist in query.")
-                                                    {:field field
-                                                     :query query
-                                                     :renames field-renames})))
-                        (get alias-lookup field))]
-    (update-in query
-               [:fields] #(->> (for [[key val] field-renames]
-                                 ;(if (contains? val (:fields query)))
-                                 [(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
-                  (nil? where) acc
-                  :else (or (if (and (sequential? where)
-                                     (= (name (first where)) "and"))
-                              `(and ~acc ~@(next where)))
-                            (if (and (sequential? acc)
-                                     (= (name (first acc)) "and"))
-                              `(and ~@(next acc) ~where))
-                            `(and ~acc ~where))))
-          nil wheres))
-
-(defn join [left right & {:keys [on type]}]
-  (let [joins-vector (or (:join left) []) 
-        common-fields (set/intersection (set (vals (:fields left)))
-                                        (set (vals (:fields right))))
-        joined-fields (if (:type :right) 
-                        (merge (->> (:fields left)
-                                    (filter (comp not common-fields val))
-                                    (into {}))
-                               (:fields right))
-                        (merge (:fields left)
-                               (->> (:fields right)
-                                    (filter (comp not common-fields val))
-                                    (into {}))))
-        implicit-on (if (seq common-fields)
-                      (map (fn [field]
-                             `(= ~(resolve-field (:table left) (:fields left) field)
-                                 ~(resolve-field (:table right) (:fields right) field)))
-                           common-fields))
-        on (if on
-             [(resolve-fields nil joined-fields on)])
-        join-condition (if-let [condition (seq (concat implicit-on on))]
-                         `(and ~@condition)
-                         true)]
-    (-> left
-        (assoc :fields joined-fields)
-        (assoc :joins (into (conj joins-vector
-                                  [(or type :inner) (:table right) join-condition])
-                            (:joins right)))
-        (assoc :where (combine-wheres (:where left) (:where right))))))
-
-(defn select [query expression]
-  (let [table-name (if-not (:joins query)
-                     (-> query :table first val))
-        old-where (:where query)
-        resolved-expression (resolve-fields table-name (:fields query) expression)
-        new-where (combine-wheres old-where resolved-expression)]
-    (assoc query :where new-where)))
-
-(defn sort-by [query fields]
-  (let [table-name (if-not (:joins query)
-                     (-> query :table first val))
-        fields-seq (if (sequential? fields)
-                     fields
-                     [fields])]
-    (assoc query
-      :sort-by (for [field fields-seq]
-                 (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
-  )
 
 
 (comment
@@ -395,14 +36,14 @@
                           (rename {:id :pid}))
                       (-> (table {:others :o})
                           (project {:id :oid}))
-                      '(= :pid :oid))
-                uid-pid-match)
+                      :on '(= :pid :oid))
+                :on uid-pid-match)
           (select is-carlo)
           (project [:fname :sname :oid]))))
 
   (-> (table :users)
       (join (table :something-else-with-a-username)
-            true)
+            :on true)
       (select '(or (= :username "john")
                    (not (= :username "carlo"))))
       (project [:username]))
@@ -413,14 +54,13 @@
       (join (-> (table {:nodes :parent})
                 (project [:id, :name])
                 (rename {:name :parent.name}))
-            '(= :parent-id :id))
+            :on '(= :parent-id :id))
       (project [:child.name :parent.name]))
 
   (-> (table :users)
       (project [:id])
       (join (-> (table :people)
-                (project [:id]))
-            true))
+                (project [:id]))))
   (-> (table :users)
       (project [:id :name])
       (rename {:id :name