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

75
jolt-core/clojure/core/20-coll.clj
View file

@ -180,6 +180,81 @@
(defn file-seq [root]
(tree-seq __dir? __list-dir root))
;; --- Ad-hoc hierarchies (stage 3) — Clojure's canonical pure-map port. -----
;; A hierarchy is {:parents {tag #{parents}} :ancestors {tag #{all}}
;; :descendants {tag #{all}}}. The 3-arity forms are PURE; the 1/2-arity forms
;; operate on the private global hierarchy atom. Multimethod dispatch
;; (evaluator defmulti-setup) calls isa? through the interned var.
(defn make-hierarchy []
{:parents {} :descendants {} :ancestors {}})
(def ^:private global-hierarchy (atom (make-hierarchy)))
(defn isa?
([child parent] (isa? (deref global-hierarchy) child parent))
([h child parent]
(or (= child parent)
(contains? (get (get h :ancestors) child #{}) parent)
(and (vector? parent) (vector? child)
(= (count parent) (count child))
(loop [ret true i 0]
(if (or (not ret) (= i (count parent)))
ret
(recur (isa? h (nth child i) (nth parent i)) (inc i))))))))
(defn parents
([tag] (parents (deref global-hierarchy) tag))
([h tag] (not-empty (get (get h :parents) tag))))
(defn ancestors
([tag] (ancestors (deref global-hierarchy) tag))
([h tag] (not-empty (get (get h :ancestors) tag))))
(defn descendants
([tag] (descendants (deref global-hierarchy) tag))
([h tag] (not-empty (get (get h :descendants) tag))))
(defn derive
([tag parent] (swap! global-hierarchy derive tag parent) nil)
([h tag parent]
(let [tp (get h :parents)
td (get h :descendants)
ta (get h :ancestors)
tf (fn [m source sources target targets]
(reduce (fn [ret k]
(assoc ret k
(reduce conj (get targets k #{})
(cons target (get targets target)))))
m (cons source (get sources source))))]
(or
(when-not (contains? (get tp tag #{}) parent)
(when (contains? (get ta tag #{}) parent)
(throw (str tag " already has " parent " as ancestor")))
(when (contains? (get ta parent #{}) tag)
(throw (str "Cyclic derivation: " parent " has " tag " as ancestor")))
{:parents (assoc tp tag (conj (get tp tag #{}) parent))
:ancestors (tf ta tag td parent ta)
:descendants (tf td parent ta tag td)})
h))))
(defn underive
([tag parent] (swap! global-hierarchy underive tag parent) nil)
([h tag parent]
(let [parent-map (get h :parents)
childs-parents (if (get parent-map tag)
(disj (get parent-map tag) parent)
#{})
new-parents (if (not-empty childs-parents)
(assoc parent-map tag childs-parents)
(dissoc parent-map tag))
deriv-seq (mapcat (fn [e] (cons (key e) (interpose (key e) (val e))))
(seq new-parents))]
(if (contains? (get parent-map tag #{}) parent)
(reduce (fn [p [t pr]] (derive p t pr))
(make-hierarchy) (partition 2 deriv-seq))
h))))
;; --- Stage 3 tier shrink: pure-over-core leaves moved off the Janet seed ----
;; Representation predicates over the overlay's own predicates (no Janet reps).

37
src/jolt/core.janet
View file

@ -2313,36 +2313,6 @@
# intern is a ctx-capturing clojure.core fn now (install-stateful-fns!).
# Hierarchy stubs for sci bootstrap
(def core-make-hierarchy make-hierarchy)
(defn core-derive
[& args]
(case (length args)
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)
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 (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 (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))))
(defn core-underive [& args]
(case (length args)
2 (let [[tag parent] args] (underive the-global-hierarchy tag parent) nil)
3 (let [[h tag parent] args] (underive h tag parent))))
(def core-get-method (fn [mm-var dispatch-val]
(let [methods (get mm-var :jolt/methods)]
(or (get methods dispatch-val) (get methods :default)))))
@ -3229,13 +3199,6 @@
"reset!" core-reset!
"swap!" core-swap!
"not" core-not
"derive" core-derive
"isa?" core-isa?
"parents" core-parents
"ancestors" core-ancestors
"descendants" core-descendants
"make-hierarchy" core-make-hierarchy
"underive" core-underive
"get-method" core-get-method
"methods" core-methods
"remove-method" core-remove-method

18
src/jolt/evaluator.janet
View file

@ -865,6 +865,7 @@
h))
(def ns (ctx-find-ns ctx (ctx-current-ns ctx)))
(def methods @{})
(def isa-cache @[nil])
(def dispatch-cache @{})
(def mm-fn
(fn [& args]
@ -875,11 +876,24 @@
(let [cached (get dispatch-cache dv)]
(if cached
(apply cached args)
(let [h (or hierarchy the-global-hierarchy)
# isa? is the OVERLAY's (the hierarchy system is pure Clojure now,
# stage 3); resolve its var lazily, once. A :hierarchy option is an
# atom (deref per dispatch, like Clojure's var) or a plain map.
(let [isa-fn (do
(when (nil? (isa-cache 0))
(put isa-cache 0
(var-get (ns-find (ctx-find-ns ctx "clojure.core") "isa?"))))
(isa-cache 0))
h (if hierarchy
(if (and (table? hierarchy) (= :jolt/atom (get hierarchy :jolt/type)))
(hierarchy :value)
hierarchy)
nil)
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))))
(if (if h (isa-fn h dv (in ks i)) (isa-fn dv (in ks i)))
(set f (get methods (in ks i))))
(++ i)))
f)]
(if found

58
src/jolt/types.janet
View file

@ -186,64 +186,6 @@
(put v :meta meta)
meta)
(defn make-hierarchy
"Create a new empty hierarchy for multimethod dispatch."
[]
{: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]
(put (h :parents) tag parent)
(let [d (get (h :descendants) parent)]
(if d (array/push d tag) (put (h :descendants) parent @[tag])))
(let [a (get (h :ancestors) tag)]
(if a (array/push a parent) (put (h :ancestors) tag @[parent])))
h)
(defn- ancestors*
"Internal: get all ancestors of a tag via iterative graph walk."
[h tag visited]
(var stack @[tag])
(while (> (length stack) 0)
(let [t (array/pop stack)]
(when (not (get visited t))
(put visited t true)
(let [p (get (h :parents) t)]
(when (and p (not= p t))
(array/push stack p))))))
visited)
(defn ancestors
"Return all transitive ancestors of a tag in the given hierarchy."
[h tag]
(let [visited (ancestors* h tag @{})]
(var result @[])
(loop [[k _] :pairs visited]
(when (not= k tag) (array/push result k)))
result))
(defn descendants
"Return the descendants of a tag in the given hierarchy."
[h tag]
(let [d (get (h :descendants) tag)] (if d d @[])))
(defn isa?
"Check if child is derived from parent in the given hierarchy."
[h child parent]
(if (= child parent) true
(let [p (get (h :parents) child)]
(if p (isa? h p parent) false))))
(defn underive
"Remove a parent relationship from a hierarchy."
[h tag parent]
(put (h :parents) tag nil)
h)
(defn with-meta
"Return a new var with updated metadata. The original var is unchanged."

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))"])