Skip to content

Instantly share code, notes, and snippets.

@favila
Last active Sep 1, 2017
Embed
What would you like to do?
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…
(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)))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment