giles
c0d02c229c
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 54s
unrelate-node! retracts every local edge touching a node (all kinds, both directions); leaves federated peer links alone. 147/147. Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
143 lines
4.6 KiB
Plaintext
143 lines
4.6 KiB
Plaintext
;; lib/relations/tests/bulk.sx — extension: bulk lifecycle (relate-many,
|
|
;; unrelate-node cascade cleanup).
|
|
|
|
(define relations-bk-pass 0)
|
|
(define relations-bk-fail 0)
|
|
(define relations-bk-failures (list))
|
|
|
|
(define
|
|
relations-bk-check!
|
|
(fn
|
|
(name got expected)
|
|
(if
|
|
(= got expected)
|
|
(set! relations-bk-pass (+ relations-bk-pass 1))
|
|
(do
|
|
(set! relations-bk-fail (+ relations-bk-fail 1))
|
|
(append!
|
|
relations-bk-failures
|
|
(str name "\n expected: " expected "\n got: " got))))))
|
|
|
|
(define
|
|
relations-bk-subset?
|
|
(fn
|
|
(xs ys)
|
|
(cond
|
|
((= (len xs) 0) true)
|
|
((relations-member? (first xs) ys)
|
|
(relations-bk-subset? (rest xs) ys))
|
|
(else false))))
|
|
|
|
(define
|
|
relations-bk-set=?
|
|
(fn
|
|
(xs ys)
|
|
(and
|
|
(= (len xs) (len ys))
|
|
(relations-bk-subset? xs ys)
|
|
(relations-bk-subset? ys xs))))
|
|
|
|
(define
|
|
relations-bk-run-all!
|
|
(fn
|
|
()
|
|
(do
|
|
(let
|
|
((db (relations-build-db (list))))
|
|
(do
|
|
(relations-relate-many!
|
|
db
|
|
(list
|
|
(list (quote a) (quote b) (quote parent))
|
|
(list (quote a) (quote c) (quote parent))
|
|
(list (quote x) (quote a) (quote parent))
|
|
(list (quote a) (quote m) (quote member))))
|
|
(relations-bk-check!
|
|
"relate-many: parent children of a"
|
|
(relations-bk-set=?
|
|
(relations-children-of db (quote a) (quote parent))
|
|
(list (quote b) (quote c)))
|
|
true)
|
|
(relations-bk-check!
|
|
"relate-many: member child of a"
|
|
(relations-bk-set=?
|
|
(relations-children-of db (quote a) (quote member))
|
|
(list (quote m)))
|
|
true)
|
|
(relations-bk-check!
|
|
"relate-many: x is a parent of a"
|
|
(relations-bk-set=?
|
|
(relations-parents-of db (quote a) (quote parent))
|
|
(list (quote x)))
|
|
true)
|
|
(relations-unrelate-node! db (quote a))
|
|
(relations-bk-check!
|
|
"after cleanup: a has no parent children"
|
|
(relations-children-of db (quote a) (quote parent))
|
|
(list))
|
|
(relations-bk-check!
|
|
"after cleanup: a has no parent parents"
|
|
(relations-parents-of db (quote a) (quote parent))
|
|
(list))
|
|
(relations-bk-check!
|
|
"after cleanup: a has no member children"
|
|
(relations-children-of db (quote a) (quote member))
|
|
(list))
|
|
(relations-bk-check!
|
|
"after cleanup: x no longer points at a"
|
|
(relations-children-of db (quote x) (quote parent))
|
|
(list))))
|
|
(let
|
|
((db (relations-build-db (list (relations-rel (quote a) (quote b) (quote parent)) (relations-rel (quote c) (quote d) (quote parent))))))
|
|
(do
|
|
(relations-unrelate-node! db (quote a))
|
|
(relations-bk-check!
|
|
"cleanup leaves unrelated edge intact"
|
|
(relations-bk-set=?
|
|
(relations-children-of db (quote c) (quote parent))
|
|
(list (quote d)))
|
|
true)
|
|
(relations-bk-check!
|
|
"cleanup removed the a edge"
|
|
(relations-children-of db (quote a) (quote parent))
|
|
(list))))
|
|
(let
|
|
((db (relations-build-db (list (relations-rel (quote a) (quote b) (quote parent))))))
|
|
(do
|
|
(relations-unrelate-node! db (quote nobody))
|
|
(relations-bk-check!
|
|
"cleanup of unknown node is a no-op"
|
|
(relations-bk-set=?
|
|
(relations-children-of db (quote a) (quote parent))
|
|
(list (quote b)))
|
|
true)))
|
|
(do
|
|
(relations/load! (list))
|
|
(relations/relate-many!
|
|
(list
|
|
(list (quote o) (quote i1) (quote member))
|
|
(list (quote o) (quote i2) (quote member))))
|
|
(relations-bk-check!
|
|
"api relate-many"
|
|
(relations-bk-set=?
|
|
(relations/children (quote o) (quote member))
|
|
(list (quote i1) (quote i2)))
|
|
true)
|
|
(relations/unrelate-node! (quote o))
|
|
(relations-bk-check!
|
|
"api unrelate-node"
|
|
(relations/children (quote o) (quote member))
|
|
(list))
|
|
(relations/load! (list))))))
|
|
|
|
(define
|
|
relations-bulk-tests-run!
|
|
(fn
|
|
()
|
|
(do
|
|
(set! relations-bk-pass 0)
|
|
(set! relations-bk-fail 0)
|
|
(set! relations-bk-failures (list))
|
|
(relations-bk-run-all!)
|
|
{:failures relations-bk-failures :total (+ relations-bk-pass relations-bk-fail) :passed relations-bk-pass :failed relations-bk-fail})))
|