Rework query.cljc to be more reductive, into a Context record.

Signed-off-by: Richard Newman <rnewman@twinql.com>

src/datomish/query.cljc

@@ -0,0 +1,225 @@
+;; This Source Code Form is subject to the terms of the Mozilla Public
+;; License, v. 2.0. If a copy of the MPL was not distributed with this
+;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(ns datomish.query
+  (:require
+     [datomish.util :as util :refer [raise var->sql-var]]
+     [datomish.transforms :as transforms]
+     [datascript.parser :as dp
+      #?@(:cljs [:refer [Pattern DefaultSrc Variable Constant Placeholder]])]
+     [clojure.string :as str]
+     [honeysql.core :as sql]
+     )
+  #?(:clj (:import [datascript.parser Pattern DefaultSrc Variable Constant Placeholder]))
+  )
+
+;; Setting this to something else will make your output more readable,
+;; but not automatically safe for use.
+(def sql-quoting-style :ansi)
+
+;;
+;; Context.
+;; 
+;; `attribute-transform` is a function from attribute to constant value. Used to
+;; turn, e.g., :p/attribute into an interned integer.
+;; `constant-transform` is a function from constant value to constant value. Used to
+;; turn, e.g., the literal 'true' into 1.
+;; `from` is a list of table pairs, suitable for passing to honeysql.
+;; `:bindings` is a map from var to qualified columns.
+;; `:wheres` is a list of fragments that can be joined by `:and`.
+;;
+(defrecord Context [from bindings wheres attribute-transform constant-transform])
+
+(defn attribute-in-context [context attribute]
+  ((:attribute-transform context) attribute))
+
+(defn constant-in-context [context constant]
+  ((:constant-transform context) constant))
+
+(defn bind-column-to-var [context variable col]
+  (let [var (:symbol variable)
+        existing-bindings (get-in context [:bindings var])]
+    (assoc-in context [:bindings var] (conj existing-bindings col))))
+
+(defn constrain-column-to-constant [context col position value]
+  (util/conj-in context [:wheres]
+                [:= col (if (= :a position)
+                          (attribute-in-context context value)
+                          (constant-in-context context value))]))
+
+(defn lookup-variable [context variable]
+  (or (-> context :bindings variable first)
+      (raise (str "Couldn't find variable " variable))))
+
+(defn make-context []
+  (->Context [] {} []
+             transforms/attribute-transform-string
+             transforms/constant-transform-default))
+  
+(defn apply-pattern-to-context
+  "Transform a DataScript Pattern instance into the parts needed
+   to build a SQL expression.
+
+  @arg context A Context instance.
+  @arg pattern The pattern instance.
+  @return an augmented Context."
+  [context pattern]
+  (when-not (instance? Pattern pattern)
+    (raise "Expected to be called with a Pattern instance."))
+  (when-not (instance? DefaultSrc (:source pattern))
+    (raise (str "Non-default sources are not supported in patterns. Pattern: "
+                (print-str pattern))))
+
+  (let [table (keyword (name (gensym "eavt")))
+        places (map (fn [place col] [place col])
+                    (:pattern pattern)
+                    [:e :a :v :t :added])]
+    (reduce
+      (fn [context
+           [pattern-part                           ; ?x, :foo/bar, 42 
+            position]]                             ; :a
+        (let [col (sql/qualify table position)]    ; :eavt.a
+          (condp instance? pattern-part
+            ;; Placeholders don't contribute any bindings, nor do
+            ;; they constrain the query -- there's no need to produce
+            ;; IS NOT NULL, because we don't store nulls in our schema.
+            Placeholder
+            context
+            
+            Variable
+            (bind-column-to-var context pattern-part col)
+
+            Constant
+            (constrain-column-to-constant context col position (:value pattern-part))
+
+            (raise (str "Unknown pattern part " (print-str pattern-part))))))
+
+      ;; Record the new table mapping.
+      (util/conj-in context [:from] [:eavt table])
+
+      places)))
+
+(defn- bindings->where
+  "Take a bindings map like
+    {?foo [:eavt12.e :eavt13.v :eavt14.e]}
+  and produce a list of constraints expression like
+    [[:= :eavt12.e :eavt13.v] [:= :eavt12.e :eavt14.e]]
+
+  TODO: experiment; it might be the case that producing more
+  pairwise equalities we get better or worse performance."
+  [bindings]
+  (println bindings)
+  (mapcat (fn [[_ vs]]
+            (when (> (count vs) 1)
+              (let [root (first vs)]
+                (map (fn [v] [:= root v]) (rest vs)))))
+          bindings))
+
+(defn expand-where-from-bindings
+  "Take the bindings in the context and contribute
+   additional where clauses. Calling this more than
+   once will result in duplicate clauses."
+  [context]
+  (assoc context :wheres (concat (bindings->where (:bindings context))
+                                 (:wheres context))))
+
+(defn patterns->context
+  "Turn a sequence of patterns into a Context."
+  [patterns]
+  (reduce apply-pattern-to-context (make-context) patterns))
+
+(defn elements->sql-projection
+  "Take a `find` clause's `:elements` list and turn it into a SQL
+   projection clause, suitable for passing as a `:select` clause to
+   honeysql.
+
+   For example:
+
+     [Variable{:symbol ?foo}, Variable{:symbol ?bar}]
+  
+   with bindings in the context:
+  
+     {?foo [:eavt12.e :eavt13.v], ?bar [:eavt13.e]}
+  
+   =>
+
+     [[:eavt12.e :foo] [:eavt13.e :bar]]
+
+   @param context A Context.
+   @param elements The input clause.
+   @return a sequence of pairs."
+  [context elements]
+  (when-not (every? #(instance? Variable %1) elements)
+    (raise "Unable to :find non-variables."))
+  (map (fn [elem]
+         (let [var (:symbol elem)]
+           [(lookup-variable context var) (var->sql-var var)]))
+       elements))
+
+(defn context->sql-clause [context elements]
+  {:select (elements->sql-projection context elements)
+   :from (:from context)
+   :where (if (empty? (:wheres context))
+            nil
+            (cons :and (:wheres context)))})
+
+(defn- validate-with [with]
+  (when-not (nil? with)
+    (raise "`with` not supported.")))
+
+(defn- validate-in [in]
+  (when-not (and (== 1 (count in))
+                 (= "$" (name (-> in first :variable :symbol))))
+    (raise (str "Complex `in` not supported: " (print-str in)))))
+  
+(defn find->sql-clause
+  "Take a parsed `find` expression and turn it into a structured SQL
+   expression that can be formatted by honeysql."
+  [find]
+  ;; There's some confusing use of 'where' and friends here. That's because
+  ;; the parsed Datalog includes :where, and it's also input to honeysql's
+  ;; SQL formatter.
+  (let [{:keys [find in with where]} find]  ; Destructure the Datalog query.
+    (validate-with with)
+    (validate-in in)
+    (context->sql-clause
+      (expand-where-from-bindings
+        (patterns->context where))    ; 'where' here is the Datalog :where clause.
+      (:elements find))))
+
+(defn find->sql-string
+  "Take a parsed `find` expression and turn it into SQL."
+  [find]
+  (-> find find->sql-clause (sql/format :quoting sql-quoting-style)))
+
+(defn parse
+  "Parse a Datalog query array into a structured `find` expression."
+  [q]
+  (dp/parse-query q))
+
+(comment
+  (datomish.query/find->sql-string
+    (datomish.query/parse
+      '[:find ?page :in $ :where [?page :page/starred true ?t] ])))
+
+(comment
+  (datomish.query/find->sql-string
+    (datomish.query/parse
+      '[:find ?timestampMicros ?page
+      :in $
+      :where
+      [?page :page/starred true ?t]
+      [?t :db/txInstant ?timestampMicros]])))
+
+(comment
+  (pattern->sql
+    (first
+      (:where
+        (datomish.query/parse
+          '[:find (max ?timestampMicros) (pull ?page [:page/url :page/title]) ?page
+          :in $
+          :where
+          [?page :page/starred true ?t]
+          [?t :db/txInstant ?timestampMicros]])))
+    identity))

src/datomish/transforms.cljc

@@ -0,0 +1,21 @@
+;; This Source Code Form is subject to the terms of the Mozilla Public
+;; License, v. 2.0. If a copy of the MPL was not distributed with this
+;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(ns datomish.transforms)
+
+#?(:clj
+     (defn boolean? [x]
+       (instance? Boolean x)))
+
+(defn attribute-transform-string
+  "Turns :p/foo into \"p/foo\". Adequate for testing, but this depends on the storage schema."
+  [x]
+  (str (namespace x) "/" (name x)))
+
+(defn constant-transform-default [x]
+  (if (boolean? x)
+    (if x 1 0)
+    (if (keyword? x)
+      (attribute-transform-string x)
+      x)))

src/datomish/util.cljc

@@ -0,0 +1,31 @@
+;; This Source Code Form is subject to the terms of the Mozilla Public
+;; License, v. 2.0. If a copy of the MPL was not distributed with this
+;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(ns datomish.util
+  (:require
+     [clojure.string :as str]))
+
+(defn raise [s]
+  #?(:clj (throw (Exception. s)))
+  #?(:cljs (throw (js/Error s))))
+
+(defn var->sql-var
+  "Turns '?xyz into :xyz."
+  [x]
+  (if (and (symbol? x)
+           (str/starts-with? (name x) "?"))
+    (keyword (subs (name x) 1))
+    (raise (str x " is not a Datalog var."))))
+
+(defn conj-in
+  "Associates a value into a sequence in a nested associative structure, where
+  ks is a sequence of keys and v is the new value, and returns a new nested
+  structure.
+  If any levels do not exist, hash-maps will be created. If the destination
+  sequence does not exist, a new one is created."
+  {:static true}
+  [m [k & ks] v]
+  (if ks
+    (assoc m k (conj-in (get m k) ks v))
+    (assoc m k (conj (get m k) v))))

test/datomish/test.cljs

@@ -3,8 +3,15 @@
    [doo.runner :refer-macros [doo-tests doo-all-tests]]
    [cljs.test :as t :refer-macros [is are deftest testing]]
    datomish.promise-sqlite-test
+   datomish.test.util
+   datomish.test.transforms
+   datomish.test.query
+   datomish.test.core
    datomish.test-macros-test))
 
 (doo-tests
   'datomish.promise-sqlite-test
+  'datomish.test.util
+  'datomish.test.transforms
+  'datomish.test.query
   'datomish.test-macros-test)

test/datomish/test/query.cljc

@@ -0,0 +1,9 @@
+(ns datomish.test.query
+  (:require
+     [datomish.query :as dq]
+     #?(:clj  [clojure.test :as t :refer [is are deftest testing]])
+     #?(:cljs [cljs.test :as t :refer-macros [is are deftest testing]])
+     ))
+
+(deftest test-query
+  (is (= 1 1)))

test/datomish/test/transforms.cljc

@@ -0,0 +1,26 @@
+(ns datomish.test.transforms
+  (:require
+     [datomish.transforms :as transforms]
+     #?(:clj  [clojure.test :as t :refer [is are deftest testing]])
+     #?(:cljs [cljs.test :as t :refer-macros [is are deftest testing]])
+     ))
+
+(deftest test-attribute-transform-string
+  (is (= "p/foo"
+         (transforms/attribute-transform-string :p/foo))))
+
+(deftest test-constant-transform-default
+  ;; Keywords.
+  (is (= "p/foo" (transforms/constant-transform-default :p/foo)))   ; For now.
+
+  ;; Booleans.
+  (is (= 1 (transforms/constant-transform-default true)))
+  (is (= 0 (transforms/constant-transform-default false)))
+
+  ;; Numbers and strings.
+  #?(:cljs (is (= 1 (transforms/constant-transform-default 1.0))))
+  #?(:clj  (is (= 1.0 (transforms/constant-transform-default 1.0))))
+  (is (= -1 (transforms/constant-transform-default -1)))
+  (is (= 42 (transforms/constant-transform-default 42)))
+  (is (= "" (transforms/constant-transform-default "")))
+  (is (= "foo" (transforms/constant-transform-default "foo"))))

test/datomish/test/util.cljc

@@ -0,0 +1,20 @@
+(ns datomish.test.util
+  (:require
+     [datomish.util :as util]
+     #?(:clj  [clojure.test :as t :refer [is are deftest testing]])
+     #?(:cljs [cljs.test :as t :refer-macros [is are deftest testing]])
+     ))
+
+(deftest test-var-translation
+  (is (= :x (util/var->sql-var '?x)))
+  (is (= :XX (util/var->sql-var '?XX))))
+
+#?(:cljs
+     (deftest test-raise
+       (let [caught
+             (try
+               (do
+                 (util/raise "succeed")
+                 "fail")
+               (catch :default e e))]
+         (is (= "succeed" (aget caught "message"))))))