Spec for a relation (tuple with named positions, optional trailing positions). Takes key + predicate pairs, and an optional final vector with key + predicate pairs. The predicates cannot be regexs. Returns a regex op that matches all values in sequence and returns a map of keys to the corresponding value, like s/cat. Unlike s/cat, values may onl…

spec-relation.clj

(ns com.breezeehr.spec-utils
  (:require [clojure.spec.alpha :as s]))

(s/def ::relation-arg-pair
  (s/cat
    :k (s/and keyword? #(not= % ::relation-tail))
    :v #(not (s/regex? %))))

(defn- distinct-relation-keys? [{:keys [req opt]}]
  (apply distinct? (concat (map :k req) (map :k opt))))

(s/def ::relation-args
  (s/and
    (s/cat
      :req (s/* ::relation-arg-pair)
      :opt (s/? (s/and vector? (s/* ::relation-arg-pair))))
    distinct-relation-keys?))

(defn- lift-relation-tail
  [{:keys [::relation-tail] :as m}]
  (into (dissoc m ::relation-tail) relation-tail))

(defn- push-relation-tail [opt-keys m]
  (let [head (apply dissoc m opt-keys)
        tail (select-keys m opt-keys)]
    (cond-> head
      (pos? (count tail))
      (assoc ::relation-tail tail))))

(defn relation-tail [opt-keys]
  (s/conformer lift-relation-tail #(push-relation-tail opt-keys %)))


(defmacro relation-impl [req [first-opt & rest-opt :as opt]]
  (if (some? first-opt)
    (let [opt-keys (mapv first opt)]
      `(s/&
         (s/cat ~@(apply concat req)
           ::relation-tail (s/? (relation-impl [~first-opt] ~rest-opt)))
         (relation-tail ~opt-keys)))
    `(s/cat ~@(apply concat req))))

(defmacro relation
  "Takes key + predicate pairs, and an optional final vector with
  key + predicate pairs. The predicates cannot be regexs.

  Returns a regex op that matches all values in sequence and returns a
  map of keys to the corresponding value, like s/cat. Unlike s/cat,
  values may only match by absolute position like s/tuple. Unlike s/tuple,
  positions on the rightmost side of the sequence may be optional if omitted.

    (s/conform (relation :a keyword? [:b string? :c keyword?]) [:kw])
    ;=> {:a :kw}
    (s/conform (relation :a keyword? [:b string? :c keyword?]) [:kw \"\"])
    ;=> {:a :kw, :b \"\"}
    (s/conform (relation :a keyword? [:b string? :c keyword?]) [:kw :kw])
    ;=> ::s/invalid
    (s/conform (relation :a keyword? [:b string? :c keyword?]) [:kw \"\" :kw :kw])
    ;=> ::s/invalid"
  [& key-pred-forms+optional-key-pred-forms]
  (let [{:keys [req opt] :as r} (s/conform ::relation-args key-pred-forms+optional-key-pred-forms)
        _ (when (s/invalid? r) (s/assert* ::relation-args key-pred-forms+optional-key-pred-forms))
        flat-req (mapv (juxt :k :v) req)
        flat-opt (mapv (juxt :k :v) opt)]
    `(relation-impl ~flat-req ~flat-opt)))