test(spec): state, multimethods, protocols — fix reify, get-method, hierarchies
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.
This commit is contained in:
Yogthos
parent
50d63d896f
commit
a24e9bfba0
7 changed files with 174 additions and 29 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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]
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
28
test/spec/multimethods-spec.janet
Normal file
28
test/spec/multimethods-spec.janet
Normal file
|
|
@ -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))"])
|
||||
46
test/spec/protocols-spec.janet
Normal file
46
test/spec/protocols-spec.janet
Normal file
|
|
@ -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)))"])
|
||||
36
test/spec/state-spec.janet
Normal file
36
test/spec/state-spec.janet
Normal file
|
|
@ -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)"])
|
||||
Loading…
Add table
Add a link
Reference in a new issue