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,31 @@
   #?(: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#))))
 
 (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
-  ([input-flow] (enforce {} input-flow))
-  ([{nm :name, f :transfer, :as o} input-flow]
+  ([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)
+                  (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]
@@ -34,7 +35,7 @@
                             (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) [_]
                   (let [should-step (first (swap-vals! !should-step? not))
                         [t v] (try [:ok @cancel] (catch #?(:clj Throwable :cljs :default) e [:ex e]))]

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)))))))))