summaryrefslogtreecommitdiff
path: root/src/clojure_sql
diff options
context:
space:
mode:
Diffstat (limited to 'src/clojure_sql')
-rw-r--r--src/clojure_sql/compiler.clj74
-rw-r--r--src/clojure_sql/dsl.clj329
2 files changed, 281 insertions, 122 deletions
diff --git a/src/clojure_sql/compiler.clj b/src/clojure_sql/compiler.clj
index 6f940c0..60a5530 100644
--- a/src/clojure_sql/compiler.clj
+++ b/src/clojure_sql/compiler.clj
@@ -50,18 +50,27 @@
;; ==============================================================
;; compile-* multimethods are of the signature:
-;; (db, expr) -> (fn [s] [sql])
+;; (db, expr) -> [args] -> [sql & args]
(declare compile-query compile-expression)
-(defmulti compile-expression-sequential (fn [db ex]))
+(defmulti compile-expression-list (fn [db _] db))
+(defmethod compile-expression-list :default [db ex]
+ (->> (map (partial compile-expression db) ex)
+ (apply sequence)
+ ((p-lift string/join ","))
+ $add-parentheses))
+
+(defmulti compile-expression-sequential (fn [db _] db))
(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 "?")))
+ (if (sequential? (second ex))
+ (compile-expression-list db (second ex))
+ (>> (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)
@@ -120,28 +129,33 @@
(def ^:private join-type-names
{:inner "INNER"
- :left "LEFT OUTER"
- :right "RIGHT OUTER"
- :outer "FULL OUTER"
+ :outer "LEFT OUTER"
+ :full-outer "FULL OUTER"
:cross "CROSS"})
(defmulti compile-tables (fn [db _ _] db))
-(defmethod compile-tables :default [db join tables-map]
- (if (vector? join)
+(defmethod compile-tables :default [db join tables-map]
+ (if (vector? join)
(->> (for [table-alias join]
(make-table-name db (get tables-map table-alias) table-alias))
(apply sequence)
((p-lift string/join ", ")))
(let [{:keys [left right type on]} join]
- ($str (return "(")
- (compile-tables db left tables-map)
- (return (str " " (get join-type-names type (name type)) " JOIN "))
- (compile-tables db right tables-map)
- (if on
- ($str (return " ON ")
- (compile-expression db on))
- (return ""))
- (return ")")))))
+ (if (= type :cross)
+ ($str (return "(")
+ (compile-tables db left tables-map)
+ (return " CROSS JOIN ")
+ (compile-tables db right tables-map)
+ (return ")"))
+ ($str (return "(")
+ (compile-tables db left tables-map)
+ (return (str " " (get join-type-names type (name type)) " JOIN "))
+ (compile-tables db right tables-map)
+ (return " ON ")
+ (if on
+ (compile-expression db on)
+ (return "TRUE"))
+ (return ")"))))))
(defmulti compile-where (fn [db _] db))
(defmethod compile-where :default [db expr]
@@ -149,8 +163,8 @@
($str (return " WHERE ") (compile-expression db expr))
(return nil)))
-(defmulti compile-sort-by (fn [db _] db))
-(defmethod compile-sort-by :default [db fields]
+(defmulti compile-sort (fn [db _] db))
+(defmethod compile-sort :default [db fields]
(if fields
(->> (for [[[table field] dir] fields]
($str (make-field-name db [table field])
@@ -160,8 +174,24 @@
($str (return " ORDER BY ")))
(return nil)))
+(defmulti compile-group (fn [db _] db))
+(defmethod compile-group :default [db fields]
+ (if fields
+ (->> (for [[table field] fields]
+ (make-field-name db [table field]))
+ (apply sequence)
+ ((p-lift string/join ","))
+ ($str (return " GROUP BY ")))
+ (return nil)))
+
+(defmulti compile-having (fn [db _] db))
+(defmethod compile-having :default [db expr]
+ (if expr
+ ($str (return " HAVING ") (compile-expression db expr))
+ (return nil)))
+
(defmulti compile-query (fn [db _] db))
-(defmethod compile-query :default [db {:keys [tables fields joins where sort-by]}]
+(defmethod compile-query :default [db {:keys [tables fields joins where sort group having]}]
($str (return "SELECT ")
(compile-fields db fields)
(if tables
@@ -169,7 +199,9 @@
(compile-tables db joins tables))
($str ""))
(compile-where db where)
- (compile-sort-by db sort-by)))
+ (compile-group db group)
+ (compile-having db having)
+ (compile-sort db sort)))
diff --git a/src/clojure_sql/dsl.clj b/src/clojure_sql/dsl.clj
index 6f01198..a31a913 100644
--- a/src/clojure_sql/dsl.clj
+++ b/src/clojure_sql/dsl.clj
@@ -1,5 +1,5 @@
(ns clojure-sql.dsl
- (:refer-clojure :exclude [sort-by])
+ (:refer-clojure :exclude [sort group])
(:require [clojure.set :as set]
[clojure.walk :as walk]
[clojure-sql.query :as q]
@@ -14,40 +14,82 @@
;; -PROJECTION-
;; -TABLES-
;; -FILTERS-
-;; GROUPING
-;; GROUPED FILTERS
;; -SORTING-
+;; -GROUPING-
+;; -GROUPED FILTERS-
+
;; {
;; :tables => tablename -> table_alias
;; :fields => (table_alias, fieldname) -> field_alias
;; :joins => [left-table type right-table on?]
;; :where => expression
-;; :sort-by => [(field, direction)]
+;; :sort => [(field, direction)]
+;; :group => [field]
+;; :having => expression
;; }
-(defn table [arg]
- (into (q/->Query)
- (if (map? arg)
- {:tables (u/flip-map arg)
- :joins (vec (vals arg))}
- {:tables {arg arg}
- :joins [arg]})))
-
(defn ^:private ambiguous-error [field & [query]]
(throw (ex-info (str "Ambiguous field " field " in query with more than one table")
{:field field
:query query})))
+(defn ^:private same-rename-error [alias renames & [query]]
+ (throw (ex-info (str "Cannot rename two fields to the same alias: " alias)
+ {:alias alias
+ :renames renames
+ :query query})))
+
+(defn ^:private missing-rename-error [field renames & [query]]
+ (throw (ex-info (str "Cannot rename field not present in query: " field)
+ {:field field
+ :query query
+ :renames renames})))
+
+(defn ^:private common-fields-error [left right common-fields]
+ (throw (ex-info "Cannot join with common fields unless natural join"
+ {:left left
+ :right right
+ :common-fields common-fields})))
+
+(defn ^:private cross-join-duplicate-fields [common-fields left right]
+ (throw (ex-info "Cross join will introduce ambiguous duplicate fields"
+ {:left left
+ :right right
+ :common-fields common-fields})))
+
+(defn ^:private cross-join-condition-error [condition left right]
+ (throw (ex-info "Cannot have a cross join with condition (maybe you wanted either a selection or an inner join)"
+ {:left left
+ :right right
+ :condition condition})))
+
+(defn ^:private invalid-join-type [type left right]
+ (throw (ex-info (str "Invalid join type: " type)
+ {:left left
+ :right right
+ :type type })))
+
+(defn table [arg]
+ (into (q/->Query)
+ (let [alias (keyword (gensym (if (u/named? arg)
+ (name arg)
+ "table")))]
+ {:tables {alias arg}
+ :joins [alias]})))
+
+(defn ^:private rename-table [query from to]
+ (q/map->Query (walk/prewalk-replace {from to} (into {} query))))
+
(defn ^:private resolve-field [table aliases field]
(let [field-alias-lookup aliases]
- (or (field-alias-lookup field)
+ (or (and field-alias-lookup (field-alias-lookup field))
(if table
[table field]
(ambiguous-error field)))))
(defn ^:private process-expression [table aliases expression]
- (cond (vector? expression) (list 'quote expression)
+ (cond (vector? expression) (list 'quote (mapv (partial process-expression table aliases) expression))
(sequential? expression) (map (partial process-expression table aliases) expression)
(keyword? expression) (resolve-field table aliases expression)
:else expression))
@@ -56,43 +98,54 @@
(let [table (if (= (count (:tables query)) 1)
(-> query :tables first key))
alias-lookup (or (:fields query) {})
- get-real-name #(resolve-field table alias-lookup %)]
+ get-real-name #(resolve-fields table alias-lookup %)
+ fields (if (map? fields)
+ fields
+ (zipmap fields fields))]
(assoc query
- :fields (->> (for [[old-name new-name] (if (map? fields)
- fields
- (zipmap fields fields))]
- [new-name (get-real-name old-name)])
- (into {})))))
+ :fields (reduce (fn [fields [field alias]]
+ (if (contains? fields alias)
+ (same-rename-error alias fields query)
+ (assoc fields alias (get-real-name field))))
+ {} fields))))
-(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))
+(defn ^:private rename-with-fn [query field-renames]
+ (update-in query [:fields]
+ (fn [fields]
+ (reduce (fn [fields [old-alias field]]
+ (let [new-alias (or (field-renames old-alias) old-alias)]
+ (if (contains? fields new-alias)
+ (same-rename-error new-alias field-renames query)
+ (assoc fields new-alias field))))
+ {} fields))))
+
+(defn ^:private rename-with-map [query field-renames]
+ {:pre [;; 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 (keys (:fields query)))
(set (keys field-renames)))))]}
- (let [fields (:fields query)
- alias-lookup (or (:fields query) {})
- fields-to-remove (set/difference (set (keys field-renames))
- (set (vals field-renames)))
- 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))
- ;; do the renaming we want here:
- fields (->> (for [[key val] field-renames]
- [val (original-name key)])
- (into fields))
- ;; remove the things we no longer have here:
- fields (->> (remove (comp fields-to-remove key) fields)
- (into {}))]
- (assoc query :fields fields)))
-
-
-(defn ^:private combine-wheres [& wheres]
+ (doseq [[field alias] field-renames]
+ (if-not (contains? (:fields query) field)
+ (missing-rename-error field field-renames query)))
+ (rename-with-fn query field-renames))
+
+(defn rename [query field-renames]
+ (if (map? field-renames)
+ (rename-with-map query field-renames)
+ (rename-with-fn query field-renames)))
+
+(defn prefix-names-matching [pred prefix]
+ (fn [alias]
+ (if (pred alias)
+ (keyword (str prefix (name alias)))
+ alias)))
+
+(defn prefix-names [prefix]
+ (prefix-names-matching (constantly true) prefix))
+
+
+
+(defn ^:private combine-conjunctions [& wheres]
(reduce (fn [acc where]
(cond (nil? acc) where
(nil? where) acc
@@ -105,71 +158,145 @@
`(and ~acc ~where))))
nil wheres))
+(defn ^:private joinable? [query]
+ (and (nil? (:group query))
+ (nil? (:having query))))
+(defn ^:private convert-to-subquery [query]
+ (-> (table query)
+ (project (keys (:fields query)))))
+
+(def ^:private valid-join-type? (comp boolean #{:cross :inner :outer :full-outer}))
(defn join [left right & {:keys [on type]}]
- (let [common-tables (set/intersection (set (keys (:tables left)))
- (set (keys (:tables right))))
- ;;_ (assert (empty? common-tables) "Cannot join two tables with the same name")
- merged-tables (merge (:tables left) (:tables right))
- common-fields (set/intersection (set (keys (:fields left)))
- (set (keys (:fields right))))
- merged-fields (merge (:fields left) (:fields right))
- join-condition (cond
- (nil? on) (let [implicit (map (fn [field]
- `(~'=
- ~(resolve-field (:table left) (:fields left) field)
- ~(resolve-field (:table right) (:fields right) field)))
- common-fields)]
- (if (next implicit)
- (seq (cons `and implicit)) ;; more than one, so add an "and" around them
- (first implicit)))
- (seq common-fields) (throw (ex-info "Cannot join with common fields unless natural join"
- {:left left
- :right right
- :common-fields common-fields}))
- :else (process-expression nil merged-fields on))
- type (or type
- (if join-condition :inner)
- :cross)]
- (-> left
- (assoc :fields merged-fields
- :tables merged-tables
- :joins {:left (:joins left)
- :right (:joins right)
- :type type
- :on join-condition}
- :where (combine-wheres (:where left)
- (:where right))))))
+ (if (= type :right)
+ (join right left :on on :type :left)
+ (let [type (if (= type :left)
+ :outer
+ type)
+ left (if (joinable? left)
+ left
+ (convert-to-subquery left))
+ right (if (joinable? right)
+ right
+ (convert-to-subquery right))
+ common-tables (set/intersection (set (keys (:tables left)))
+ (set (keys (:tables right))))
+ right (reduce (fn [query [alias table]]
+ (rename-table query alias (keyword (gensym (name table)))))
+ right (:tables right))
+ ;_ (assert (empty? common-tables) "Cannot join two tables with the same name")
+ merged-tables (merge (:tables left) (:tables right))
+ common-fields (set/intersection (set (keys (:fields left)))
+ (set (keys (:fields right))))
+ merged-fields (merge (:fields left) (:fields right))
+ join-condition (cond
+ (nil? on) (let [implicit (map (fn [field]
+ `(~'=
+ ~(resolve-field (:table left) (or (:fields left) {}) field)
+ ~(resolve-field (:table right) (or (:fields right) {}) field)))
+ common-fields)]
+ (if (next implicit)
+ (seq (cons `and implicit)) ;; more than one, so add an "and" around them
+ (first implicit)))
+ (seq common-fields) (common-fields-error left right common-fields)
+ :else (process-expression nil merged-fields on))
+ type (or type
+ (if join-condition :inner)
+ :cross)
+ [join-condition where] (if (contains? #{:outer :full-outer} type)
+ [(combine-conjunctions (:where right) join-condition) (:where left)]
+ [join-condition (combine-conjunctions (:where left) (:where right))])]
+ (if-not (valid-join-type? type)
+ (throw (invalid-join-type type left right)))
+ (if (and (= type :cross) join-condition)
+ (if (seq common-fields)
+ (cross-join-duplicate-fields common-fields left right)
+ (cross-join-condition-error join-condition left right)))
+ (-> left
+ (assoc :fields merged-fields
+ :tables merged-tables
+ :joins {:left (:joins left)
+ :right (:joins right)
+ :type type
+ :on join-condition}
+ :where where
+ :sort (seq (concat (:sort left)
+ (:sort right))))))))
(defn select [query expression]
(let [table-name (if (= (count (:tables query)) 1)
(-> query :tables first key))
old-where (:where query)
resolved-expression (process-expression table-name (:fields query) expression)
- new-where (combine-wheres old-where resolved-expression)]
+ new-where (combine-conjunctions old-where resolved-expression)]
(assoc query :where new-where)))
-(defn sort-by [query fields]
+(defn sort [query fields]
(let [table-name (if (= (count (:tables query)) 1)
(-> query :tables first key))
fields-seq (if (sequential? fields)
fields
- [fields])]
+ [fields])
+ fields-lookup (or (:fields query) {})]
(assoc query
- :sort-by (for [field fields-seq]
- (if (vector? field)
- [(resolve-field table-name (:fields query) (first field)) (second field)]
- [(resolve-field table-name (:fields query) field) :asc])))))
-
-
-(let [id 10]
- (-> (table {:x :carlo-table})
- (project [:x])
- (select `(and (in :x [1 2 3 :y])
- (= :x ~id)))
- (join (-> (table :y)
- (project [:y]))
- :on `(= :x :y)
- :type :left)
- (join (-> (table :z)
- (project [:x])))
- (sort-by [[:x :desc]])))
+ :sort (for [field fields-seq]
+ (if (vector? field)
+ [(resolve-field table-name fields-lookup (first field)) (second field)]
+ [(resolve-field table-name fields-lookup field) :asc])))))
+
+(defn group [query fields]
+ (let [table-name (if (= (count (:tables query)) 1)
+ (-> query :tables first key))
+ fields-seq (if (sequential? fields)
+ fields
+ [fields])
+ fields-lookup (or (:fields query) {})]
+ (assoc query :group (map (partial resolve-field table-name fields-lookup)
+ fields-seq))))
+
+(defn having [query expression]
+ (let [table-name (if (= (count (:tables query)) 1)
+ (-> query :tables first key))
+ old-having (:having query)
+ resolved-expression (process-expression table-name (:fields query) expression)
+ new-having (combine-conjunctions old-having resolved-expression)]
+ (assoc query :having new-having)))
+
+(-> (table :x)
+ (project [:x])
+ (join (-> (table :y)
+ (select `(= :id 10)))
+ :type :right))
+
+(let [users (-> (table :users)
+ (project [:id]))]
+ (join users users))
+
+(-> (table :x)
+ (project [:x])
+ (join (-> (table :y)
+ #_(select `(= :id 10)))
+ :type :full-outer))
+
+(-> (table :x)
+ (project [:x])
+ (join (-> (table :y)
+ (project [:x]))))
+
+#_(-> (table :x)
+ (project [:x])
+ (rename {:y :z}))
+
+(-> (table :x)
+ (project [:x])
+ (rename {:x :y}))
+
+(-> (table :people)
+ (project '{(count *) :count})
+ (group [:age])
+ (sort [:age])
+ (join (-> (table :number-count)
+ (project [:number :text])
+ (sort [:number]))
+ :on `(= :count :number))
+ (project [:text])
+ println)