relations: bulk lifecycle — relate-many! + unrelate-node! cascade cleanup + 12 tests
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>
This commit is contained in:
2026-06-07 13:27:12 +00:00
parent b66395886b
commit c0d02c229c
6 changed files with 202 additions and 6 deletions

View File

@@ -100,3 +100,42 @@
(define
relations/connected?
(fn (a b kind) (relations-connected? (relations-ensure-db!) a b kind)))
(define
relations-relate-many!
(fn
(db triples)
(do
(for-each
(fn
(t)
(dl-assert!
db
(relations-rel (first t) (nth t 1) (nth t 2))))
triples)
db)))
(define
relations-unrelate-node!
(fn
(db node)
(do
(for-each
(fn
(s)
(dl-retract! db (relations-rel node (get s :Dst) (get s :Kind))))
(dl-query db (list (quote rel) node (quote Dst) (quote Kind))))
(for-each
(fn
(s)
(dl-retract! db (relations-rel (get s :Src) node (get s :Kind))))
(dl-query db (list (quote rel) (quote Src) node (quote Kind))))
db)))
(define
relations/relate-many!
(fn (triples) (relations-relate-many! (relations-ensure-db!) triples)))
(define
relations/unrelate-node!
(fn (node) (relations-unrelate-node! (relations-ensure-db!) node)))

View File

@@ -30,4 +30,5 @@ SUITES=(
"shape:lib/relations/tests/shape.sx:(relations-shape-tests-run!)"
"tree:lib/relations/tests/tree.sx:(relations-tree-tests-run!)"
"routes:lib/relations/tests/routes.sx:(relations-routes-tests-run!)"
"bulk:lib/relations/tests/bulk.sx:(relations-bulk-tests-run!)"
)

View File

@@ -1,8 +1,8 @@
{
"lang": "relations",
"total_passed": 135,
"total_passed": 147,
"total_failed": 0,
"total": 135,
"total": 147,
"suites": [
{"name":"direct","passed":22,"failed":0,"total":22},
{"name":"reach","passed":24,"failed":0,"total":24},
@@ -10,7 +10,8 @@
{"name":"fed","passed":22,"failed":0,"total":22},
{"name":"shape","passed":18,"failed":0,"total":18},
{"name":"tree","passed":16,"failed":0,"total":16},
{"name":"routes","passed":9,"failed":0,"total":9}
{"name":"routes","passed":9,"failed":0,"total":9},
{"name":"bulk","passed":12,"failed":0,"total":12}
],
"generated": "2026-06-07T13:18:20+00:00"
"generated": "2026-06-07T13:26:23+00:00"
}

View File

@@ -1,6 +1,6 @@
# relations scoreboard
**135 / 135 passing** (0 failure(s)).
**147 / 147 passing** (0 failure(s)).
| Suite | Passed | Total | Status |
|-------|--------|-------|--------|
@@ -11,3 +11,4 @@
| shape | 18 | 18 | ok |
| tree | 16 | 16 | ok |
| routes | 9 | 9 | ok |
| bulk | 12 | 12 | ok |

142
lib/relations/tests/bulk.sx Normal file
View File

@@ -0,0 +1,142 @@
;; 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})))

View File

@@ -18,7 +18,7 @@ links. Reuses `lib/datalog/` — does not reimplement the engine.
## Status (rolling)
`bash lib/relations/conformance.sh`**135/135** (Phases 14 complete + extensions)
`bash lib/relations/conformance.sh`**147/147** (Phases 14 complete + extensions)
## Ground rules
@@ -110,9 +110,21 @@ lib/relations/federation.sx
computed in SX over `reach`/`ancestors`/`rnode`. `lib/relations/tests/tree.sx`.
- [x] **route enumeration**`all-paths` (all simple directed paths a→b, not just
the shortest; cycle-safe DFS) in explain.sx. `lib/relations/tests/routes.sx`.
- [x] **bulk lifecycle**`relate-many!` (batch assert) + `unrelate-node!` (cascade
cleanup: retract every local edge touching a node, all kinds, both directions —
for domain object deletion; leaves federated peer links alone). api.sx,
`lib/relations/tests/bulk.sx`.
## Progress log
- **Extension: bulk lifecycle** (147/147). `relations-relate-many!` (batch
`dl-assert!` over a list of (src dst kind) triples) and `relations-unrelate-node!`
(query `rel` for every edge with the node as src or dst, across all kinds, then
`dl-retract!` each — the cascade-cleanup a domain needs when it deletes the
object a node id names). Federated `peer_rel` links are a peer's assertion and
are deliberately left untouched. + `relations/relate-many!`/`unrelate-node!`
wrappers, `lib/relations/tests/bulk.sx` (12 tests: batch assert, cascade across
kinds/both directions, unrelated edges preserved, unknown-node no-op, api layer).
- **Extension: route enumeration** (135/135). `relations-all-paths(db,a,b,kind)`
in explain.sx — every simple (no repeated node) directed path a→b, not just the
shortest one `relations-path` returns; DFS that skips nodes already on the