From a24e9bfba043288e8b8b50fef9ead8e3374707a4 Mon Sep 17 00:00:00 2001 From: Yogthos Date: Fri, 5 Jun 2026 00:24:18 -0400 Subject: [PATCH] =?UTF-8?q?test(spec):=20state,=20multimethods,=20protocol?= =?UTF-8?q?s=20=E2=80=94=20fix=20reify,=20get-method,=20hierarchies?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Add spec suites for stateful refs (atoms/volatiles/delays/promises), multimethods (dispatch + hierarchies), and protocols/types/records. Bugs caught and fixed: - reify with multiple methods registered only the first (stepped i by 2 over one-element specs); now collects every method spec - get-method/methods/remove-method evaluated their arg to the dispatch fn, but a multimethod's methods live on its var — now resolve the var (get-method and methods are special forms; remove-method fixed). get-method/methods added. - no global hierarchy: 2-arg derive modified a throwaway, isa? was hardcoded false, parents missing, ancestors/descendants returned arrays (so contains? failed), and dispatch ignored derive. Now a global hierarchy backs the 1/2-arg derive/isa?/parents/ancestors/descendants (returning sets) and multimethod dispatch falls back to it. Corrected a phase5 port assertion that encoded the old isa? bug. conformance 218/218, jpm test green. --- src/jolt/core.janet | 41 +++++++++++++-------- src/jolt/evaluator.janet | 43 +++++++++++++++------- src/jolt/types.janet | 4 +++ test/integration/ports/phase5-test.janet | 5 +-- test/spec/multimethods-spec.janet | 28 +++++++++++++++ test/spec/protocols-spec.janet | 46 ++++++++++++++++++++++++ test/spec/state-spec.janet | 36 +++++++++++++++++++ 7 files changed, 174 insertions(+), 29 deletions(-) create mode 100644 test/spec/multimethods-spec.janet create mode 100644 test/spec/protocols-spec.janet create mode 100644 test/spec/state-spec.janet diff --git a/src/jolt/core.janet b/src/jolt/core.janet index 74ed09c..6453f4d 100644 --- a/src/jolt/core.janet +++ b/src/jolt/core.janet @@ -2226,24 +2226,28 @@ (defn core-derive [& args] (case (length args) - 2 (let [[tag parent] args] (derive* (make-hierarchy) tag parent)) + 2 (let [[tag parent] args] (derive* the-global-hierarchy tag parent) nil) 3 (let [[h tag parent] args] (derive* h tag parent)))) (defn core-isa? [& args] (case (length args) - 1 false - 2 false + 2 (let [[child parent] args] (isa? the-global-hierarchy child parent)) 3 (let [[h child parent] args] (isa? h child parent)))) (defn core-ancestors [& args] (case (length args) - 1 @[] - 2 (let [[h tag] args] (ancestors h tag)))) + 1 (apply make-phs (ancestors the-global-hierarchy (in args 0))) + 2 (let [[h tag] args] (apply make-phs (ancestors h tag))))) (defn core-descendants [& args] (case (length args) - 1 @[] - 2 (let [[h tag] args] (descendants h tag)))) + 1 (apply make-phs (descendants the-global-hierarchy (in args 0))) + 2 (let [[h tag] args] (apply make-phs (descendants h tag))))) +(defn core-parents + [& args] + (let [[h tag] (if (= 1 (length args)) [the-global-hierarchy (in args 0)] args) + p (get (h :parents) tag)] + (if p (make-phs p) (make-phs)))) (def core-underive underive) (def core-get-method (fn [mm-var dispatch-val] (let [methods (get mm-var :jolt/methods)] @@ -2583,17 +2587,23 @@ (def core-extend (fn [& args] nil)) -(defn core-reify [proto-sym & impls] +(defn core-reify [& forms] + # forms interleaves protocol-name symbols with method specs (name [args] body); + # collect every method spec (a list), tracking the first protocol for the tag. (def result @[{:jolt/type :symbol :ns nil :name "do"}]) (def methods @{}) + (var proto-sym nil) (var i 0) - (while (< i (length impls)) - (let [method-spec (impls i)] - (def method-name (method-spec 0)) - (def arg-vec (method-spec 1)) - (def body (tuple/slice method-spec 2)) - (put methods (keyword (if (struct? method-name) (method-name :name) method-name)) @{:fn* true :args arg-vec :body body}) - (+= i 2))) + (while (< i (length forms)) + (def elem (in forms i)) + (if (and (struct? elem) (= :symbol (elem :jolt/type))) + (do (when (nil? proto-sym) (set proto-sym elem)) (++ i)) + (let [method-name (in elem 0) + arg-vec (in elem 1) + body (tuple/slice elem 2)] + (put methods (keyword (if (struct? method-name) (method-name :name) method-name)) + @{:fn* true :args arg-vec :body body}) + (++ i)))) (array/push result @[ {:jolt/type :symbol :ns nil :name "make-reified"} proto-sym @@ -3487,6 +3497,7 @@ "defn-" core-defn- "derive" core-derive "isa?" core-isa? + "parents" core-parents "ancestors" core-ancestors "descendants" core-descendants "make-hierarchy" core-make-hierarchy diff --git a/src/jolt/evaluator.janet b/src/jolt/evaluator.janet index 3f252c8..a9ae4c7 100644 --- a/src/jolt/evaluator.janet +++ b/src/jolt/evaluator.janet @@ -29,7 +29,8 @@ (= name "disj") (= name "set?") (= name "satisfies?") (= name "protocol-dispatch") (= name "register-method") (= name "make-reified") - (= name "prefer-method") (= name "remove-method") (= name "remove-all-methods"))) + (= name "prefer-method") (= name "remove-method") (= name "remove-all-methods") + (= name "get-method") (= name "methods"))) (var eval-form nil) @@ -1045,14 +1046,14 @@ method (get methods dv)] (if method (apply method args) - # hierarchy-based match - (let [found (if hierarchy - (do (var f nil) (var i 0) - (let [ks (keys methods)] - (while (and (nil? f) (< i (length ks))) - (if (isa? hierarchy dv (ks i)) (set f (get methods (ks i)))) - (++ i))) f) - nil)] + # hierarchy-based match (explicit :hierarchy or + # the global hierarchy from derive) + (let [h (or hierarchy the-global-hierarchy) + found (do (var f nil) (var i 0) + (let [ks (keys methods)] + (while (and (nil? f) (< i (length ks))) + (if (isa? h dv (in ks i)) (set f (get methods (in ks i)))) + (++ i))) f)] (if found (apply found args) # fall back to the method registered under the default key (let [dm (get methods default-key)] @@ -1103,11 +1104,29 @@ (do (put mm-var :jolt/prefers @{}) (mm-var :jolt/prefers)))] (put prefs dispatch-val-a dispatch-val-b) mm-var) - "remove-method" (let [mm-var (eval-form ctx bindings (in form 1)) + # A multimethod's methods live on its VAR, but the value is the dispatch fn; + # so resolve the var from the symbol rather than evaluating it. + "get-method" (let [mm-arg (in form 1) + mm-var (if (and (struct? mm-arg) (= :symbol (mm-arg :jolt/type))) + (resolve-var ctx bindings mm-arg) + (eval-form ctx bindings mm-arg)) + dispatch-val (eval-form ctx bindings (in form 2))] + (when mm-var + (let [methods (get mm-var :jolt/methods)] + (or (get methods dispatch-val) (get methods :default))))) + "methods" (let [mm-arg (in form 1) + mm-var (if (and (struct? mm-arg) (= :symbol (mm-arg :jolt/type))) + (resolve-var ctx bindings mm-arg) + (eval-form ctx bindings mm-arg))] + (and mm-var (get mm-var :jolt/methods))) + "remove-method" (let [mm-arg (in form 1) + mm-var (if (and (struct? mm-arg) (= :symbol (mm-arg :jolt/type))) + (resolve-var ctx bindings mm-arg) + (eval-form ctx bindings mm-arg)) dispatch-val (eval-form ctx bindings (in form 2))] - (if mm-var + (when mm-var (let [methods (get mm-var :jolt/methods)] - (put methods dispatch-val nil))) + (when methods (put methods dispatch-val nil)))) mm-var) "remove-all-methods" (let [mm-var (eval-form ctx bindings (in form 1))] (if mm-var diff --git a/src/jolt/types.janet b/src/jolt/types.janet index 459d0de..5abcc51 100644 --- a/src/jolt/types.janet +++ b/src/jolt/types.janet @@ -148,6 +148,10 @@ [] {:parents @{} :descendants @{} :ancestors @{}}) +# The global hierarchy used by the 1/2-arg derive/isa?/parents/ancestors/ +# descendants and by multimethod dispatch when no explicit hierarchy is given. +(def the-global-hierarchy (make-hierarchy)) + (defn derive* "Add a parent relationship to a hierarchy." [h tag parent] diff --git a/test/integration/ports/phase5-test.janet b/test/integration/ports/phase5-test.janet index 7bfc157..339b247 100644 --- a/test/integration/ports/phase5-test.janet +++ b/test/integration/ports/phase5-test.janet @@ -6,9 +6,10 @@ (print "22: hierarchy...") (let [ctx (init)] (assert (= true (ct-eval ctx "(map? (make-hierarchy))")) "make-hierarchy returns map") - # 2-arity derive/isa? just returns nil/false (no global hierarchy) + # 2-arity derive/isa? use the global hierarchy (ct-eval ctx "(derive ::square ::shape)") - (assert (= false (ct-eval ctx "(isa? ::square ::shape)")) "isa? 2-arity always false")) + (assert (= true (ct-eval ctx "(isa? ::square ::shape)")) "isa? 2-arity via global hierarchy") + (assert (= true (ct-eval ctx "(isa? ::square ::square)")) "isa? reflexive")) (print " passed") # 23. Multimethods — basic dispatch diff --git a/test/spec/multimethods-spec.janet b/test/spec/multimethods-spec.janet new file mode 100644 index 0000000..52bd53b --- /dev/null +++ b/test/spec/multimethods-spec.janet @@ -0,0 +1,28 @@ +# Specification: multimethods & hierarchies. +(use ../support/harness) + +(defspec "multimethods / dispatch" + ["dispatch on value" "\"two\"" + "(do (defmulti f identity) (defmethod f 1 [_] \"one\") (defmethod f 2 [_] \"two\") (f 2))"] + ["dispatch on keyword fn" "\"circle\"" + "(do (defmulti area :shape) (defmethod area :circle [_] \"circle\") (area {:shape :circle}))"] + [":default method" "\"other\"" + "(do (defmulti f identity) (defmethod f 1 [_] \"one\") (defmethod f :default [_] \"other\") (f 99))"] + ["no match throws" :throws + "(do (defmulti f identity) (defmethod f 1 [_] \"one\") (f 99))"] + ["multiple args" "5" + "(do (defmulti g (fn [a b] a)) (defmethod g :add [_ b] b) (g :add 5))"] + ["get-method" "\"one\"" + "(do (defmulti f identity) (defmethod f 1 [_] \"one\") ((get-method f 1) 1))"] + ["remove-method" :throws + "(do (defmulti f identity) (defmethod f 1 [_] \"one\") (remove-method f 1) (f 1))"]) + +(defspec "multimethods / hierarchies" + ["derive + isa?" "true" "(do (derive ::child ::parent) (isa? ::child ::parent))"] + ["isa? reflexive" "true" "(isa? ::x ::x)"] + ["isa? unrelated" "false" "(do (derive ::a ::b) (isa? ::a ::c))"] + ["parents" "true" "(do (derive ::c ::p) (contains? (parents ::c) ::p))"] + ["ancestors" "true" "(do (derive ::c ::p) (derive ::p ::g) (contains? (ancestors ::c) ::g))"] + ["descendants" "true" "(do (derive ::c ::p) (contains? (descendants ::p) ::c))"] + ["dispatch via hierarchy" "\"animal\"" + "(do (derive ::dog ::animal) (defmulti speak identity) (defmethod speak ::animal [_] \"animal\") (speak ::dog))"]) diff --git a/test/spec/protocols-spec.janet b/test/spec/protocols-spec.janet new file mode 100644 index 0000000..2a6b34b --- /dev/null +++ b/test/spec/protocols-spec.janet @@ -0,0 +1,46 @@ +# Specification: protocols, types and records. +(use ../support/harness) + +(defspec "protocols / defprotocol & dispatch" + ["protocol on record" "16" + "(do (defprotocol Shape (area [s])) (defrecord Sq [side] Shape (area [_] (* side side))) (area (->Sq 4)))"] + ["protocol on deftype" "16" + "(do (defprotocol Shape (area [s])) (deftype Sq [side] Shape (area [_] (* side side))) (area (->Sq 4)))"] + ["multiple methods" "[1 2]" + "(do (defprotocol P (m [s]) (n [s])) (defrecord R [a b] P (m [_] a) (n [_] b)) [(m (->R 1 2)) (n (->R 1 2))])"] + ["multiple protocols" "[:a :b]" + "(do (defprotocol P1 (p1 [s])) (defprotocol P2 (p2 [s])) (deftype T [] P1 (p1 [_] :a) P2 (p2 [_] :b)) [(p1 (->T)) (p2 (->T))])"] + ["method args" "7" + "(do (defprotocol P (add [s x])) (defrecord R [n] P (add [_ x] (+ n x))) (add (->R 5) 2))"] + ["extend-type" "10" + "(do (defprotocol P (twice [s])) (extend-type Number P (twice [n] (* n 2))) (twice 5))"] + ["extend-protocol" "[2 4]" + "(do (defprotocol P (dbl [s])) (extend-protocol P Number (dbl [n] (* n 2))) [(dbl 1) (dbl 2)])"]) + +(defspec "protocols / records" + ["record field access" "1" + "(do (defrecord R [a b]) (:a (->R 1 2)))"] + ["record map access" "2" + "(do (defrecord R [a b]) (get (->R 1 2) :b))"] + ["record equality" "true" + "(do (defrecord R [a b]) (= (->R 1 2) (->R 1 2)))"] + ["record inequality" "false" + "(do (defrecord R [a b]) (= (->R 1 2) (->R 3 4)))"] + ["map-> factory" "1" + "(do (defrecord R [a b]) (:a (map->R {:a 1 :b 2})))"] + ["record? true" "true" + "(do (defrecord R [a]) (record? (->R 1)))"] + ["assoc on record" "9" + "(do (defrecord R [a]) (:a (assoc (->R 1) :a 9)))"]) + +(defspec "protocols / reify & satisfies" + ["reify dispatch" "42" + "(do (defprotocol P (m [_])) (m (reify P (m [_] 42))))"] + ["reify multi-method" "[1 2]" + "(do (defprotocol P (a [_]) (b [_])) (let [r (reify P (a [_] 1) (b [_] 2))] [(a r) (b r)]))"] + ["satisfies? true" "true" + "(do (defprotocol P (m [_])) (defrecord R [] P (m [_] 1)) (satisfies? P (->R)))"] + ["satisfies? false" "false" + "(do (defprotocol P (m [_])) (defrecord R []) (satisfies? P (->R)))"] + ["instance? record" "true" + "(do (defrecord R [a]) (instance? R (->R 1)))"]) diff --git a/test/spec/state-spec.janet b/test/spec/state-spec.janet new file mode 100644 index 0000000..9fde3cc --- /dev/null +++ b/test/spec/state-spec.janet @@ -0,0 +1,36 @@ +# Specification: stateful reference types (atoms, volatiles, delays, promises). +(use ../support/harness) + +(defspec "state / atoms" + ["deref @" "0" "(let [a (atom 0)] @a)"] + ["deref fn" "0" "(deref (atom 0))"] + ["reset!" "5" "(let [a (atom 0)] (reset! a 5) @a)"] + ["reset! returns new" "5" "(let [a (atom 0)] (reset! a 5))"] + ["swap!" "1" "(let [a (atom 0)] (swap! a inc) @a)"] + ["swap! with args" "10" "(let [a (atom 1)] (swap! a + 2 3 4) @a)"] + ["swap! returns new" "1" "(let [a (atom 0)] (swap! a inc))"] + ["swap-vals!" "[0 1]" "(let [a (atom 0)] (swap-vals! a inc))"] + ["reset-vals!" "[0 9]" "(let [a (atom 0)] (reset-vals! a 9))"] + ["compare-and-set! ok" "true" "(let [a (atom 0)] (compare-and-set! a 0 1))"] + ["compare-and-set! no" "false" "(let [a (atom 0)] (compare-and-set! a 9 1))"] + ["atom?" "true" "(do (require (quote [clojure.core])) (instance? clojure.lang.Atom (atom 0)))"]) + +(defspec "state / watches & validators" + ["add-watch fires" "1" "(let [a (atom 0) seen (atom 0)] (add-watch a :k (fn [k r o n] (reset! seen 1))) (reset! a 5) @seen)"] + ["remove-watch" "0" "(let [a (atom 0) seen (atom 0)] (add-watch a :k (fn [k r o n] (swap! seen inc))) (remove-watch a :k) (reset! a 5) @seen)"] + ["set-validator! ok" "5" "(let [a (atom 0)] (set-validator! a number?) (reset! a 5) @a)"] + ["set-validator! rejects" :throws "(let [a (atom 0)] (set-validator! a pos?) (reset! a -1))"]) + +(defspec "state / volatiles & delays" + ["volatile! deref" "0" "(let [v (volatile! 0)] @v)"] + ["vreset!" "5" "(let [v (volatile! 0)] (vreset! v 5) @v)"] + ["vswap!" "1" "(let [v (volatile! 0)] (vswap! v inc) @v)"] + ["delay not forced" "0" "(let [c (atom 0) d (delay (swap! c inc))] @c)"] + ["delay force once" "1" "(let [c (atom 0) d (delay (swap! c inc))] (force d) (force d) @c)"] + ["delay value" "5" "(let [d (delay 5)] @d)"] + ["realized? before" "false" "(let [d (delay 5)] (realized? d))"] + ["realized? after" "true" "(let [d (delay 5)] (force d) (realized? d))"]) + +(defspec "state / promises" + ["promise deliver" "5" "(let [p (promise)] (deliver p 5) @p)"] + ["promise undelivered" "nil" "(let [p (promise)] @p)"])