path: root/src/clojure_sql/dsl.clj

(ns clojure-sql.dsl
  (:refer-clojure :exclude [sort group take drop])
  (:require [clojure.set :as set]
            [clojure.walk :as walk]
            [clojure-sql.query :as q]
            [clojure-sql.util :as u]))


;; ==============================================================
;; The DSL for making query maps
;; ==============================================================

;; important sections:
;;   -PROJECTION-
;;   -TABLES-
;;   -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 => [(field, direction)]
;;  :group => [field]
;;  :having => expression
;; }

(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 multiple 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 ^:private invalid-union [queries]
  (throw (ex-info "Cannot union queries with different fields"
                  {:queries queries})))

(defn table [arg]
  (q/map->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 (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 (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))

(defn project [query fields]
  (let [table (if (= (count (:tables query)) 1)
                (-> query :tables first key))
        alias-lookup (or (:fields query) {})
        get-real-name #(process-expression table alias-lookup %)
        fields (if (map? fields)
                 fields
                 (zipmap fields fields))]
    (assoc query
      :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 ^: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]
  (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
                  :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 ^:private joinable? [query] 
  (and (nil? (:group query))
       (nil? (:having query))
       (nil? (:take query))
       (nil? (:drop query))))

(defn ^:private convert-to-subquery [query]
  (-> (table query)
      (project (keys (:fields query)))))

(defn ^:private remove-sort [query]
  (dissoc query :sort))

(defn ^:private make-join-subquery [query]
  (if (joinable? query)
    query
    (if (or (:take query) (:drop query))
      (convert-to-subquery query)
      (convert-to-subquery (remove-sort query)))))

(def ^:private valid-join-type? (comp boolean #{:cross :inner :outer :full-outer}))
(defn join [left right & {:keys [on type]}]
  (if (= type :right)
    (join right left :on on :type :left)
    (let [type (if (= type :left)
                 :outer
                 type)
          left (make-join-subquery left)
          right (make-join-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 right) (:fields left)) ;; favour the left name for outer joins
          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-conjunctions old-where resolved-expression)]
    (assoc query :where new-where)))

(defn sort [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
      :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)))

(defn take [query n]
  (if-let [old-take (:take query)]
    (assoc query :take (min old-take n))
    (assoc query :take n)))

(defn drop [query n]
  (let [query (if-let [old-take (:take query)]
                (assoc query :take (- old-take n))
                query)]
    (if-let [old-drop (:drop query)]
      (assoc query :drop (+ old-drop n))
      (assoc query :drop n))))