deterministic testing of protocol violations

src/contrib/debug.cljc

@@ -52,16 +52,11 @@
            it (flow #(do (dbgf [nm id 'notified]) (n)) #(do (dbgf [nm id 'terminated]) (t)))]
        (reify
          IFn (#?(:clj invoke :cljs -invoke) [_] (dbgf [nm id 'cancelled]) (it))
+         (#?(:clj invoke :cljs -invoke) [_ _] it)
          IDeref (#?(:clj deref :cljs -deref) [_]
-                  (let [v (try @it (catch #?(:clj Throwable :cljs :default) e [::ex e]))]
-                    (dbgf [nm id 'transferred
-                           (if false #_(instance? Failure v) ; FIXME Update to electric v3
-                               (let [e (.-error v)]
-                                 [(type e) (ex-message e)])
-                               v)])
-                    (if (and (vector? v) (= ::ex (first v)))
-                      (throw (second v))
-                      v))))))))
+                  (let [[t v] (try [::ok @it] (catch #?(:clj Throwable :cljs :default) e [::ex e]))]
+                    (dbgf [nm id 'transferred (if (= ::ex t) [(type v) (ex-message v)] v)])
+                    (if (= ::ex t) (throw v) v))))))))
 (defmacro instrument [nm v] `(hyperfiddle.electric3/input (instrument* ~nm (hyperfiddle.electric3/pure ~v))))
 
 (defmacro js-measure [nm & body]

src/hyperfiddle/incseq/flow_protocol_enforcer.cljc

@@ -2,30 +2,47 @@
   #?(:clj (:import [clojure.lang IDeref IFn]))
   #?(:cljs (:require-macros [hyperfiddle.incseq.flow-protocol-enforcer :refer [cannot-throw]])))
 
-(defn violated
+(defn %violated
   ([nm msg] (println nm "flow protocol violation:" msg) #?(:cljs (.error js/console) :clj (prn (Throwable.))))
   ([nm msg e]
    (println nm "flow protocol violation:" msg)
    (#?(:clj prn :cljs js/console.error) e)))
 
-(defmacro cannot-throw [nm f] `(try (~f) (catch ~(if (:js-globals &env) :default 'Throwable) e#
-                                        (violated ~nm ~(str f " cannot throw") e#))))
+(defmacro cannot-throw [f nm violated]
+  `(try (~f) (catch ~(if (:js-globals &env) :default 'Throwable) e#
+               (~violated ~nm ~(str f " cannot throw") e#))))
 
-(defn flow
-  ([input-flow] (flow "" input-flow))
-  ([nm input-flow]
+(def diff? (every-pred :grow :degree :shrink :change :permutation :freeze))
+
+(defn is-array? [v] #?(:clj (-> v class .isArray) :cljs (array? v)))
+(defn pretty [v] (cond-> v (is-array? v) vec))
+
+(defn enforce
+  ([flow] (enforce {} flow))
+  ([{nm :name, f :transfer, violated :on-violate :as o :or {violated %violated}} flow]
    (fn [step done]
      (let [!should-step? (atom ::init), !done? (atom false)
            step (fn []
                   (when @!done? (violated nm "step after done"))
-                  (if (first (swap-vals! !should-step? not)) (cannot-throw nm step) (violated nm "double step")))
-           done (fn [] (if (first (reset-vals! !done? true)) (violated nm "done called twice") (cannot-throw nm done)))
-           cancel (try (input-flow step done)
-                       (catch #?(:clj Throwable :cljs :default) e (violated nm "flow process creation threw" e)))]
-       (when (= ::init @!should-step?) (violated nm "missing initial step"))
+                  (if (first (swap-vals! !should-step? not)) (cannot-throw step nm violated) (violated nm "double step")))
+           done (fn [] (if (first (reset-vals! !done? true)) (violated nm "done called twice") (cannot-throw done nm violated)))
+           cancel (try (flow step done)
+                       (catch #?(:clj Throwable :cljs :default) e (violated nm "flow process creation threw" e)))
+           check-transfer (if f
+                            (fn [t v]
+                              (when (and (= :ok t) (not (f v)))
+                                (violated nm (str "transferred value doesn't satisfy " f ": " (pretty v)))))
+                            (fn [_ _]))]
+       (when (and (:initialized o) (= ::init @!should-step?)) (violated nm "missing initial step"))
        (reify
-         IFn (#?(:clj invoke :cljs -invoke) [_] (cannot-throw nm cancel))
+         IFn (#?(:clj invoke :cljs -invoke) [_] (cannot-throw cancel nm violated))
          IDeref (#?(:clj deref :cljs -deref) [_]
-                  (if-let [should-step (first (swap-vals! !should-step? not))]
-                    (violated nm (if (= ::init should-step) "transfer without initial step" "double transfer"))
-                    @cancel)))))))
+                  (let [should-step (first (swap-vals! !should-step? not))
+                        [t v] (try [:ok @cancel] (catch #?(:clj Throwable :cljs :default) e [:ex e]))]
+                    (check-transfer t v)
+                    (when should-step (violated nm "transfer without step" (when (= :ex t) v)))
+                    (if (= :ex t) (throw v) v))))))))
+
+(defn incseq [nm flow] (enforce {:name nm, :initialized true, :transfer #'diff?} flow))
+(defn initialized [nm flow] (enforce {:name nm, :initialized true} flow))
+(defn uninitialized [nm flow] (enforce {:name nm} flow))

src/hyperfiddle/incseq/items_eager_impl.cljc

@@ -137,6 +137,8 @@
                    (run! (fn [item-ps] (item-ps v)) @(a/fget item -ps*))))
       nil (:change diff))))
 
+(defn ?add-freeze [diff] (if (:freeze diff) diff (assoc diff :freeze #{})))
+
 (defn needed-diff? [d]
   (or (seq (:permutation d)) (pos? (:grow d)) (pos? (:shrink d)) (seq (:freeze d))))
 
@@ -147,8 +149,9 @@
             (let [?in-diff (try @(a/fget ps -input-ps) (catch #?(:clj Throwable :cljs :default) e e))]
               (if (map? ?in-diff)
                 (do (grow! ps ?in-diff) (permute! ps ?in-diff) (shrink! ps ?in-diff) (change! ps ?in-diff)
-                    (let [newdiff (a/fset ps -diff (cond->> (assoc ?in-diff :change (:change (a/fget ps -diff)))
-                                                     diff (d/combine diff)))]
+                    (let [newdiff (a/fset ps -diff (?add-freeze
+                                                     (cond->> (assoc ?in-diff :change (:change (a/fget ps -diff)))
+                                                       diff (d/combine diff))))]
                       (if (= 1 (going ps))
                         (case (a/fget ps -stepped)
                           false (when (needed-diff? newdiff) (a/fset ps -stepped true))

test/hyperfiddle/detest.cljc

@@ -0,0 +1,86 @@
+(ns hyperfiddle.detest
+  (:import #?(:clj [clojure.lang IFn IDeref])
+           #?(:clj [clojure.lang ExceptionInfo])
+           #?(:cljs [goog.math Long])
+           [missionary Cancelled])
+  (:require [hyperfiddle.incseq.flow-protocol-enforcer :as fpe]
+            #?(:cljs [contrib.data :refer [->box]])
+            [contrib.debug :as dbg]
+            [clojure.string :as str]))
+
+;; DETErministic TESTing, so naturally, DETEST
+
+#?(:clj
+   (defn ->xorshift64 [seed]
+     (let [!v (atom seed)]
+       (fn step
+         ([] (swap! !v (fn [v]
+                         (let [v (bit-xor v (bit-shift-left v 7))]
+                           (bit-xor v (unsigned-bit-shift-right v 9))))))
+         ([n] (if (zero? n) n (mod (step) n)))))))
+
+#?(:clj (defn random-seed [] (-> java.security.SecureRandom new .nextLong)))
+
+#?(:cljs
+   (defn ->xorshift64 [seed]
+     (let [<v> (->box seed)
+           step (fn [] (let [^Long v (<v>)
+                             ^Long v (.xor v (.shiftLeft v 7))]
+                         (<v> (.xor v (.shiftRightUnsigned v 9)))))]
+       (fn self
+         ([] (let [^Long v (step)] (.toNumber v)))
+         ([n] (if (zero? n) n (let [^Long v (step)] (mod (.toNumber v) n))))))))
+
+#?(:cljs (defn random-seed [] (Long/fromBits (rand-int 0x100000000) (rand-int 0x100000000))))
+
+(defprotocol Engine
+  (exercise [this opts flow])
+  (roll [this] [this nm])
+  (add-proc [this proc])
+  (del-proc [this proc]))
+
+(defn instrument [nm flow]
+  (fn [step done]
+    (let [it ((dbg/instrument* nm flow) step done)]
+      (reify
+        IFn
+        (#?(:clj invoke :cljs -invoke) [_] (it))
+        (#?(:clj invoke :cljs -invoke) [_ n] ((it :process) n))
+        IDeref
+        (#?(:clj deref :cljs -deref) [_] @it)))))
+
+(defn on-violate
+  ([nm msg] (on-violate nm msg nil))
+  ([nm msg e] (throw (ex-info (str nm " flow protocol violation: " msg) {} e))))
+
+(defn ->engine
+  ([] (->engine {}))
+  ([{:keys [seed]}]
+   (let [seed (or seed (random-seed)), rng (->xorshift64 seed), !proc* (atom [])]
+     (reify Engine
+       (add-proc [_ proc] (swap! !proc* conj proc))
+       (del-proc [_ proc] (swap! !proc* (fn [proc*] (filterv #(not= % proc) proc*))))
+       (roll [_] (rng))
+       (roll [_ n] (rng n))
+       (exercise [this opts flow]
+         (try (let [flow (fpe/enforce {:name ::root, :on-violate on-violate} flow)
+                    !s (atom nil)
+                    root (flow #(reset! !s :step) #(reset! !s :done))]
+                (add-proc this root)
+                (while (not= :done @!s)
+                  (let [proc* @!proc*, n (rng (count proc*)), proc (nth proc* n)]
+                    (if (= proc root)
+                      (case @!s
+                        (:done nil) (when (> 1 (rng 100)) (root))
+                        (:step) (condp > (rng 100)
+                                  1 (root)
+                                  25 nil
+                                  #_else (try (reset! !s nil) @root
+                                              (catch Cancelled _)
+                                              (catch ExceptionInfo e
+                                                (when-not (str/starts-with? (ex-message e) "[DETEST OK] ")
+                                                  (throw e))))))
+                      (proc (rng)))))
+                (dotimes [_ 3] (root)))
+              (catch #?(:clj Throwable :cljs :default) e
+                (throw (ex-info (str "exercise failed with seed " seed) {:seed seed} e)))))))))

test/hyperfiddle/detest/incseq_test.cljc

@@ -0,0 +1,85 @@
+(ns hyperfiddle.detest.incseq-test
+  (:import #?(:clj [clojure.lang IFn IDeref])
+           [missionary Cancelled])
+  (:require [hyperfiddle.detest :as dt]
+            [hyperfiddle.incseq :as i]
+            [hyperfiddle.incseq.diff-impl :as d]
+            [hyperfiddle.incseq.perm-impl :as p]
+            [clojure.set :as set]
+            [contrib.debug :as dbg]
+            [clojure.test :as t]))
+
+(defn %next-diff [prev-degree ngn next-fn]
+  (let [grow (dt/roll ngn 10), degree (+ prev-degree grow)
+        shrink (dt/roll ngn degree)
+        ;; TODO if shrank ensure grown items are permuted so they stay
+        perm (p/rotation (dt/roll ngn degree) (dt/roll ngn degree))
+        inv (set/map-invert perm)
+        change (reduce (fn [m i] (assoc m (inv i i) (next-fn ngn))) {} (range prev-degree (+ prev-degree grow)))
+        change (reduce (fn [m i] (cond-> m (zero? (dt/roll ngn 2)) (assoc i (next-fn ngn))))
+                 change (range (- degree shrink)))]
+    {:grow grow :degree degree :shrink shrink :permutation perm :change change :freeze #{}}))
+
+(defn %rand-incseq [ngn next-incseq-fn]
+  (fn [step done]
+    (step)
+    (let [!should-step? (atom false), !v (atom (d/empty-diff 0)), !done? (atom false), !cancelled? (atom false)
+          fin #(when-not (first (reset-vals! !done? true)) (done))
+          proc
+          (reify
+            IFn
+            (#?(:clj invoke :cljs -invoke) [_]
+              (let [cancelled? (first (reset-vals! !cancelled? true))]
+                (when (and @!should-step? (not @!done?) (not cancelled?))
+                  (swap! !should-step? not) (step))))
+            (#?(:clj invoke :cljs -invoke) [this n]
+              (if @!done?
+                (dt/del-proc ngn this)
+                (if (> 1 (mod n 100))
+                  (when @!should-step? (fin))
+                  (when (and @!should-step? (not @!done?)) (swap! !should-step? not) (step)))))
+            IDeref
+            (#?(:clj deref :cljs -deref) [_]
+              (cond
+                @!done?
+                (throw (ex-info "transfer after done" {}))
+
+                @!cancelled?
+                (do (fin) (throw (Cancelled.)))
+
+                @!should-step?
+                (throw (ex-info "transfer without step" {}))
+
+                :else
+                (do (swap! !should-step? not)
+                    (if (> 1 (dt/roll ngn 100))
+                      (do (fin) (throw (ex-info "[DETEST OK] random incseq throw" {})))
+                      (do (condp > (dt/roll ngn 100)
+                            1 (fin)
+                            25 (do (swap! !should-step? not) (step))
+                            #_else nil)
+                          (swap! !v next-incseq-fn ngn)))))))]
+      (dt/add-proc ngn proc)
+      proc)))
+
+(defn next-diff [prev-diff ngn]
+  (%next-diff (- (:degree prev-diff) (:shrink prev-diff)) ngn dt/roll))
+
+(defn rand-incseq [ngn] (%rand-incseq ngn next-diff))
+
+(defn next-lc-diff [prev-diff ngn]
+  (%next-diff (- (:degree prev-diff) (:shrink prev-diff)) ngn rand-incseq))
+
+(defn rand-lc-incseq [ngn] (%rand-incseq ngn next-lc-diff))
+
+(t/deftest detest-latest-product
+  (dotimes [_ 100]
+    (let [ngn (dt/->engine)]
+      (t/is (nil?
+              (dt/exercise ngn {} (i/latest-product vector (rand-incseq ngn) (rand-incseq ngn))))))))
+
+(t/deftest detest-latest-concat
+  (dotimes [_ 500]
+    (let [ngn (dt/->engine)]
+      (t/is (nil?
+              (dt/exercise ngn {} (i/latest-concat (rand-lc-incseq ngn))))))))

test/hyperfiddle/incseq/items_eager_impl_test.cljc

@@ -30,12 +30,13 @@
   ([q] (spawn-ps q (->box (fn [_step _done] (q)))))
   ([q <transfer-fn>] (spawn-ps q <transfer-fn> (->box (fn [_step _done] (q :input-cancel)))))
   ([q <transfer-fn> <cancel-fn>]
-   ((fpe/flow "i/items" (items/flow (fn [step done]
-                            (q [step done])
-                            (step)
-                            (reify
-                              IFn (#?(:clj invoke :cljs -invoke) [_] ((<cancel-fn>) step done))
-                              IDeref (#?(:clj deref :cljs -deref) [_] ((<transfer-fn>) step done))))))
+   ((fpe/incseq "i/items"
+      (items/flow (fn [step done]
+                    (q [step done])
+                    (step)
+                    (reify
+                      IFn (#?(:clj invoke :cljs -invoke) [_] ((<cancel-fn>) step done))
+                      IDeref (#?(:clj deref :cljs -deref) [_] ((<transfer-fn>) step done))))))
     #(q :items-step) #(q :items-done))))
 
 (t/deftest spawn