A GraphQL-like Query Language for Datomic (https://nikolasgoebel.com/2018/06/26/a-query-language.html)

deps.edn

{:deps
 {org.clojure/clojure      {:mvn/version "1.9.0"}
  com.datomic/datomic-free {:mvn/version "0.9.5697"}}}

interpreter.clj

(require '[clojure.set :as set])
(require '[datomic.api :as d])

(load "parser")

(defmulti impl (fn [ctx node] (first node)))

(defn pull [db pattern eids]
  (let [ctx {:db     db
             :datoms #{}
             :eids   eids}]
    (impl ctx [:pattern pattern])))

(defmethod impl :pattern [ctx [_ specs]]
  (reduce impl ctx specs))

(defmethod impl :attribute [{:keys [db eids] :as ctx} [_ attr]]
  (let [datoms (into #{}
                     (filter (fn [datom] (contains? eids (.-e datom))))
                     (d/datoms db :aevt attr))]
    (update ctx :datoms set/union datoms)))

(defmethod impl :expand [{:keys [db eids] :as ctx} [_ map-spec]]
  (let [[attr pattern] (first map-spec)
        children       (into #{}
                             (filter (fn [datom] (contains? eids (.-e datom))))
                             (d/datoms db :aevt attr))
        children-eids  (into #{} (map :v) children)
        children-ctx   (pull db pattern children-eids)]
    (-> ctx
        (update :eids set/union (:eids children-ctx))
        (update :datoms set/union (into #{} (filter (fn [datom]
                                                      (contains? (:eids children-ctx) (.-v datom))) children)))
        (update :datoms set/union (:datoms children-ctx)))))

(defmethod impl :clause [{:keys [db eids] :as ctx} [_ clause]]
  (let [[_ data-pattern] clause
        [attr v]         data-pattern
        indexed?         (:indexed (d/attribute db attr))
        matching-datoms  (if indexed?
                           (into #{} (d/datoms db :avet attr v))
                           (into #{}
                                 (filter (fn [datom] (= (.-v datom) v)))
                                 (d/datoms db :aevt attr)))]
    (-> ctx
        (update :datoms set/union matching-datoms)
        (update :eids set/intersection (into #{} (map :e) matching-datoms)))))

(defn resolve-root [db root]
  (case root
    :human (set (d/q '[:find [?e ...] :where [?e :human/name _]] db))))

(defn resolve-query [db query]
  (->> query
       (parse)
       (reduce-kv
        (fn [result root pattern]
          (let [root-eids (resolve-root db root)
                ctx       (pull db pattern root-eids)
                eids      (:eids ctx)
                entities  (->> (:datoms ctx)
                               (reduce
                                (fn [tree datom]
                                  (if-not (contains? eids (.-e datom))
                                    tree
                                    (let [attr (d/attribute db (.-a datom))
                                          ref? (= (:value-type attr) :db.type/ref)]
                                      (if ref?
                                        (update-in tree [(.-e datom) (:ident attr)] conj (.-v datom))
                                        (assoc-in tree [(.-e datom) (:ident attr)] (.-v datom)))))) {}))
                hydrate   (fn [eid]
                            (->> (get entities eid)
                                 (reduce-kv
                                  (fn [entity a v]
                                    (let [attr (d/attribute db a)
                                          ref? (= (:value-type attr) :db.type/ref)]
                                      (if-not ref?
                                        (assoc entity a v)
                                        (if (coll? v)
                                          (assoc entity a (mapv entities v))
                                          (assoc entity a (get entities v)))))) {})))
                ;; hydrate
                tree      (->> root-eids
                               (into [] (comp (map hydrate) (remove empty?))))]
            (assoc result root tree))) {})))

;; TRY IT OUT

(comment

  (def uri "datomic:mem://language")
  (d/create-database uri)
  (def conn (d/connect uri))

  (def schema
    [{:db/ident       :human/name
      :db/valueType   :db.type/string
      :db/unique      :db.unique/identity
      :db/cardinality :db.cardinality/one}
     {:db/ident       :human/starships
      :db/valueType   :db.type/ref
      :db/cardinality :db.cardinality/many}
     {:db/ident       :ship/name
      :db/valueType   :db.type/string
      :db/unique      :db.unique/identity
      :db/cardinality :db.cardinality/one}
     {:db/ident       :ship/class
      :db/valueType   :db.type/keyword
      :db/cardinality :db.cardinality/one}])
  
  (d/transact conn schema)

  (d/transact conn
              [{:human/name      "Naomi Nagata"
                :human/starships [{:db/id "roci" :ship/name "Roci" :ship/class :ship.class/fighter}
                                  {:ship/name "Anubis" :ship/class :ship.class/science-vessel}]}
               {:human/name      "Amos Burton"
                :human/starships ["roci"]}])

  ;; verify
  (d/q '[:find ?e ?name :where [?e :human/name ?name]] (d/db conn))
  (d/q '[:find [?name ...] :where [_ :ship/name ?name]] (d/db conn))
  (d/pull (d/db conn) '[:human/name {:human/starships [*]}] [:human/name "Naomi Nagata"])

  (resolve-query (d/db conn) '{:human [:human/name]})

  (resolve-query (d/db conn) '{:human [:human/name
                                       {:human/starships [:ship/name
                                                          :ship/class]}]})

  (resolve-query (d/db conn) '{:human [[:human/name "Naomi Nagata"] 
                                       {:human/starships [:ship/name :ship/class]}]})
  
  (resolve-query (d/db conn)
                 '{:human [:human/name
                           {:human/starships [:ship/name
                                              [:ship/class :ship.class/fighter]]}]}))

parser.clj

(require '[clojure.string :as str])
(require '[clojure.spec.alpha :as s])

;; A simple GraphQL expression: 
;;
;; {
;;   human(id: 1002) {
;;     name
;;     starships {
;;       name
;;       class
;;     }
;;   }
;; }
;; 
;; Translated into Datalog, this could look a bit like this:

'{:human [:human/name
          {:human/starships [:ship/name
                             :ship/class]}]}

;; As we can see, GraphQL also allows to specify arguments on the
;; root, allowing clients to filter out the entities that they're
;; interested in. We could translate this as such:

'{(human {:db/id 1002}) [:human/name
                         {:human/starships [:ship/name
                                            :ship/class]}]}

;; But just to keep things fresh and interesting, let's do it in a bit
;; more general, clause-oriented way.

'{:human [[:db/id 1002]
          :human/name
          {:human/starships [:ship/name
                             :ship/class]}]}

;; Note that this would allows us to do something that GraphQL can't,
;; which is to filter nested relations as well.

'{:human [[:db/id 1002]
          :human/name
          {:human/starships [[:ship/name "Anubis"]
                             :ship/class]}]}

;; Let's formalize this into a grammar.

(s/def ::query (s/map-of keyword? ::pattern))
(s/def ::pattern (s/coll-of ::attr-spec))
(s/def ::attr-spec (s/or :attribute ::attr-name
                         :clause ::clause
                         :expand ::map-spec))
(s/def ::attr-name keyword?)
(s/def ::clause (s/or :data-pattern ::data-pattern))
(s/def ::data-pattern (s/tuple ::attr-name ::constant))
(s/def ::constant (constantly true)) ;; @TODO
(s/def ::map-spec (s/and (s/map-of ::attr-name ::pattern)
                         #(= (count %) 1)))

;; core.spec then gives us a parser for free

(defn parse [query]
  (let [conformed (s/conform ::query query)]
    (if (s/invalid? conformed)
      (throw (ex-info "Couldn't parse query" (s/explain-data ::query query)))
      conformed)))

(comment
  
  ;; Try it out
  
  (parse '{:human [:human/name
                   {:human/starships [:ship/name :ship/class]}]})

  (parse '{:human [[:db/id 1002]
                   :human/name
                   {:human/starships [[:ship/name "Anubis"]
                                      :ship/class]}]})