summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/clojure_sql/compiler.clj216
-rw-r--r--src/clojure_sql/core.clj87
-rw-r--r--src/clojure_sql/dsl.clj49
-rw-r--r--src/clojure_sql/query.clj19
-rw-r--r--src/clojure_sql/util.clj3
-rw-r--r--src/clojure_sql/writer.clj69
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))
generated by cgit v1.2.3 (git 2.46.2) at 2024-11-10 07:58:02 +0000