cat

babashka · Oct 22, 2024 · 4119db2 · 4119db2
1 parent 9fb036e
commit 4119db2
Showing 1 changed file with 22 additions and 3 deletions.
diff --git a/src/sci/configs/cljs/spec/alpha.cljs b/src/sci/configs/cljs/spec/alpha.cljs
@@ -1,5 +1,5 @@
 (ns sci.configs.cljs.spec.alpha
-  (:refer-clojure :exclude [and or keys merge every])
+  (:refer-clojure :exclude [and or keys merge every cat])
   (:require [clojure.spec.alpha :as s]
             [cljs.spec.gen.alpha :as gen]
             [sci.core :as sci]
@@ -177,7 +177,7 @@
   {:i1 42, :m {:a 1, :c 2, :d 4}, :i2 99}"
   [& kspecs]
   `(let [mspec# (s/keys ~@kspecs)]
-     (s/with-gen (s/& (* (cat ::s/k keyword? ::s/v cljs.core/any?)) ::s/kvs->map mspec#)
+     (s/with-gen (s/& (* (s/cat ::s/k keyword? ::s/v cljs.core/any?)) ::s/kvs->map mspec#)
        (fn [] (gen/fmap (fn [m#] (apply concat m#)) (s/gen mspec#))))))
 
 (macros/defmacro &
@@ -311,6 +311,23 @@
         desc `(every-kv ~(res &env kpred) ~(res &env vpred) ~@(res-kind &env opts))]
     `(s/every (s/tuple ~kpred ~vpred) ::s/kfn (fn [i# v#] (nth v# 0)) :into {} ::s/describe '~desc ~@opts)))
 
+(macros/defmacro cat
+  "Takes key+pred pairs, e.g.
+
+  (s/cat :e even? :o odd?)
+
+  Returns a regex op that matches (all) values in sequence, returning a map
+  containing the keys of each pred and the corresponding value."
+  [& key-pred-forms]
+  (let [&env (ctx/get-ctx)
+        pairs (partition 2 key-pred-forms)
+        keys (mapv first pairs)
+        pred-forms (mapv second pairs)
+        pf (mapv #(res &env %) pred-forms)]
+    ;;(prn key-pred-forms)
+    (clojure.core/assert (clojure.core/and (even? (count key-pred-forms)) (every? keyword? keys)) "cat expects k1 p1 k2 p2..., where ks are keywords")
+    `(s/cat-impl ~keys ~pred-forms '~pf)))
+
 (def namespaces {'cljs.spec.alpha {'def (sci/copy-var def* sns)
                                    'def-impl (sci/copy-var s/def-impl sns)
                                    'and (sci/copy-var and sns)
@@ -338,7 +355,9 @@
                                    'tuple (sci/copy-var tuple sns)
                                    'tuple-impl (sci/copy-var s/tuple-impl sns)
                                    'map-of (sci/copy-var map-of sns)
-                                   'every-kv (sci/copy-var every-kv sns)}
+                                   'every-kv (sci/copy-var every-kv sns)
+                                   'cat (sci/copy-var cat sns)
+                                   'cat-impl (sci/copy-var s/cat-impl sns)}
                  'cljs.spec.gen.alpha {'fmap (sci/copy-var gen/fmap gns)}})
 
 (def config {:namespaces namespaces})