Merge pull request #294 from jolt-lang/hierarchy/reference-contracts
Hierarchy fns follow the reference contracts; deftype classes join the class graph
This commit is contained in:
Dmitri Sotnikov
GitHub
commit
257f822825
10 changed files with 618 additions and 401 deletions
|
|
@ -258,6 +258,14 @@ transitivity is computed):
|
|||
;; (catch java.io.IOException e …) now matches it; (instance? java.lang.Exception e) is true
|
||||
```
|
||||
|
||||
deftype/defrecord classes join the same graph automatically at definition: a
|
||||
record's ancestry carries the record interfaces (`clojure.lang.IRecord`,
|
||||
`IPersistentMap`, `Associative`, …), a bare deftype carries
|
||||
`clojure.lang.IType`, and every protocol the type implements inline appears as
|
||||
an implemented interface — so `(ancestors MyRecord)`, `(isa? MyRecord
|
||||
clojure.lang.IPersistentMap)`, and hierarchy relationships `derive`d on a
|
||||
class's supers all answer like the JVM.
|
||||
|
||||
Extending a *built-in* class instead (adding a method to core's `String` shim,
|
||||
say) means editing the relevant `host/chez/*.ss` file and running `make remint`
|
||||
— see [building-and-deps.md](building-and-deps.md).
|
||||
|
|
|
|||
|
|
@ -232,6 +232,56 @@ clojure-test-suite `core_test/special_symbol_qmark.cljc` and every
|
|||
|
||||
---
|
||||
|
||||
### make-hierarchy, derive, underive, isa?, parents, ancestors, descendants — since 1.0
|
||||
|
||||
```
|
||||
(make-hierarchy)
|
||||
(derive tag parent) (derive h tag parent)
|
||||
(underive tag parent) (underive h tag parent)
|
||||
(isa? child parent) (isa? h child parent)
|
||||
(parents tag) (ancestors tag) (descendants tag) ; + (f h tag) forms
|
||||
```
|
||||
|
||||
**Semantics**
|
||||
|
||||
- S1. A hierarchy is a pure value `{:parents {tag #{...}} :ancestors {...}
|
||||
:descendants {...}}`; the 3-arity forms are pure, the shorter arities read and
|
||||
mutate the global hierarchy.
|
||||
- S2. `isa?` is true when `(= child parent)`, when the host type system says
|
||||
parent is assignable from child (both classes), when the relationship was
|
||||
`derive`d — including a relationship derived on one of a class child's
|
||||
supers — or component-wise for equal-length vectors.
|
||||
- S3. Class tags answer through the host type hierarchy: `(parents c)` includes
|
||||
the class's direct supers (`bases` — a concrete class's chain roots at
|
||||
`java.lang.Object`, an interface's does not); `(ancestors c)` is the
|
||||
transitive set plus anything `derive`d on the class or its supers. A
|
||||
deftype/defrecord class's ancestry includes its implemented protocol
|
||||
interfaces and, for records, the record interfaces
|
||||
(`clojure.lang.IRecord`/`IPersistentMap`/`Associative`/…; `clojure.lang.IType`
|
||||
for a bare deftype).
|
||||
- S4. `derive` returns the updated hierarchy (3-arity) or nil (2-arity);
|
||||
deriving a relationship that already holds transitively, or one that would
|
||||
create a cycle, throws.
|
||||
|
||||
**Errors**
|
||||
|
||||
- X1. `derive` asserts its argument shapes: parent must be a namespaced Named
|
||||
value; tag must be a class or a Named value (namespaced in the 2-arity
|
||||
global form); `(derive h tag tag)` fails the `not=` assert. AssertionError.
|
||||
- X2. `underive`/`derive` with a non-hierarchy `h` throw at the parents
|
||||
lookup (the map is called as a function, like the reference).
|
||||
- X3. `(descendants h SomeClass)` throws UnsupportedOperationException
|
||||
("Can't get descendants of classes") — Java type inheritance is not
|
||||
enumerable downward.
|
||||
|
||||
**Conformance**
|
||||
|
||||
S1–S4, X1–X3 → corpus `hierarchy / *` rows; clojure-test-suite
|
||||
`core_test/{derive,underive,isa_…,parents,ancestors,descendants}.cljc`
|
||||
(all fully passing).
|
||||
|
||||
---
|
||||
|
||||
## Authoring notes
|
||||
|
||||
- Source examples from the ClojureDocs export (`clojuredocs-export.edn`,
|
||||
|
|
|
|||
|
|
@ -33,6 +33,15 @@
|
|||
|
||||
(define (jch-direct-supers name) (hashtable-ref jvm-class-parents name '()))
|
||||
|
||||
;; Replace a class's direct supers outright (defrecord re-declares the row its
|
||||
;; deftype half registered). Same cache invalidation as a register.
|
||||
(define (jch-set-supers! name supers)
|
||||
(hashtable-set! jvm-class-parents name supers)
|
||||
(hashtable-clear! jch-closure-cache)
|
||||
(hashtable-clear! jch-tags-cache)
|
||||
(set! jch-known-cache #f)
|
||||
(set! jch-simple->fqn-cache #f))
|
||||
|
||||
;; transitive supers of NAME (canonical), excluding NAME and Object; Object is the
|
||||
;; universal root supplied by callers. Breadth-first, deduped, stable order.
|
||||
(define (jch-closure name)
|
||||
|
|
@ -46,6 +55,11 @@
|
|||
(hashtable-set! jch-closure-cache name result)
|
||||
result)))
|
||||
|
||||
;; ns segment munging for a JVM-spelled class name: dashes become underscores
|
||||
;; (clojure.core-test.x -> clojure.core_test.x).
|
||||
(define (jch-munge-segments s)
|
||||
(list->string (map (lambda (c) (if (char=? c #\-) #\_ c)) (string->list s))))
|
||||
|
||||
(define (jch-last-segment s)
|
||||
(let loop ((i (- (string-length s) 1)))
|
||||
(cond ((< i 0) s)
|
||||
|
|
@ -130,6 +144,30 @@
|
|||
(set! jch-simple->fqn-cache #f)
|
||||
(jch-register-supers!-inner name supers)))
|
||||
|
||||
;; ---- interface marking ---------------------------------------------------------
|
||||
;; The JVM distinguishes a concrete class (whose bases/supers chain roots at
|
||||
;; Object) from an interface (whose don't). The graph marks the modeled
|
||||
;; interfaces; anything unmarked is treated as a concrete class.
|
||||
(define jch-interface-set (make-hashtable string-hash string=?))
|
||||
(define (jch-mark-interface! name) (hashtable-set! jch-interface-set name #t))
|
||||
(define (jch-interface? name) (hashtable-ref jch-interface-set name #f))
|
||||
(for-each jch-mark-interface!
|
||||
'("clojure.lang.Seqable" "clojure.lang.Sequential" "clojure.lang.Sorted"
|
||||
"clojure.lang.Reversible" "clojure.lang.Indexed" "clojure.lang.Counted"
|
||||
"clojure.lang.Named" "clojure.lang.Fn" "clojure.lang.IFn"
|
||||
"clojure.lang.IPersistentCollection" "clojure.lang.ISeq"
|
||||
"clojure.lang.Associative" "clojure.lang.ILookup"
|
||||
"clojure.lang.IPersistentStack" "clojure.lang.IPersistentVector"
|
||||
"clojure.lang.IPersistentMap" "clojure.lang.IPersistentSet"
|
||||
"clojure.lang.IPersistentList" "clojure.lang.IObj" "clojure.lang.IMeta"
|
||||
"clojure.lang.IDeref" "clojure.lang.IRecord" "clojure.lang.IType"
|
||||
"clojure.lang.IHashEq" "clojure.lang.IEditableCollection"
|
||||
"clojure.lang.IExceptionInfo" "clojure.lang.IReduceInit"
|
||||
"java.util.List" "java.util.Set" "java.util.Collection" "java.util.Map"
|
||||
"java.util.Iterator" "java.lang.Iterable" "java.lang.CharSequence"
|
||||
"java.lang.Comparable" "java.lang.Runnable"
|
||||
"java.util.concurrent.Callable" "java.io.Serializable"))
|
||||
|
||||
;; ---- seed the built-in graph: direct supers only, faithful to the JVM ---------
|
||||
;; core clojure.lang interfaces
|
||||
(jch-register-supers! "clojure.lang.IPersistentCollection" '("clojure.lang.Seqable"))
|
||||
|
|
|
|||
|
|
@ -841,7 +841,12 @@
|
|||
(define (make-class-obj name) (make-jhost "class" (vector name)))
|
||||
(define (jclass? x) (and (jhost? x) (string=? (jhost-tag x) "class")))
|
||||
(define (jclass-name x) (vector-ref (jhost-state x) 0))
|
||||
(define (class-key x) (cond ((jclass? x) (jclass-name x)) ((string? x) x) (else #f)))
|
||||
(define (class-key x)
|
||||
(cond ((jclass? x) (jclass-name x))
|
||||
((string? x) x)
|
||||
;; a deftype/defrecord NAME var holds its ctor; treat it as the class
|
||||
((procedure? x) (hashtable-ref chez-deftype-ctor-tag x #f))
|
||||
(else #f)))
|
||||
(register-eq-arm! (lambda (a b) (or (jclass? a) (jclass? b)))
|
||||
(lambda (a b) (let ((ka (class-key a)) (kb (class-key b)))
|
||||
(and ka kb (string=? ka kb) #t))))
|
||||
|
|
@ -1047,19 +1052,62 @@
|
|||
#t jolt-nil))
|
||||
jolt-nil))))
|
||||
|
||||
;; is NAME a class the host models (registered in the class graph, a legacy
|
||||
;; supers-table entry, or a fn class)? Object itself is modeled.
|
||||
(define (hsc-class-known? name)
|
||||
(or (string=? name "java.lang.Object")
|
||||
(jch-known? name)
|
||||
(and (hashtable-ref class-supers-tbl name #f) #t)
|
||||
(str-has-dollar? name)))
|
||||
|
||||
;; transitive ancestry, rooted at Object for a concrete class like (supers c);
|
||||
;; an interface's chain has no Object (its getSuperclass is null). '() for
|
||||
;; Object itself and for a name the host doesn't model.
|
||||
(define (class-ancestors-rooted name)
|
||||
(if (or (string=? name "java.lang.Object") (jch-interface? name))
|
||||
(class-ancestors-list name)
|
||||
(let ((as (class-ancestors-list name)))
|
||||
(cond ((member "java.lang.Object" as) as)
|
||||
((null? as) (if (hsc-class-known? name) '("java.lang.Object") '()))
|
||||
(else (append as '("java.lang.Object")))))))
|
||||
|
||||
;; (jolt.host/class-supers name) / (jolt.host/class-ancestors name) — a jolt seq of
|
||||
;; super / ancestor class-name strings, or nil when jolt models no hierarchy for it.
|
||||
;; super / ancestor class-name strings (transitive, Object-rooted), or nil when
|
||||
;; jolt models no hierarchy for it. class-bases is the DIRECT supers (clojure.core
|
||||
;; `bases` / the class arm of `parents`).
|
||||
(def-var! "jolt.host" "class-supers"
|
||||
(lambda (x)
|
||||
(let ((name (class-key x)))
|
||||
(if name
|
||||
(let ((as (class-ancestors-list name))) ; transitive, like the JVM
|
||||
(let ((as (class-ancestors-rooted name)))
|
||||
(if (null? as) jolt-nil (list->cseq as)))
|
||||
jolt-nil))))
|
||||
(def-var! "jolt.host" "class-ancestors"
|
||||
(lambda (x)
|
||||
(let ((name (class-key x)))
|
||||
(if name
|
||||
(let ((as (class-ancestors-list name)))
|
||||
(let ((as (class-ancestors-rooted name)))
|
||||
(if (null? as) jolt-nil (list->cseq as)))
|
||||
jolt-nil))))
|
||||
(def-var! "jolt.host" "class-bases"
|
||||
(lambda (x)
|
||||
(let ((name (class-key x)))
|
||||
(if name
|
||||
(let* ((ds (class-direct-supers name))
|
||||
;; a concrete class's bases include its superclass — Object when
|
||||
;; nothing more specific is modeled (interfaces have none).
|
||||
(ds (if (or (string=? name "java.lang.Object")
|
||||
(jch-interface? name)
|
||||
(member "java.lang.Object" ds))
|
||||
ds
|
||||
(append ds '("java.lang.Object")))))
|
||||
(if (null? ds) jolt-nil (list->cseq ds)))
|
||||
jolt-nil))))
|
||||
;; is X a class value — a jclass, a deftype ctor, or a name string the host
|
||||
;; graph models?
|
||||
(def-var! "jolt.host" "class-value?"
|
||||
(lambda (x)
|
||||
(if (jclass? x)
|
||||
#t
|
||||
(let ((n (class-key x)))
|
||||
(if (and n (hsc-class-known? n)) #t jolt-nil)))))
|
||||
|
|
|
|||
|
|
@ -44,6 +44,10 @@
|
|||
;; resolves "Raw" to its real tag "a.util.Raw" here instead of prepending the
|
||||
;; calling ns. The local ns is preferred, so a same-named local type still wins.
|
||||
(define chez-deftype-tag-set (make-hashtable string-hash string=?))
|
||||
;; ctor procedure -> its class tag: the type NAME var holds the ctor (a jolt-ism;
|
||||
;; the JVM resolves it to the class), so class-key maps the ctor back to the
|
||||
;; class for (ancestors TypeName) / (isa? x TypeName) / derive on the type.
|
||||
(define chez-deftype-ctor-tag (make-weak-eq-hashtable))
|
||||
(define chez-simple-name-tag (make-hashtable string-hash string=?))
|
||||
;; a jrec that is coll? — a record, or a deftype implementing a collection
|
||||
;; interface (its seq/count/nth/valAt/cons method is registered). find-method-any-
|
||||
|
|
@ -618,6 +622,11 @@
|
|||
;; index the tag so a cross-ns extend-protocol resolves the bare type name.
|
||||
(hashtable-set! chez-deftype-tag-set tag #t)
|
||||
(hashtable-set! chez-simple-name-tag (symbol-t-name name-sym) tag)
|
||||
;; graft the type onto the class graph so isa?/supers/ancestors see it. A
|
||||
;; bare deftype is an IType; defrecord (which runs register-record-type!
|
||||
;; right after) replaces the row with the record interface set.
|
||||
(jch-set-supers! tag '("clojure.lang.IType"))
|
||||
(hashtable-set! chez-deftype-ctor-tag ctor tag)
|
||||
;; record the shape for whole-program inference, keyed by the positional
|
||||
;; ctor var "ns/->Name" the analyzer resolves a (->Name …) call to.
|
||||
(register-record-shape! (string-append (chez-current-ns) "/->" (symbol-t-name name-sym))
|
||||
|
|
@ -689,9 +698,14 @@
|
|||
type-name)))
|
||||
;; a host class if the literal set lists it OR the class graph models it — both
|
||||
;; feed value-host-tags (which emits the same bare segment), so a protocol
|
||||
;; extended to any modeled class keys under a tag the value reports.
|
||||
;; extended to any modeled class keys under a tag the value reports. A
|
||||
;; deftype/defrecord is in the graph too (its ancestry), but its VALUES report
|
||||
;; the ns-qualified tag, not the bare segment — so a name that resolves to a
|
||||
;; deftype never canonicalizes through the graph arm.
|
||||
(and (or (hashtable-ref host-type-set base #f)
|
||||
(jch-known? base) (jch-known? type-name))
|
||||
(and (not (hashtable-ref chez-simple-name-tag type-name #f))
|
||||
(not (hashtable-ref chez-deftype-tag-set type-name #f))
|
||||
(or (jch-known? base) (jch-known? type-name))))
|
||||
base)))
|
||||
;; An extend/extend-type/extend-protocol registration marks the tag as an
|
||||
;; extender of the protocol (recorded inside type-registry so the per-case prune
|
||||
|
|
@ -731,6 +745,12 @@
|
|||
(let ((h (make-hashtable string-hash string=?))) (hashtable-set! type-registry tag h) h))))
|
||||
(unless (hashtable-ref ti proto-name #f)
|
||||
(hashtable-set! ti proto-name (make-hashtable string-hash string=?))))
|
||||
;; the protocol's interface joins the type's class ancestry, spelled like the
|
||||
;; JVM interface (munged ns; the defining ns is assumed to be the current one —
|
||||
;; the macro passes only the simple protocol name).
|
||||
(let ((iface (string-append (jch-munge-segments (chez-current-ns)) "." proto-name)))
|
||||
(jch-mark-interface! iface)
|
||||
(jch-register-supers! (string-append (chez-current-ns) "." type-name) (list iface)))
|
||||
jolt-nil)
|
||||
|
||||
;; protocol-resolve: the impl procedure for obj — by record type tag, a reify's
|
||||
|
|
@ -1050,8 +1070,18 @@
|
|||
;; defrecord marks its type a record (deftype does not), keyed by the same
|
||||
;; "ns.Name" tag make-deftype-ctor bakes — so jrec-record? distinguishes the two.
|
||||
(define (register-record-type! name-sym)
|
||||
(hashtable-set! chez-record-type-tbl
|
||||
(string-append (chez-current-ns) "." (symbol-t-name name-sym)) #t)
|
||||
(let ((tag (string-append (chez-current-ns) "." (symbol-t-name name-sym))))
|
||||
(hashtable-set! chez-record-type-tbl tag #t)
|
||||
;; a defrecord's class ancestry: replace the deftype IType row with the
|
||||
;; record interfaces (their closure supplies Associative/Seqable/ILookup/…),
|
||||
;; keeping any protocol interfaces already grafted by the inline
|
||||
;; registrations that ran between the deftype ctor and this call.
|
||||
(let ((protos (filter (lambda (s) (not (string=? s "clojure.lang.IType")))
|
||||
(jch-direct-supers tag))))
|
||||
(jch-set-supers! tag (append protos
|
||||
'("clojure.lang.IRecord" "clojure.lang.IObj"
|
||||
"clojure.lang.IPersistentMap" "java.util.Map"
|
||||
"clojure.lang.IHashEq" "java.io.Serializable")))))
|
||||
jolt-nil)
|
||||
(def-var! "clojure.core" "register-record-type!" register-record-type!)
|
||||
(def-var! "clojure.core" "make-protocol" make-protocol)
|
||||
|
|
|
|||
File diff suppressed because one or more lines are too long
File diff suppressed because one or more lines are too long
|
|
@ -298,16 +298,28 @@
|
|||
(defn val [e] (if (map-entry? e) (nth e 1) (throw (ex-info "val requires a map entry" {}))))
|
||||
|
||||
;; --- Ad-hoc hierarchies (stage 3) — Clojure's canonical pure-map port. -----
|
||||
;; A hierarchy is {:parents {tag #{parents}} :ancestors {tag #{all}}
|
||||
;; 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.
|
||||
;;
|
||||
;; Ported from clojure.core with the reference's argument assertions and throw
|
||||
;; contracts intact — bad shapes throw exactly where they do there (a non-map h
|
||||
;; fails on the (parent-map tag) call, invalid tags fail the asserts). The class
|
||||
;; arms answer through the host class graph (jolt.host/class-* seams).
|
||||
|
||||
(defn make-hierarchy []
|
||||
{:parents {} :descendants {} :ancestors {}})
|
||||
|
||||
(def ^:private global-hierarchy (atom (make-hierarchy)))
|
||||
|
||||
(defn- hier-assert [ok form]
|
||||
(when-not ok (throw (new AssertionError (str "Assert failed: " form)))))
|
||||
|
||||
;; a hierarchy tag naming a class — a class value, or the name string of a class
|
||||
;; the host graph models (jolt classes are their name strings).
|
||||
(defn- class-tag? [tag] (if (jolt.host/class-value? tag) true false))
|
||||
|
||||
(defn isa?
|
||||
([child parent] (isa? (deref global-hierarchy) child parent))
|
||||
([h child parent]
|
||||
|
|
@ -316,6 +328,10 @@
|
|||
;; so a class-keyed multimethod / (isa? (class x) C) dispatches like the JVM.
|
||||
(jolt.host/class-isa? child parent)
|
||||
(contains? (get (get h :ancestors) child #{}) parent)
|
||||
;; a hierarchy relationship established on one of a class's supers
|
||||
(and (class-tag? child)
|
||||
(some (fn [s] (contains? (get (get h :ancestors) s #{}) parent))
|
||||
(jolt.host/class-supers child)))
|
||||
(and (vector? parent) (vector? child)
|
||||
(= (count parent) (count child))
|
||||
(loop [ret true i 0]
|
||||
|
|
@ -325,24 +341,44 @@
|
|||
|
||||
(defn parents
|
||||
([tag] (parents (deref global-hierarchy) tag))
|
||||
([h tag] (not-empty (get (get h :parents) tag))))
|
||||
([h tag] (not-empty
|
||||
(let [tp (get (get h :parents) tag)]
|
||||
(if (class-tag? tag)
|
||||
(into (set (jolt.host/class-bases tag)) tp)
|
||||
tp)))))
|
||||
|
||||
(defn ancestors
|
||||
([tag] (ancestors (deref global-hierarchy) tag))
|
||||
([h tag]
|
||||
;; the user hierarchy plus any modeled JVM ancestry (jolt.host/class-ancestors)
|
||||
;; so (ancestors (class x)) answers like the JVM for the common interfaces.
|
||||
(let [hier (get (get h :ancestors) tag)
|
||||
host (jolt.host/class-ancestors tag)]
|
||||
(not-empty (if host (into (or hier #{}) host) hier)))))
|
||||
([h tag] (not-empty
|
||||
(let [ta (get (get h :ancestors) tag)]
|
||||
(if (class-tag? tag)
|
||||
;; the class's own ancestry plus hierarchy relationships derived
|
||||
;; on the class or any of its supers
|
||||
(let [superclasses (set (jolt.host/class-supers tag))]
|
||||
(reduce into superclasses
|
||||
(cons ta (map (fn [s] (get (get h :ancestors) s))
|
||||
superclasses))))
|
||||
ta)))))
|
||||
|
||||
(defn descendants
|
||||
([tag] (descendants (deref global-hierarchy) tag))
|
||||
([h tag] (not-empty (get (get h :descendants) tag))))
|
||||
([h tag] (if (class-tag? tag)
|
||||
(throw (new UnsupportedOperationException "Can't get descendants of classes"))
|
||||
(not-empty (get (get h :descendants) tag)))))
|
||||
|
||||
(defn derive
|
||||
([tag parent] (swap! global-hierarchy derive tag parent) nil)
|
||||
([tag parent]
|
||||
(hier-assert (namespace parent) "(namespace parent)")
|
||||
(hier-assert (or (class-tag? tag)
|
||||
(and (or (keyword? tag) (symbol? tag)) (namespace tag)))
|
||||
"(or (class? tag) (and (instance? clojure.lang.Named tag) (namespace tag)))")
|
||||
(swap! global-hierarchy derive tag parent) nil)
|
||||
([h tag parent]
|
||||
(hier-assert (not= tag parent) "(not= tag parent)")
|
||||
(hier-assert (or (class-tag? tag) (keyword? tag) (symbol? tag))
|
||||
"(or (class? tag) (instance? clojure.lang.Named tag))")
|
||||
(hier-assert (or (keyword? parent) (symbol? parent))
|
||||
"(instance? clojure.lang.Named parent)")
|
||||
(let [tp (get h :parents)
|
||||
td (get h :descendants)
|
||||
ta (get h :ancestors)
|
||||
|
|
@ -350,14 +386,14 @@
|
|||
(reduce (fn [ret k]
|
||||
(assoc ret k
|
||||
(reduce conj (get targets k #{})
|
||||
(cons target (get targets target)))))
|
||||
m (cons source (get sources source))))]
|
||||
(cons target (targets target)))))
|
||||
m (cons source (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")))
|
||||
(when-not (contains? (tp tag) parent)
|
||||
(when (contains? (ta tag) parent)
|
||||
(throw (new Exception (str tag " already has " parent " as ancestor"))))
|
||||
(when (contains? (ta parent) tag)
|
||||
(throw (new Exception (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)})
|
||||
|
|
@ -367,15 +403,15 @@
|
|||
([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)
|
||||
childs-parents (if (parent-map tag)
|
||||
(disj (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)
|
||||
(if (contains? (parent-map tag) parent)
|
||||
(reduce (fn [p [t pr]] (derive p t pr))
|
||||
(make-hierarchy) (partition 2 deriv-seq))
|
||||
h))))
|
||||
|
|
|
|||
|
|
@ -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))"}
|
||||
]
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue