zipper solution for splitting nested relational query (pull spec) into flat select queries which can be stiched together

relational_mapper.clj

(ns om-starter.relational-mapper
  (:require [om.next.impl.parser :as parser]
            [om.next.server :as om]
            [clojure.zip :as zip :refer [zipper]]
            [clojure.test :refer [deftest is]])
  (:use clojure.pprint))

(defn make-node
  "Build new om.next ast node making sure query and children match."
  [old-node children]
  (assoc old-node
    :query (mapv parser/ast->expr children)
    :children (vec children)))

(defn path
  "Fetch path for ast node loc"
  [loc]
  (loop [loc loc
         path (list (-> loc zip/node :key))]
    (if-let [parent (zip/up loc)]
      (recur parent (conj path (-> parent zip/node :key)))
      (vec path))))

(defn join-type
  "Use path to work out type of relation"
  [schema loc]
  (if (zip/up loc)
    (let [a (-> loc zip/up zip/node :key)
          b (-> loc zip/node :key)]
      (get-in schema [a b]))))

(defn ast-zip
  "Build zipper from ast."
  [ast]
  (zipper :children :children make-node ast))

(defn shred?
  "Logic for deciding when to split query:
   * by default split on has-many
   * don't split if :include is present and true
   * force split if :include is present and false
  "
  [schema loc]
  (let [node (zip/node loc)
        has-many? (= :has-many (join-type schema loc))
        root? (nil? (zip/up loc))
        params (-> node :params)]
    (if-not root?
      (case (get params :include :default)
        true false
        false true
        :default has-many?))))

(defn shred
  "Process ast zipper.  Splits nested relational query into simple select queries."
  [schema loc]
  (loop [loc loc ret nil]
    (if (zip/end? loc)
      (cons {:ast (zip/root loc)} ret)
      (if (shred? schema loc)
        (recur (zip/next (zip/remove loc))
               (concat ret (for [query-path (shred schema (ast-zip (zip/node loc)))]
                             (update query-path :path #(concat (path loc) (rest %))))))
        (recur (zip/next loc) ret)))))

(defn readf
  [env k params]
  (let [{:keys [schema query path parser ast]} env
        loc (ast-zip ast)
        queries (shred schema (zip/next loc))
        value (loop [queries (seq queries) ret nil]
                (if (seq queries)
                  (let [{:keys [path ast]} (first queries)
                        {:keys [key query params]} ast
                        results (parser/ast->expr ast)
                        ret (if ret (concat ret `((q/select-in ~(vec path) ~results)))
                                    `(q/-> (q/select ~results)))]
                    (recur (next queries) ret))
                  ret))]
    {:value value}))

(def parser (om/parser {:read readf}))

(def schema {:race    {:meeting      :belongs-to
                       :logged-event :has-many}
             :meeting {:race  :has-many
                       :venue :belongs-to}
             :venue   {:meeting :has-many}})

(println "\nSelect meetings, then select associated races")
(pprint (parser {:schema schema} '[{:meeting [{:race [*]}]}]))

(println "\nSelect meetings and races in one query")
(pprint (parser {:schema schema} '[{:meeting [({:race [*]} {:include true})]}]))

(println "\nSelect races and join to associated meetings")
(pprint (parser {:schema schema} '[{:race [({:meeting [*]} {:include true})]}]))

(println "\nSelect races, select meetings after to avoid duplication")
(pprint (parser {:schema schema} '[{:race [({:meeting [*]} {:include false})]}]))

(println "\nSelect meetings, then select races, then select logged events")
(pprint (parser {:schema schema} '[{:meeting [* {:race [:number :time {:logged-event [*]}]}]}]))

(println "\nSelect meetings joined on races, then select logged events")
(pprint (parser {:schema schema} '[{:meeting [({:race [* {:logged-event [*]}]} {:include true})]}]))

(println "\nSelect one day's meetings joined on races, then select logged events")
(pprint (parser {:schema schema} '[({:meeting [*]} {:where [:date := "2016-01-01"]})]))

(println "\nSelect one day's meetings")
(pprint (parser {:schema schema} '[({:meeting [*]} {:where [[:date := "2016-01-01"]]})]))

(println "\nSelect one day's meetings, select non-archived races")
(pprint (parser {:schema schema}
                '[({:meeting [* ({:race [*]}
                                  {:where [[:is-archived := false]]})]}
                    {:where [[:date := "2016-01-01"]]})]))

script-output.clj

Select meetings, then select associated races
{:meeting
 (q/->
  (q/select {:meeting []})
  (q/select-in [:meeting :race] {:race [*]}))}

Select meetings and races in one query
{:meeting (q/-> (q/select {:meeting [({:race [*]} {:include true})]}))}

Select races and join to associated meetings
{:race (q/-> (q/select {:race [({:meeting [*]} {:include true})]}))}

Select races, select meetings after to avoid duplication
{:race
 (q/->
  (q/select {:race []})
  (q/select-in [:race :meeting] ({:meeting [*]} {:include false})))}

Select meetings, then select races, then select logged events
{:meeting
 (q/->
  (q/select {:meeting [*]})
  (q/select-in [:meeting :race] {:race [:number :time]})
  (q/select-in [:meeting :race :logged-event] {:logged-event [*]}))}

Select meetings joined on races, then select logged events
{:meeting
 (q/->
  (q/select {:meeting [({:race [*]} {:include true})]})
  (q/select-in [:meeting :race :logged-event] {:logged-event [*]}))}

Select one day's meetings joined on races, then select logged events
{:meeting
 (q/-> (q/select ({:meeting [*]} {:where [:date := "2016-01-01"]})))}

Select one day's meetings
{:meeting
 (q/-> (q/select ({:meeting [*]} {:where [[:date := "2016-01-01"]]})))}

Select one day's meetings, select non-archived races
{:meeting
 (q/->
  (q/select ({:meeting [*]} {:where [[:date := "2016-01-01"]]}))
  (q/select-in
   [:meeting :race]
   ({:race [*]} {:where [[:is-archived := false]]})))}