keys

src/sci/configs/cljs/spec/alpha.cljs

@@ -1,5 +1,5 @@
 (ns sci.configs.cljs.spec.alpha
-  (:refer-clojure :exclude [and or])
+  (:refer-clojure :exclude [and or keys])
   (:require [clojure.spec.alpha :as s]
             [sci.core :as sci]
             [sci.ctx-store :as ctx]
@@ -96,6 +96,69 @@
         pf (res &env pred)]
     `(s/nilable-impl '~pf ~pred nil)))
 
+(macros/defmacro keys
+  "Creates and returns a map validating spec. :req and :opt are both
+  vectors of namespaced-qualified keywords. The validator will ensure
+  the :req keys are present. The :opt keys serve as documentation and
+  may be used by the generator.
+
+  The :req key vector supports 'and' and 'or' for key groups:
+
+  (s/keys :req [::x ::y (or ::secret (and ::user ::pwd))] :opt [::z])
+
+  There are also -un versions of :req and :opt. These allow
+  you to connect unqualified keys to specs.  In each case, fully
+  qualfied keywords are passed, which name the specs, but unqualified
+  keys (with the same name component) are expected and checked at
+  conform-time, and generated during gen:
+
+  (s/keys :req-un [:my.ns/x :my.ns/y])
+
+  The above says keys :x and :y are required, and will be validated
+  and generated by specs (if they exist) named :my.ns/x :my.ns/y
+  respectively.
+
+  In addition, the values of *all* namespace-qualified keys will be validated
+  (and possibly destructured) by any registered specs. Note: there is
+  no support for inline value specification, by design.
+
+  Optionally takes :gen generator-fn, which must be a fn of no args that
+  returns a test.check generator."
+  [& {:keys [req req-un opt opt-un gen]}]
+  (let [&env (ctx/get-ctx)
+        unk #(-> % name keyword)
+        req-keys (filterv keyword? (flatten req))
+        req-un-specs (filterv keyword? (flatten req-un))
+        _ (clojure.core/assert (every? #(clojure.core/and (keyword? %) (namespace %)) (concat req-keys req-un-specs opt opt-un))
+                  "all keys must be namespace-qualified keywords")
+        req-specs (into req-keys req-un-specs)
+        req-keys (into req-keys (map unk req-un-specs))
+        opt-keys (into (vec opt) (map unk opt-un))
+        opt-specs (into (vec opt) opt-un)
+        gx (gensym)
+        parse-req (fn [rk f]
+                    (map (fn [x]
+                           (if (keyword? x)
+                             `(contains? ~gx ~(f x))
+                             (walk/postwalk
+                               (fn [y] (if (keyword? y) `(contains? ~gx ~(f y)) y))
+                               x)))
+                         rk))
+        pred-exprs [`(map? ~gx)]
+        pred-exprs (into pred-exprs (parse-req req identity))
+        pred-exprs (into pred-exprs (parse-req req-un unk))
+        keys-pred `(fn* [~gx] (cljs.core/and ~@pred-exprs))
+        pred-exprs (mapv (fn [e] `(fn* [~gx] ~e)) pred-exprs)
+        pred-forms (walk/postwalk #(res &env %) pred-exprs)]
+    ;; `(map-spec-impl ~req-keys '~req ~opt '~pred-forms ~pred-exprs ~gen)
+    `(s/map-spec-impl {:req '~req :opt '~opt :req-un '~req-un :opt-un '~opt-un
+                       :req-keys '~req-keys :req-specs '~req-specs
+                       :opt-keys '~opt-keys :opt-specs '~opt-specs
+                       :pred-forms '~pred-forms
+                       :pred-exprs ~pred-exprs
+                       :keys-pred ~keys-pred
+                       :gfn ~gen})))
+
 (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)
@@ -106,6 +169,9 @@
                                    'conform (sci/copy-var s/conform sns)
                                    'nilable (sci/copy-var nilable sns)
                                    'nilable-impl (sci/copy-var s/nilable-impl sns)
-                                   'explain (sci/copy-var s/explain sns)}})
+                                   'explain (sci/copy-var s/explain sns)
+                                   'explain-data (sci/copy-var s/explain-data sns)
+                                   'keys (sci/copy-var keys sns)
+                                   'map-spec-impl (sci/copy-var s/map-spec-impl sns)}})
 
 (def config {:namespaces namespaces})