WIP: delay/future/promise schemas

README.md

@@ -27,6 +27,7 @@ Data-driven Schemas for Clojure/Script and [babashka](#babashka).
 - [Multi-schemas](#multi-schemas), [Recursive Schemas](#recursive-schemas) and [Default values](#default-values)
 - [Function Schemas](docs/function-schemas.md) with dynamic and static schema checking
    - Integrates with both [clj-kondo](#clj-kondo) and [Typed Clojure](#static-type-checking-via-typed-clojure) 
+- [Delay, Future and Promise Schemas](#delay-future-and-promise-schemas)
 - Visualizing Schemas with [DOT](#dot) and [PlantUML](#plantuml)
 - Pretty [development time errors](#pretty-errors)
 - [Fast](#performance)
@@ -1985,6 +1986,51 @@ Any function can be used for `:dispatch`:
 ; :address {:country :finland}}
 ```
 
+## Delay, Future and Promise Schemas
+
+`:delay`, `:future`, and `:promise` schemas validate their respective concurrency
+types. They all share common behavior for validation. Since `deref` is prone
+to block the current thread, malli is careful to only validate `realized?` values.
+This can be overridden to always validate with `:force true`.
+
+```clojure
+;; Fails if not delay/future/promise.
+(m/validate [:delay :any] 42)   ; => false
+(m/validate [:future :any] 42)  ; => false
+(m/validate [:promise :any] 42) ; => false
+
+;; Unrealized values are not forced...
+(m/validate [:delay :int] (delay 42))     ; => true
+(m/validate [:delay :int] (delay "42"))   ; => true
+(m/validate [:future :int] (future 42))   ; => true
+(m/validate [:future :int] (future "42")) ; => true / false
+(m/validate [:promise :int] (promise))    ; => true
+
+;; ...unless `realized?` or `:force true`
+(m/validate [:delay :int] (doto (delay "42") deref))    ; => false
+(m/validate [:delay {:force true} :int] (delay "42"))   ; => false
+(m/validate [:future :int] (doto (future "42") deref))  ; => false
+(m/validate [:future {:force true} :int] (future "42")) ; => false
+(m/validate [:future {:force true} :int] (future @(promise))) ; Blocks forever!
+(m/validate [:promise {:force true} :int] (doto (promise) (deliver "42"))) ; => false
+(m/validate [:promise {:force true} :int] (promise))    ; Blocks forever!
+```
+
+Generators make a best-effort to return realizable values, however
+they may block indefinitely or throw exceptions when dereferenced
+depending on the child generator. `:promise` in particular will not receive
+a value if its child generator fails.
+
+Humanizers nest failures for the contained value under `:deref`.
+
+```clojure
+(me/humanize (m/explain [:delay :int] 42))
+; => ["should be a delay"]
+
+(me/humanize (m/explain [:delay {:force true} :int] (delay "42")))
+; => {:deref ["should be an integer"]}
+```
+
 ## Recursive schemas
 
 To create a recursive schema, introduce a [local registry](#local-registry) and wrap all recursive positions in the registry with `:ref`. Now you may reference the recursive schemas in the body of the schema.

src/malli/core.cljc

@@ -2718,6 +2718,101 @@
                                   :re-transformer (fn [_ children] (apply re/alt-transformer children))
                                   :re-min-max (fn [_ children] (reduce -re-alt-min-max {:max 0} (-vmap last children)))})})
 
+(defn -deref-schema [{:keys [type]}]
+  ^{:type ::into-schema}
+  (reify
+    AST
+    (-from-ast [parent ast options] (-from-child-ast parent ast options))
+    IntoSchema
+    (-type [_] type)
+    (-type-properties [_])
+    (-properties-schema [_ _])
+    (-children-schema [_ _])
+    (-into-schema [parent {:keys [force timeout] :as properties} children options]
+      (-check-children! type properties children 1 1)
+      (let [[schema :as children] (-vmap #(schema % options) children)
+            timeout-ms (if (number? timeout) timeout 100)
+            form (delay (-simple-form parent properties children -form options))
+            sentinel form
+            [deref? deref-with-timeout? pending?]
+            #?(:clj [#(instance? clojure.lang.IDeref %)
+                     #?(;; IBlockingDeref not supported by babashka
+                        :bb (let [c (class (promise))]
+                              #(or (future? %) (instance? c %)))
+                        :default #(instance? clojure.lang.IBlockingDeref %))
+                     #(instance? clojure.lang.IPending %)]
+               :cljs [#(satisfies? cljs.core.IDeref %)
+                      #(satisfies? cljs.core.IDerefWithTimeout %)
+                      #(satisfies? cljs.core.IPending %)]
+               :default (-fail! ::deref-not-supported))
+            pred (case type
+                   :deref (miu/-every-pred
+                            (cond-> [deref?]
+                              timeout (conj deref-with-timeout?)))
+                   :delay (do (when timeout
+                                (-fail! ::delay-does-not-support-timeout))
+                              delay?)
+                   #?@(:clj [:future future?
+                             :promise #(and (deref? %)
+                                            (deref-with-timeout? %)
+                                            (ifn? %)
+                                            (pending? %))]))
+            force? (if force
+                     any?
+                     (case type
+                       :deref #(if (pending? %)
+                                 (realized? %)
+                                 true)
+                       realized?))
+            try-deref (if force
+                        #(c/deref %)
+                        #(if (deref-with-timeout? %)
+                           (c/deref % timeout-ms sentinel)
+                           (if (force? %) @% sentinel)))
+            cache (-create-cache options)]
+        ^{:type ::schema}
+        (reify
+          AST
+          (-to-ast [this _] (-to-child-ast this))
+          Schema
+          (-validator [_]
+            (let [validator (-validator schema)]
+              (fn [d]
+                (if (pred d)
+                  (let [r (try-deref d)]
+                    (if (identical? r sentinel)
+                      true
+                      (validator r)))
+                  false))))
+          (-explainer [this path]
+            (let [explainer (-explainer schema (conj path 0))]
+              (fn [x in acc]
+                (if-not (pred x)
+                  (conj acc (miu/-error path in this x))
+                  (let [r (try-deref x)]
+                    (cond->> acc
+                      (not (identical? r sentinel)) (explainer r (conj in :deref))))))))
+          (-parser [this]
+            (let [validator (-validator this)]
+              (fn [x] (if (validator x) x ::invalid))))
+          (-unparser [this] (-parser this))
+          (-transformer [this transformer method options]
+            (-intercepting (-value-transformer transformer this method options)))
+          (-walk [this walker path options]
+            (when (-accept walker this path options)
+              (-outer walker this path [(-inner walker schema (conj path ::in) options)] options)))
+          (-properties [_] properties)
+          (-options [_] options)
+          (-children [_] children)
+          (-parent [_] parent)
+          (-form [_] @form)
+          Cached
+          (-cache [_] cache)
+          LensSchema
+          (-keep [_] true)
+          (-get [_ _ _] schema)
+          (-set [this _ value] (-set-children this [value])))))))
+
 (defn base-schemas []
   {:and (-and-schema)
    :or (-or-schema)
@@ -2741,6 +2836,10 @@
    :-> (-->-schema nil)
    :function (-function-schema nil)
    :schema (-schema-schema nil)
+   :deref (-deref-schema {:type :deref})
+   :delay (-deref-schema {:type :delay})
+   #?(:clj :future) #?(:clj (-deref-schema {:type :future}))
+   #?(:clj :promise) #?(:clj (-deref-schema {:type :promise}))
    ::schema (-schema-schema {:raw true})})
 
 (defn default-schemas []

src/malli/error.cljc

@@ -142,6 +142,9 @@
    :qualified-keyword {:error/message {:en "should be a qualified keyword"}}
    :qualified-symbol {:error/message {:en "should be a qualified symbol"}}
    :uuid {:error/message {:en "should be a uuid"}}
+   :delay {:error/message {:en "should be a delay"}}
+   #?(:clj :future) #?(:clj {:error/message {:en "should be a future"}})
+   #?(:clj :promise) #?(:clj {:error/message {:en "should be a promise"}})
    :> {:error/fn {:en (fn [{:keys [schema value negated] :as error} options]
                         (if negated
                           (-forward-negation [:<= (first (m/children schema))] error options)

src/malli/generator.cljc

@@ -314,6 +314,38 @@
 (defn -function-gen [schema options]
   (gen/return (m/-instrument {:schema schema, :gen #(generate % options)} nil options)))
 
+(defn -deref-gen [schema options]
+  (gen/return (let [d (#?(:clj future :default delay) (generate (-child-gen schema options) options))]
+                #?(:clj (reify
+                          clojure.lang.IPending
+                          (isRealized [_] (realized? d))
+                          clojure.lang.IDeref
+                          (deref [_] (deref d))
+                          #?@(:bb []
+                              :default [clojure.lang.IBlockingDeref
+                                        (deref [_ timeout timeout-val] (deref d timeout timeout-val))]))
+                   :cljs (reify
+                           cljs.core.IPending
+                           (-realized? [_] (realized? d))
+                           cljs.core.IDeref
+                           (-deref [_] (deref d))
+                           clojure.lang.IDerefWithTimeout
+                           (-deref-with-timeout [_ _ _] (deref d))) ;;TODO timeout
+                   :default (m/-fail! ::deref-not-supported)))))
+
+(defn -delay-gen [schema options]
+  (gen/return (delay (generate (-child-gen schema options) options))))
+
+#?(:clj
+   (defn -future-gen [schema options]
+     (gen/return (future (generate (-child-gen schema options) options)))))
+
+#?(:clj
+   (defn -promise-gen [schema options]
+     (let [p (promise)]
+       (future (deliver p (generate (-child-gen schema options) options)))
+       (gen/return p))))
+
 (defn -regex-generator [schema options]
   (cond-> (generator schema options) (not (m/-regex-op? schema)) (-> vector gen-tuple)))
 
@@ -415,6 +447,10 @@
 (defmethod -schema-generator :=> [schema options] (-=>-gen schema options))
 (defmethod -schema-generator :-> [schema options] (-=>-gen schema options))
 (defmethod -schema-generator :function [schema options] (-function-gen schema options))
+(defmethod -schema-generator :deref [schema options] (-deref-gen schema options))
+(defmethod -schema-generator :delay [schema options] (-delay-gen schema options))
+#?(:clj (defmethod -schema-generator :future [schema options] (-future-gen schema options)))
+#?(:clj (defmethod -schema-generator :promise [schema options] (-promise-gen schema options)))
 (defmethod -schema-generator 'ifn? [_ _] gen/keyword)
 (defmethod -schema-generator :ref [schema options] (-ref-gen schema options))
 (defmethod -schema-generator :schema [schema options] (generator (m/deref schema) options))

test/malli/core_test.cljc

@@ -3581,3 +3581,93 @@
   (is (not (m/validate [:sequential {:min 11} :int] (eduction identity (range 10)))))
   (is (not (m/validate [:seqable {:min 11} :int] (eduction identity (range 10)))))
   (is (nil? (m/explain [:sequential {:min 9} :int] (eduction identity (range 10))))))
+
+(deftest deref-test
+  (testing "schema matches delay"
+    (is (m/validate [:deref :int] (delay 1)))
+    (is (m/validate [:deref :int] (doto (delay 1) deref)))
+    (is (m/validate [:deref {:force true} :int] (delay 1)))
+    (is (m/validate [:deref {:force true} :int] (doto (delay 1) deref)))
+    (is (nil? (m/explain [:deref :int] (delay 1))))
+    (is (nil? (m/explain [:deref :int] (doto (delay 1) deref))))
+    (is (nil? (m/explain [:deref {:force true} :int] (delay 1)))))
+  (testing "schema does not match delay"
+    (is (m/validate [:deref :boolean] (delay 1)))
+    (is (not (m/validate [:deref :boolean] (doto (delay 1) deref))))
+    (is (not (m/validate [:deref {:force true} :boolean] (delay 1))))
+    (is (not (m/validate [:deref {:force true} :boolean] (doto (delay 1) deref))))
+    (is (not (m/validate [:deref :boolean] 1)))
+    (is (nil? (m/explain [:deref :boolean] (delay 1))))
+    (is (m/explain [:deref :boolean] (doto (delay 1) deref)))
+    (is (m/explain [:deref {:force true} :boolean] (delay 1)))
+    (is (m/explain [:deref {:force true} :boolean] (doto (delay 1) deref)))
+    (is (m/explain [:deref :boolean] 1))))
+
+(deftest delay-test
+  (testing "schema matches delay"
+    (is (m/validate [:delay :int] (delay 1)))
+    (is (m/validate [:delay :int] (doto (delay 1) deref)))
+    (is (m/validate [:delay {:force true} :int] (delay 1)))
+    (is (m/validate [:delay {:force true} :int] (doto (delay 1) deref)))
+    (is (nil? (m/explain [:delay :int] (delay 1))))
+    (is (nil? (m/explain [:delay :int] (doto (delay 1) deref))))
+    (is (nil? (m/explain [:delay {:force true} :int] (delay 1)))))
+  (testing "schema does not match delay"
+    (is (m/validate [:delay :boolean] (delay 1)))
+    (is (not (m/validate [:delay :boolean] (doto (delay 1) deref))))
+    (is (not (m/validate [:delay {:force true} :boolean] (delay 1))))
+    (is (not (m/validate [:delay {:force true} :boolean] (doto (delay 1) deref))))
+    (is (not (m/validate [:delay :boolean] 1)))
+    (is (nil? (m/explain [:delay :boolean] (delay 1))))
+    (is (m/explain [:delay :boolean] (doto (delay 1) deref)))
+    (is (m/explain [:delay {:force true} :boolean] (delay 1)))
+    (is (m/explain [:delay {:force true} :boolean] (doto (delay 1) deref)))
+    (is (m/explain [:delay :boolean] 1))))
+
+#?(:clj
+   (deftest future-test
+     (testing "schema matches future"
+       (is (m/validate [:future :int] (future 1)))
+       (is (m/validate [:future :int] (doto (future 1) deref)))
+       (is (m/validate [:future {:force true} :int] (future 1)))
+       (is (m/validate [:future {:force true} :int] (doto (future 1) deref)))
+       (is (nil? (m/explain [:future :int] (future 1))))
+       (is (nil? (m/explain [:future :int] (doto (future 1) deref))))
+       (is (nil? (m/explain [:future {:force true} :int] (future 1)))))
+     (testing "schema does not match future"
+       (let [p (promise)
+             f (future @p 1)]
+         (is (m/validate [:future :boolean] f))
+         (is (nil? (m/explain [:future :boolean] f)))
+         (deliver p true))
+       (is (not (m/validate [:future :boolean] (doto (future 1) deref))))
+       (is (not (m/validate [:future {:force true} :boolean] (future 1))))
+       (is (not (m/validate [:future {:force true} :boolean] (doto (future 1) deref))))
+       (is (not (m/validate [:future :boolean] 1)))
+       (is (m/explain [:future :boolean] (doto (future 1) deref)))
+       (is (m/explain [:future {:force true} :boolean] (future 1)))
+       (is (m/explain [:future {:force true} :boolean] (doto (future 1) deref)))
+       (is (m/explain [:future :boolean] 1)))))
+
+#?(:clj
+   (deftest promise-test
+     (testing "schema matches promise"
+       (is (m/validate [:promise :int] (doto (promise) (deliver 1))))
+       (is (m/validate [:promise {:force true} :int] (doto (promise) (deliver 1))))
+       (is (m/validate [:promise {:force true} :int] (doto (promise) (deliver 1))))
+       (is (nil? (m/explain [:promise :int] (doto (promise) (deliver 1)))))
+       (is (nil? (m/explain [:promise :int] (doto (promise) (deliver 1)))))
+       (is (nil? (m/explain [:promise {:force true} :int] (doto (promise) (deliver 1))))))
+     (testing "schema does not match promise"
+       (is (m/validate [:promise :boolean] (promise)))
+       (is (not (m/validate [:promise :boolean] (doto (promise) (deliver 1)))))
+       (is (not (m/validate [:promise {:force true} :boolean] (doto (promise) (deliver 1)))))
+       (is (not (m/validate [:promise {:force true} :boolean] (doto (promise) (deliver 1)))))
+       (is (not (m/validate [:promise :boolean] 1)))
+       (is (not (m/validate [:promise :boolean] (future))))
+       (is (not (m/validate [:promise :boolean] (delay))))
+       (is (nil? (m/explain [:promise :boolean] (promise))))
+       (is (m/explain [:promise :boolean] (doto (promise) (deliver 1))))
+       (is (m/explain [:promise {:force true} :boolean] (doto (promise) (deliver 1))))
+       (is (m/explain [:promise {:force true} :boolean] (doto (promise) (deliver 1))))
+       (is (m/explain [:promise :boolean] 1)))))

test/malli/error_test.cljc

@@ -943,3 +943,16 @@
                                                                   (negated "should not avoid being a multiple of 3")
                                                                   "should not be a multiple of 3"))}}
                                           #(not= 0 (mod % 3))]] 1))))))
+
+(deftest humanize-delay-future-promise-test
+  (is (= ["should be a delay"] (me/humanize (m/explain [:delay :int] 42))))
+  (is (= ["should not be a delay"] (me/humanize (m/explain [:not [:delay :int]] (delay 42)))))
+  #?(:clj (is (= ["should be a promise"] (me/humanize (m/explain [:promise :int] 42)))))
+  #?(:clj (is (= ["should be a future"] (me/humanize (m/explain [:future :int] 42)))))
+  (is (= {:deref ["should be an integer"]} (me/humanize (m/explain [:delay {:force true} :int] (delay "42")))))
+  (is (= {:deref ["should not be an integer"]} (me/humanize (m/explain [:delay {:force true} [:not :int]] (delay 42)))))
+  #?(:clj (is (= {:deref ["should be an integer"]} (me/humanize (m/explain [:future {:force true} :int] (future "42"))))))
+  #?(:clj (is (= {:deref ["should be an integer"]} (me/humanize (m/explain [:promise {:force true} :int] (doto (promise) (deliver "42")))))))
+  (is (= [{:a {:deref ["should be an integer"]}}]
+         (me/humanize (m/explain [:vector [:map [:a [:delay {:force true} :int]]]]
+                                 [{:a (delay "42")}])))))