diff --git a/src/contrib/debug.cljc b/src/contrib/debug.cljc index ebe6487e1..9067c9b93 100644 --- a/src/contrib/debug.cljc +++ b/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] diff --git a/src/hyperfiddle/incseq/flow_protocol_enforcer.cljc b/src/hyperfiddle/incseq/flow_protocol_enforcer.cljc index fc4db3758..c0b1b69fd 100644 --- a/src/hyperfiddle/incseq/flow_protocol_enforcer.cljc +++ b/src/hyperfiddle/incseq/flow_protocol_enforcer.cljc @@ -2,14 +2,15 @@ #?(: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)) @@ -17,15 +18,15 @@ (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]))] diff --git a/test/hyperfiddle/detest.cljc b/test/hyperfiddle/detest.cljc new file mode 100644 index 000000000..f970973e6 --- /dev/null +++ b/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 [ (->box seed) + step (fn [] (let [^Long v () + ^Long v (.xor v (.shiftLeft v 7))] + ( (.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)))))))))