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

core: Stage 3 — the hierarchy system is pure Clojure (canonical port)

Browse source 
make-hierarchy/derive/underive/isa?/parents/ancestors/descendants are now
Clojure in the overlay — Clojure's own pure-map implementation: a hierarchy
is {:parents {tag #{..}} :ancestors {..} :descendants {..}}, the 3-arity
forms are PURE (derive returns a new hierarchy), and the 1/2-arity forms swap
a private global-hierarchy atom.

This fixes three correctness gaps the Janet kernel had: multi-parent derive
(the kernel's :parents held a single parent per tag), TRANSITIVE descendants
(the kernel tracked direct children only), and vector-pair isa?
((isa? [child1 child2] [parent1 parent2])). Cyclic and duplicate derives now
behave like Clojure (throw / no-op).

Multimethod dispatch was the kernel's only internal caller: defmulti-setup's
dispatch closure now calls the overlay's isa? through a lazily-resolved var
(cached per multimethod); a :hierarchy option is an atom (deref per dispatch,
matching Clojure's var semantics) or a plain hierarchy map. The Janet kernel
(types.janet) and the core-* wrappers are deleted.

20 new hierarchy spec rows (pure 3-arity incl. cycle/duplicate edges, global
+ dispatch incl. custom :hierarchy atoms). Gate green: conformance 326x3,
suite 4566 >= 4540, all batteries, bench in the session band.
This commit is contained in:
Yogthos 2026-06-10 13:19:05 -04:00
parent 232e4b137c
commit c1a54fa2de
5 changed files with 139 additions and 97 deletions
Download patch file Download diff file Expand all files Collapse all files

48
test/spec/hierarchy-spec.janet Normal file
View file

@ -0,0 +1,48 @@
# Specification: ad-hoc hierarchies (make-hierarchy/derive/underive/isa?/
# parents/ancestors/descendants) — ported to pure Clojure (stage 3). The
# 3-arity forms are PURE (derive returns a new hierarchy); the 1/2-arity forms
# use the global hierarchy. Multi-parent derive, transitive ancestors AND
# descendants, and vector-pair isa? match Clojure (the old Janet kernel had
# single-parent :parents and direct-only descendants).
(use ../support/harness)
(defspec "hierarchy / pure 3-arity"
["derive returns new h" "true"
"(let [h (derive (make-hierarchy) :rect :shape)] (and (map? h) (isa? h :rect :shape)))"]
["original unchanged" "false"
"(let [h0 (make-hierarchy) h1 (derive h0 :rect :shape)] (isa? h0 :rect :shape))"]
["isa? self" "true" "(isa? (make-hierarchy) :a :a)"]
["isa? transitive" "true"
"(let [h (-> (make-hierarchy) (derive :square :rect) (derive :rect :shape))] (isa? h :square :shape))"]
["multi-parent" "[true true]"
"(let [h (-> (make-hierarchy) (derive :sq :rect) (derive :sq :rhombus))] [(isa? h :sq :rect) (isa? h :sq :rhombus)])"]
["parents set" "true"
"(let [h (-> (make-hierarchy) (derive :sq :rect) (derive :sq :rhombus))] (= #{:rect :rhombus} (parents h :sq)))"]
["ancestors transitive" "true"
"(let [h (-> (make-hierarchy) (derive :square :rect) (derive :rect :shape))] (= #{:rect :shape} (ancestors h :square)))"]
["descendants transitive" "true"
"(let [h (-> (make-hierarchy) (derive :square :rect) (derive :rect :shape))] (= #{:rect :square} (descendants h :shape)))"]
["underive removes" "false"
"(let [h (-> (make-hierarchy) (derive :a :b) (underive :a :b))] (isa? h :a :b))"]
["vector isa?" "true"
"(let [h (-> (make-hierarchy) (derive :rect :shape))] (isa? h [:rect :rect] [:shape :shape]))"]
["vector isa? length" "false"
"(isa? (make-hierarchy) [:a] [:a :a])"]
["cyclic derive throws" :throws
"(-> (make-hierarchy) (derive :a :b) (derive :b :a))"]
["duplicate derive ok" "true"
"(let [h (-> (make-hierarchy) (derive :a :b) (derive :a :b))] (isa? h :a :b))"]
["parents nil when none" "nil" "(parents (make-hierarchy) :x)"])
(defspec "hierarchy / global + multimethod dispatch"
["global derive + isa?" "true" "(do (derive :gsq :grect) (isa? :gsq :grect))"]
["global ancestors" "true"
"(do (derive :ga :gb) (derive :gb :gc) (contains? (ancestors :ga) :gc))"]
["global underive" "false"
"(do (derive :gu :gv) (underive :gu :gv) (isa? :gu :gv))"]
["dispatch via hierarchy" ":is-shape"
"(do (derive :hsq :hshape) (defmulti hmm identity) (defmethod hmm :hshape [_] :is-shape) (hmm :hsq))"]
["dispatch custom hierarchy" ":parent"
"(do (def hh (atom (derive (make-hierarchy) :c :p))) (defmulti cmm identity :hierarchy hh) (defmethod cmm :p [_] :parent) (cmm :c))"]
["dispatch exact beats isa" ":exact"
"(do (derive :de1 :de2) (defmulti emm identity) (defmethod emm :de2 [_] :parent) (defmethod emm :de1 [_] :exact) (emm :de1))"])