Most of the RA stuff works now.

Need to fix up the compilation to return a query ready for value substitution
by the jdbc stuff, or something (rather than embedding parameters in the
query).

Also need to add insert!, update! and delete! functions.

5 files changed, 339 insertions, 8 deletions

diff --git a/.hgignore b/.hgignore
index c04b460..2970b8e 100644
--- a/.hgignore
+++ b/.hgignore
@@ -11,3 +11,4 @@ pom.xml.asc
 .lein-failures
 .lein-plugins
 .lein-repl-history
+.\#*
diff --git a/README.md b/README.md
index 7b454a1..5e58b6b 100644
--- a/README.md
+++ b/README.md
@@ -1,10 +1,36 @@
 # clojure-sql
 
-A Clojure library designed to ... well, that part is up to you.
+A DSL for [Clojure][1] to compose queries using the constructs of [Relational
+Algebra][2]. The RA constructs are then compiled into an SQL query to be run on
+a DBMS.
+
+`clojure-sql` provides some utility functions beyond strict RA to allow for
+data to be inserted, updated and deleted.
+
+`clojure-sql` provides no mechanism to create database schemas.
+
+[1]: http://clojure.org/
+[2]: http://en.wikipedia.org/wiki/Relational_Algebra
 
 ## Usage
 
