simon/jolt
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Hierarchy fns follow the reference contracts; deftype classes join the class graph

Browse source 
derive/underive/ancestors/descendants/parents/isa? re-ported from
clojure.core with the argument assertions and throw contracts intact:
derive asserts tag/parent shapes (AssertionError) and throws on redundant
or cyclic derivation; underive/derive on a non-hierarchy value throw at the
parents lookup (the map is called as a function, like the reference);
(descendants h SomeClass) throws UnsupportedOperationException. isa? gains
the reference's supers arm (a relationship derived on a class's super
applies to the class).

The class arms now answer fully through the one class graph: parents of a
class are its direct supers (bases), ancestors are the transitive set
rooted at java.lang.Object for concrete classes (interfaces are marked and
don't root at Object, matching getSuperclass semantics). deftype/defrecord
classes register into the graph at definition — protocol interfaces they
implement appear as supers (JVM-munged ns spelling), records carry the
record interfaces (IRecord/IPersistentMap/... whose closure supplies
Associative/Seqable), bare deftypes carry IType. The type NAME var still
holds the ctor (a jolt-ism); class-key maps it back to the class so
(ancestors TypeName)/(isa? x TypeName) work. canonical-host-tag learned to
NOT canonicalize deftype names through the graph arm (extend-type on a
deftype was registering under the bare segment its values never report).

Five old corpus rows used non-namespaced derive tags that throw on the JVM
too; now namespaced. 8 new JVM-certified corpus rows; spec entries for the
hierarchy family; cts baseline 5730 -> 5781 pass (ancestors/derive/
descendants/parents/underive namespaces fully clean), 74 baselined
namespaces.
This commit is contained in:
Yogthos 2026-07-02 08:48:30 -04:00
parent 7e1df2c600
commit 6e333b3020
10 changed files with 618 additions and 401 deletions
Download patch file Download diff file Expand all files Collapse all files

18
test/chez/corpus.edn
View file

@ -501,12 +501,12 @@
{:suite "hierarchy / pure 3-arity" :label "cyclic derive throws" :expected :throws :actual "(-> (make-hierarchy) (derive :a :b) (derive :b :a))"}
{:suite "hierarchy / pure 3-arity" :label "duplicate derive ok" :expected "true" :actual "(let [h (-> (make-hierarchy) (derive :a :b) (derive :a :b))] (isa? h :a :b))"}
{:suite "hierarchy / pure 3-arity" :label "parents nil when none" :expected "nil" :actual "(parents (make-hierarchy) :x)"}
{:suite "hierarchy / global + multimethod dispatch" :label "global derive + isa?" :expected "true" :actual "(do (derive :gsq :grect) (isa? :gsq :grect))"}
{:suite "hierarchy / global + multimethod dispatch" :label "global ancestors" :expected "true" :actual "(do (derive :ga :gb) (derive :gb :gc) (contains? (ancestors :ga) :gc))"}
{:suite "hierarchy / global + multimethod dispatch" :label "global underive" :expected "false" :actual "(do (derive :gu :gv) (underive :gu :gv) (isa? :gu :gv))"}
{:suite "hierarchy / global + multimethod dispatch" :label "dispatch via hierarchy" :expected ":is-shape" :actual "(do (derive :hsq :hshape) (defmulti hmm identity) (defmethod hmm :hshape [_] :is-shape) (hmm :hsq))"}
{:suite "hierarchy / global + multimethod dispatch" :label "global derive + isa?" :expected "true" :actual "(do (derive :g/sq :g/rect) (isa? :g/sq :g/rect))"}
{:suite "hierarchy / global + multimethod dispatch" :label "global ancestors" :expected "true" :actual "(do (derive :g/a :g/b) (derive :g/b :g/c) (contains? (ancestors :g/a) :g/c))"}
{:suite "hierarchy / global + multimethod dispatch" :label "global underive" :expected "false" :actual "(do (derive :g/u :g/v) (underive :g/u :g/v) (isa? :g/u :g/v))"}
{:suite "hierarchy / global + multimethod dispatch" :label "dispatch via hierarchy" :expected ":is-shape" :actual "(do (derive :h/sq :h/shape) (defmulti hmm identity) (defmethod hmm :h/shape [_] :is-shape) (hmm :h/sq))"}
{:suite "hierarchy / global + multimethod dispatch" :label "dispatch custom hierarchy" :expected ":parent" :actual "(do (def hh (atom (derive (make-hierarchy) :c :p))) (defmulti cmm identity :hierarchy hh) (defmethod cmm :p [_] :parent) (cmm :c))"}
{:suite "hierarchy / global + multimethod dispatch" :label "dispatch exact beats isa" :expected ":exact" :actual "(do (derive :de1 :de2) (defmulti emm identity) (defmethod emm :de2 [_] :parent) (defmethod emm :de1 [_] :exact) (emm :de1))"}
{:suite "hierarchy / global + multimethod dispatch" :label "dispatch exact beats isa" :expected ":exact" :actual "(do (derive :de/e1 :de/e2) (defmulti emm identity) (defmethod emm :de/e2 [_] :parent) (defmethod emm :de/e1 [_] :exact) (emm :de/e1))"}
{:suite "interop / dot forms" :label "method call" :expected "\"v=41\"" :actual "(. {:value 41 :describe (fn [self] (str \"v=\" (:value self)))} describe)"}
{:suite "interop / dot forms" :label "method with args" :expected "\"Hello Alice\"" :actual "(. {:greet (fn [self n] (str \"Hello \" n))} greet \"Alice\")"}
{:suite "interop / dot forms" :label "field access .-" :expected "41" :actual "(.-value {:value 41})"}
@ -3534,4 +3534,12 @@
{:suite "numbers / with-precision" :label "division rounds to precision (default HALF_UP)" :expected "\"0.3333\"" :actual "(str (with-precision 4 (/ 1M 3M)))"}
{:suite "numbers / rationalize" :label "doubles go through shortest decimal print" :expected "[11/10 3/2 1 0 -1]" :actual "[(rationalize 1.1) (rationalize 1.5) (rationalize 1.0) (rationalize 0.0) (rationalize -1.0)]"}
{:suite "numbers / rationalize" :label "bigdec and exacts pass through exactly" :expected "[3/2 1/3 7]" :actual "[(rationalize 1.5M) (rationalize 1/3) (rationalize 7)]"}
{:suite "hierarchy / derive asserts" :label "tag and parent must be namespaced Named (or a class)" :expected "[:ae :ae :ae :ae]" :actual "[(try (derive :a :user/p) (catch AssertionError _ :ae)) (try (derive :user/a :p) (catch AssertionError _ :ae)) (try (derive (make-hierarchy) :user/a :user/a) (catch AssertionError _ :ae)) (try (derive (make-hierarchy) :user/a \"p\") (catch AssertionError _ :ae))]"}
{:suite "hierarchy / derive throws" :label "redundant ancestor and cyclic derivation throw" :expected "[:anc :cyc]" :actual "(let [h (derive (derive (make-hierarchy) :user/b :user/a) :user/c :user/b)] [(try (derive h :user/c :user/a) (catch Exception _ :anc)) (try (derive h :user/a :user/c) (catch Exception _ :cyc))])"}
{:suite "hierarchy / underive" :label "a non-hierarchy first arg throws at the parents lookup" :expected "[:t :t :t]" :actual "[(try (underive {} :user/a :user/b) (catch Throwable _ :t)) (try (underive 42 :user/a :user/b) (catch Throwable _ :t)) (try (underive nil :user/a :user/b) (catch Throwable _ :t))]"}
{:suite "hierarchy / underive" :label "underive removes the relationship" :expected "[nil false]" :actual "(let [h (derive (make-hierarchy) :user/b :user/a) h2 (underive h :user/b :user/a)] [(parents h2 :user/b) (isa? h2 :user/b :user/a)])"}
{:suite "hierarchy / classes" :label "descendants of a class throws" :expected ":uoe" :actual "(try (descendants (make-hierarchy) java.lang.String) (catch UnsupportedOperationException _ :uoe))"}
{:suite "hierarchy / classes" :label "ancestors of a concrete class roots at Object" :expected "[true true]" :actual "[(contains? (ancestors (class #{})) java.lang.Object) (contains? (ancestors (class [])) java.lang.Object)]"}
{:suite "hierarchy / classes" :label "parents of a class are its direct supers" :expected "true" :actual "(contains? (parents (class [])) clojure.lang.APersistentVector)"}
{:suite "hierarchy / classes" :label "a relationship derived on a super applies to the class (isa? supers arm)" :expected "true" :actual "(let [h (derive (make-hierarchy) java.util.Collection :user/coll-like)] (isa? h (class []) :user/coll-like))"}
]

