tx: cascade :db/retractEntity through :db/isComponent children
ober
a3849d7bd7b45fc340b0b38875641229db4d128b
--- a/lib/jerboa-db/tx.ss +++ b/lib/jerboa-db/tx.ss @@ -335,31 +335,50 @@ (unless attr (error 'transact! "Unknown attribute" attr-ident)) (emit-datom! eid (db-attribute-id attr) val #f))) - (define (process-retract-entity! eid) - ;; Retract all current datoms for this entity. - ;; Resolve current state: only retract values whose latest datom is an assertion. + ;; Live (current) datoms of one entity: the latest assertion per (a, v). + (define (live-datoms-of eid) (let* ([eavt (index-set-eavt indices)] [lo (make-datom eid 0 +min-val+ 0 #t)] [hi (make-datom eid (greatest-fixnum) +max-val+ (greatest-fixnum) #t)] - [found (dbi-range eavt lo hi)]) - ;; Group by (a, v), find latest tx per group - (let ([ht (make-hashtable equal-hash equal?)]) - (for-each - (lambda (d) - (when (db-filter-datom? db d) - (let ([key (cons (datom-a d) (datom-v d))]) - (let ([existing (hashtable-ref ht key #f)]) - (when (or (not existing) - (> (datom-tx d) (datom-tx existing))) - (hashtable-set! ht key d)))))) - found) - ;; Retract only live values - (let-values ([(keys vals) (hashtable-entries ht)]) - (vector-for-each - (lambda (d) - (when (datom-added? d) - (emit-datom! (datom-e d) (datom-a d) (datom-v d) #f))) - vals))))) + [found (dbi-range eavt lo hi)] + [ht (make-hashtable equal-hash equal?)]) + (for-each + (lambda (d) + (when (db-filter-datom? db d) + (let ([key (cons (datom-a d) (datom-v d))]) + (let ([existing (hashtable-ref ht key #f)]) + (when (or (not existing) + (> (datom-tx d) (datom-tx existing))) + (hashtable-set! ht key d)))))) + found) + (let-values ([(keys vals) (hashtable-entries ht)]) + (filter datom-added? (vector->list vals))))) + + ;; Is attribute aid a :db/isComponent ref? Such children cascade-retract. + (define (component-ref-attr? aid) + (let ([attr (schema-lookup-by-id schema aid)]) + (and attr (db-attribute-is-component? attr) (ref-type? attr)))) + + (define (process-retract-entity! eid) + ;; Datomic :db/retractEntity semantics: retract all of the entity's + ;; current datoms, and recursively retract component entities (those + ;; referenced via :db/isComponent attributes). A visited set guards + ;; against cycles; all retractions are computed against the pre-tx db. + (let ([visited (make-hashtable equal-hash equal?)] + [to-retract '()]) + (let walk ([e eid]) + (unless (hashtable-ref visited e #f) + (hashtable-set! visited e #t) + (let ([lds (live-datoms-of e)]) + (set! to-retract (append lds to-retract)) + (for-each + (lambda (d) + (when (component-ref-attr? (datom-a d)) + (walk (datom-v d)))) + lds)))) + (for-each + (lambda (d) (emit-datom! (datom-e d) (datom-a d) (datom-v d) #f)) + to-retract))) (define (process-cas! eid attr-ident old-val new-val) (let* ([attr (lookup-attr attr-ident)] --- a/tests/test-core.ss +++ b/tests/test-core.ss @@ -785,6 +785,31 @@ (sr (q '((find ?s (sum ?dd)) (where (?t t/rel ?r) (?r r/status ?s) (?t t/d ?dd))) (db conn))) '(("x" 30) ("y" 5)))))) +(test "retractEntity cascades through :db/isComponent (transitive)" + (let ([conn (connect ":memory:")]) + (transact! conn + (list '((db/ident . order/code) (db/valueType . db.type/string) (db/cardinality . db.cardinality/one)) + '((db/ident . order/line) (db/valueType . db.type/ref) (db/cardinality . db.cardinality/one) (db/isComponent . #t)) + '((db/ident . line/sku) (db/valueType . db.type/string) (db/cardinality . db.cardinality/one)) + '((db/ident . line/detail) (db/valueType . db.type/ref) (db/cardinality . db.cardinality/one) (db/isComponent . #t)) + '((db/ident . detail/note) (db/valueType . db.type/string) (db/cardinality . db.cardinality/one)))) + ;; build children-first so refs point at resolved eids (order -> line -> detail) + (transact! conn (list '((detail/note . "N")))) + (let ([detail-eid (caar (q '((find ?e) (where (?e detail/note "N"))) (db conn)))]) + (transact! conn (list `((line/sku . "A") (line/detail . ,detail-eid)))) + (let ([line-eid (caar (q '((find ?e) (where (?e line/sku "A"))) (db conn)))]) + (transact! conn (list `((order/code . "O1") (order/line . ,line-eid)))) + (let ([order-eid (caar (q '((find ?e) (where (?e order/code "O1"))) (db conn)))]) + ;; sanity: the component children exist + (assert-equal (length (q '((find ?l) (where (?l line/sku "A"))) (db conn))) 1) + (assert-equal (length (q '((find ?x) (where (?x detail/note "N"))) (db conn))) 1) + ;; retract the root entity -> cascades to line and detail + (transact! conn (list (list 'db/retractEntity order-eid))) + (let ([d2 (db conn)]) + (assert-equal (q '((find ?e) (where (?e order/code "O1"))) d2) '()) + (assert-equal (q '((find ?l) (where (?l line/sku "A"))) d2) '()) + (assert-equal (q '((find ?x) (where (?x detail/note "N"))) d2) '()))))))) + ;; ============================================================ ;; Report ;; ============================================================