-FIXME
+    (require '[clojure.sql :as s])
+
+    (-> (s/table :users)
+        (s/project [:id :username])
+        deref)
+    ; => "SELECT \"users\".\"id\", \"users\".\"username\" FROM \"users\""
+
+    (-> (s/table {:users :u})
+        (s/project [:id :username])
+        (s/rename {:id :uid})
+        (s/join (-> (s/table {:people :p})
+                    (s/project {:id :pid, :fname :first})
+                    (s/select '(= :first "Henry")))
+                '(= :uid :pid))
+        (s/project [:username])
+        deref)
+    ; => "SELECT \"u\".\"username\" FROM \"users\" AS \"u\" JOIN \"people\" AS \"p\" ON (\"u\".\"id\" = \"p\".\"id\") WHERE (\"p\".\"fname\" = 'Henry')"
 
 ## License
 
diff --git a/project.clj b/project.clj
index c024d44..a568c1d 100644
--- a/project.clj
+++ b/project.clj
@@ -3,4 +3,5 @@
   :url "http://example.com/FIXME"
   :license {:name "Eclipse Public License"
             :url "http://www.eclipse.org/legal/epl-v10.html"}
-  :dependencies [[org.clojure/clojure "1.5.1"]])
+  :dependencies [[org.clojure/clojure "1.5.1"]
+                 [midje "1.5.0"]])
diff --git a/src/clojure_sql/core.clj b/src/clojure_sql/core.clj
index 423ff8e..2000595 100644
--- a/src/clojure_sql/core.clj
+++ b/src/clojure_sql/core.clj
@@ -1,6 +1,299 @@
-(ns clojure-sql.core)
+(ns clojure-sql.core
+  (:refer-clojure :exclude [sort-by])
+  (:require [clojure.set :as set]
+            [clojure.string :as string]
+            [clojure-sql.util :as u]))
 
-(defn foo
-  "I don't do a whole lot."
-  [x]
-  (println x "Hello, World!"))
+(defn add-parentheses [s]
+  (str \( s \)))
+
+(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 sql-string (fn [db _] db))
+(defmethod sql-string :default [_ string]
+  (str \' (string/replace string "'" "''") \'))
+
+;; compile-* multimethods are of the signature:
+;;  (db, expr) -> (SQL, replacements)
+
+(def is-unary? (comp boolean '#{not}))
+(def is-predicate? (comp boolean '#{= < > <= >= is in}))
+
+(defn c-lift [f]
+  (fn [& args]
+    (let [seconds (map second args)])
+    (apply f (map first args))))
+(defn c-str [elements]
+  (reduce (fn [[string args] [new-string new-args]]
+            [(str string new-string)
+             (vec concat args new-args)])
+          ["" nil] elements))
+
+(defmulti compile-expression (fn [db _] db))
+(defmethod compile-expression :default [db ex]
+  (condp #(%1 %2) ex
+    nil? "NULL"
+    vector? (str (table-name db (first ex)) \. (field-name db (second ex)))
+    keyword? (field-name db ex)
+    string? (sql-string db ex)
+    symbol? (string/upper-case (name ex))
+    sequential? (if (= (count ex) 2)
+                  (->> (second ex)
+                       (compile-expression db)
+                       (str (compile-expression db (first ex)) " ")
+                       add-parentheses) 
+                  (->> (rest ex)
+                       (map (partial compile-expression db))
+                       (interpose (compile-expression db (first ex)))
+                       (string/join " ")
+                       add-parentheses))
+    ex))
+
+(defmulti compile-join (fn [db _] db))
+(defmethod compile-join :default [db [type table-map on]]
+  (str (case type
+         :left " LEFT OUTER "
+         :right " RIGHT OUTER "
+         "")
+       " JOIN " (compile-tables db table-map) " ON " (compile-expression db on)))
+
+(defmulti compile-joins (fn [db _] db))
+(defmethod compile-joins :default [db joins]
+  (->> joins
+       (map (partial compile-join db))
+       (string/join " ")))
+
+(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 ", "))
+    "*"))
+
+(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 ", ")))
+
+(defmulti compile-where (fn [db _] db))
+(defmethod compile-where :default [db expr]
+  (if expr
+    (str " 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 "))))
+
+(defmulti compile-query (fn [db _] db))
+(defmethod compile-query :default [db {:keys [table fields joins where sort-by]}]
+  (str "SELECT "
+       (compile-fields db fields)
+       " 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) \`))
+
+(defmethod sql-string :mysql [_ string]
+  (str \"  (string/replace string "\"" "\\\"") \"))
+
+
+
+
+
+;; important sections:
+;;   -PROJECTION-
+;;   -TABLES-
+;;   -FILTERS-
+;;   GROUPING
+;;   GROUPED FILTERS
+;;   -SORTING-
+
+
+;; table: tablename -> table_alias
+;; fields: (table_alias, fieldname) -> field_alias
+;; joins: [(tablename -> table_alias, type, on)]
+;; where: expression
+;; group-by: [field]
+;; having: expression
+
+(def ^:dynamic *database-type* nil)
+(defrecord Table []
+  clojure.lang.IDeref
+  (deref [this] (compile-query *database-type* this)))
+
+(defn table [arg]
+  (into (->Table)
+        (if (map? arg)
+          {:table arg}
+          {:table {arg arg}})))
+
+(defn project [query fields]
+  (let [table (-> query :table first val)
+        alias-lookup (->> query :fields
+                          (map (comp vec reverse))
+                          (into {}))
+        original-name (fn [field]
+                        (if (vector? field)
+                          field
+                          (get alias-lookup field [table field])))]
+    (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)]}
+  (let [alias-lookup (->> query :fields
+                          (map (comp vec reverse))
+                          (into {}))
+        original-name (fn [field]
+                        (cond (vector? field) field
+                              (contains? alias-lookup field) (get alias-lookup field)
+                              :else (throw (ex-info (str "Invalid field in rename: " (pr-str field))
+                                                    {:field field
+                                                     :query query
+                                                     :renames field-renames})))
+                        (get alias-lookup field))]
+    (update-in query
+               [:fields] #(->> (for [[key val] field-renames]
+                                 [(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]))))
+
+(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 on & [type]]
+  (let [joins-vector (or (:join left) [])
+        joined-fields (merge (:fields left) (:fields right))]
+    (-> left
+        (assoc :fields joined-fields)
+        (assoc :joins (into (conj joins-vector
+                                  [(or type :inner) (:table right) (resolve-fields nil joined-fields on)])
+                            (:joins right)))
+        (assoc :where (combine-wheres (:where left) (:where right))))))
+
+(defn select [query expression]
+  (let [table-name (-> 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]
+  #_{:pre [(let [flipped-query-fields (u/flip-map (:fields query))
+               field-names-seq (map (fn [x] (if (vector? x) (first x) x)) 
+                                    (if (sequential? fields) fields [fields]))]
+           (every? flipped-query-fields field-names-seq))]}
+  (let [table-name (-> 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])))))
+
+
+(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 `(= :username "Carlo")
+        query (-> (join (-> users
+                            (rename {:id :uid}))
+                        (join (-> people
+                                  (rename {:id :pid}))
+                              (-> (table {:others :o})
+                                  (project {:id :oid}))
+                              '(= :pid :oid))
+                        uid-pid-match)
+                  (select is-carlo)
+                  (project [:fname :sname :oid]))]
+    @query))
+
+(-> (table {:nodes :child})
+    (project [:parent-id, :name])
+    (rename {:name :child.name})
+    (join (-> (table {:nodes :parent})
+              (project [:id, :name])
+              (rename {:name :parent.name}))
+          '(= :parent-id :id))
+    (project [:child.name :parent.name])
+    deref #_println)
+
+
+(deref (-> (table :anotherStack)
+           (project [:anotherNumber])
+           (join (-> (table :collection)
+                     (project [:number]))
+                 true)))
diff --git a/src/clojure_sql/util.clj b/src/clojure_sql/util.clj
new file mode 100644
index 0000000..03c90f1
--- /dev/null
+++ b/src/clojure_sql/util.clj
@@ -0,0 +1,10 @@
+(ns clojure-sql.util)
+
+(defn flip [f]
+  (fn [& args]
+    (apply f (reverse args))))
+
+(defn flip-map [m]
+  (->> m
+       (map (comp vec reverse))
+       (into {})))