5
test/chez/cts-known-failures.txt
View file

@ -3,7 +3,6 @@
# with: JOLT_CTS_WRITE_BASELINE=1 host/chez/cts.sh
clojure.core-test.abs 1 0
clojure.core-test.add-watch 0 3
clojure.core-test.ancestors 9 0
clojure.core-test.atom 14 0
clojure.core-test.bigint 6 0
clojure.core-test.bit-set 1 0
@ -16,8 +15,6 @@ clojure.core-test.contains-qmark 3 0
clojure.core-test.counted-qmark 1 0
clojure.core-test.dec 1 0
clojure.core-test.denominator 0 3
clojure.core-test.derive 21 0
clojure.core-test.descendants 4 0
clojure.core-test.double 0 4
clojure.core-test.double-qmark 3 0
clojure.core-test.empty 1 0
@ -43,7 +40,6 @@ clojure.core-test.num 2 1
clojure.core-test.number-qmark 3 0
clojure.core-test.numerator 0 3
clojure.core-test.odd-qmark 1 0
clojure.core-test.parents 10 0
clojure.core-test.parse-uuid 3 0
clojure.core-test.peek 2 0
clojure.core-test.plus 11 0
@ -68,7 +64,6 @@ clojure.core-test.special-symbol-qmark 4 0
clojure.core-test.star 13 0
clojure.core-test.star-squote 13 0
clojure.core-test.transient 23 0
clojure.core-test.underive 7 0
clojure.core-test.update 1 0
clojure.core-test.vals 0 3
clojure.core-test.vec 1 0