diff options
Diffstat (limited to 'src/clojure_sql')
| -rw-r--r-- | src/clojure_sql/compiler.clj | 74 | ||||
| -rw-r--r-- | src/clojure_sql/dsl.clj | 329 |
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) |