src/folio/doc/structural.sgl

1;;; (folio doc structural) -- structural operations (F3b): insert, delete,

2;;; move, and rename-id-with-reference-rewrite, plus the cross-file

3;;; publication engine they share.

4;;;

5;;; Everything here rides the F3a machinery through the deliberately narrow

6;;; `%txn-` surface: the same coordinator door (in-process mutex, cross-

7;;; process lock, automatic crash recovery), the same bounded reparse, the

8;;; same verify pipeline, the same refusal vocabulary. Structural requests

9;;; NEVER rebase -- D11 amendment 1 -- so every door here refuses

10;;; 'structural-revision-mismatch on a stale expected revision.

11;;;

12;;; SCOPE (ruled 2026-08-25): insert and move handle WORK-ITEM kinds (task,

13;;; decision, question, update). Structural-container surgery -- inserting

14;;; phases or milestones, re-parenting sections -- is SCOPED OUT of F3b

15;;; deliberately, not unsupported: the refusal says so in those words, so a

16;;; later reader extends this module rather than redesigning around a wall

17;;; that was never load-bearing.

18;;;

19;;; THE REFERRER DISCIPLINE. Delete and rename both answer to the same

20;;; hazard: a reference left pointing at nothing, or rewritten into nothing,

21;;; is SILENT KNOWLEDGE LOSS -- the worst outcome available in this component

22;;; (t-5e4329 is the estate's own case: a note rename that updated zero

23;;; crosslinks). Two independent passes find referrers: the SEMANTIC pass

24;;; walks descriptors for `related`/`transclude` `node:` fields (span-

25;;; addressed, so a rewrite is exact), and the RAW pass scans file text for

26;;; the id with identifier-boundary checks, sharing nothing with the parser.

27;;; Any raw occurrence the semantic pass cannot address REFUSES the whole

28;;; operation -- absolutely, with no override flag (ruled: an override on a

29;;; silent-loss guard becomes habit).

30(define-library (folio doc structural)

31 (import (sigil core)

32 (sigil struct)

33 (sigil string)

34 (sigil list)

35 (sigil math)

36 (sigil fs)

37 (sigil path)

38 (sigil io)

39 (folio doc model)

40 (folio doc revision)

41 (folio doc inspect)

42 (folio doc discovery)

43 (folio doc manifest)

44 (folio doc lock)

45 (folio doc coordinator)

46 (folio doc transaction))

47 (export

48 folio-insert-node! folio-delete-node! folio-rename-id! folio-move-node!

49 sop-result? sop-result-op sop-result-files sop-result-node-id

50 sop-result-detail sop-result-recovery-actions

51 sop-file? sop-file-path sop-file-old-revision sop-file-new-revision

52 sop-file-diff)

53 (begin

54

55 ;; ------------------------------------------------------------------

56 ;; Multi-file result

57 ;; ------------------------------------------------------------------

58 (define-struct sop-file-record (path) (old-revision) (new-revision) (diff))

59 (define (sop-file path old new diff)

60 (sop-file-record path: path old-revision: old new-revision: new diff: diff))

61 (define (sop-file? v) (sop-file-record? v))

62 (define (sop-file-path f) (sop-file-record-path f))

63 (define (sop-file-old-revision f) (sop-file-record-old-revision f))

64 (define (sop-file-new-revision f) (sop-file-record-new-revision f))

65 (define (sop-file-diff f) (sop-file-record-diff f))

66

67 (define-struct sop-result-record

68 (op) (files) (node-id) (detail) (recovery))

69 (define (sop-result? v) (sop-result-record? v))

70 (define (sop-result-op r) (sop-result-record-op r))

71 (define (sop-result-files r) (sop-result-record-files r))

72 (define (sop-result-node-id r) (sop-result-record-node-id r))

73 (define (sop-result-detail r) (sop-result-record-detail r))

74 (define (sop-result-recovery-actions r) (sop-result-record-recovery r))

75

76 ;; ------------------------------------------------------------------

77 ;; Work-item rendering

78 ;;

79 ;; The serializer is deliberately minimal: validated scalars into the

80 ;; argument group, an optional PROSE body in the F3a-restricted class

81 ;; (no @, braces, or newlines -- richer bodies arrive by editing the

82 ;; inserted node with folio-edit-body! or the journal doors). Every

83 ;; render is verified by the staged reparse reading the values back, so

84 ;; a serializer defect refuses rather than publishes.

85 ;; ------------------------------------------------------------------

86 (define work-item-kinds '(task decision question update))

87 (define container-kinds-for-insert

88 ;; Work items may live in any of these (mirrors the frozen model's

89 ;; containment: sections and containers hold work items; work items may

90 ;; hold work items). A kind outside this set refuses as SCOPED OUT.

91 '(note section project milestone phase task decision question))

92

93 (define (render-work-item kind (keys: (id #f) (title #f) (status #f)

94 (priority #f) (due #f) (tags #f)

95 (timestamp #f) (author #f) (commit #f)

96 (body-text #f)))

97 (let ((args

98 (case kind

99 ((task)

100 (string-append (%txn-escape-string-literal id)

101 " title: " (%txn-escape-string-literal title)

102 " status: " (%txn-serialize-value 'status status)

103 (if priority (string-append " priority: " (%txn-serialize-value 'priority priority)) "")

104 (if due (string-append " due: " (%txn-serialize-value 'due due)) "")

105 (if tags (string-append " tags: " (%txn-serialize-value 'tags tags)) "")))

106 ((decision question)

107 (string-append (%txn-escape-string-literal id)

108 " title: " (%txn-escape-string-literal title)

109 " status: " (%txn-serialize-value 'status status)))

110 ((update)

111 (string-append (if id (string-append (%txn-escape-string-literal id) " ") "")

112 "timestamp: " (%txn-escape-string-literal timestamp)

113 (if author (string-append " author: " (%txn-escape-string-literal author)) "")

114 (if commit (string-append " commit: " (%txn-escape-string-literal commit)) "")))

115 (else (error (format "render-work-item: ~a is not a work-item kind" kind))))))

116 (string-append "@" (symbol->string kind) "[" args "]{"

117 (if body-text (string-append "\n@p{" body-text "}\n") "")

118 "}\n")))

119

120 ;; ------------------------------------------------------------------

121 ;; Identifier-boundary raw scan. Character class mirrors the flat

122 ;; node-id grammar ([a-z0-9] segments joined by hyphens); an occurrence

123 ;; counts only when both neighbours are OUTSIDE the class, so `t-a`

124 ;; never matches inside `t-alpha` (the estate's own id-truncation lesson,

125 ;; t-060d78's third defect).

126 ;; ------------------------------------------------------------------

127 (define (id-char? c)

128 (or (and (char>=? c #\a) (char<=? c #\z))

129 (and (char>=? c #\0) (char<=? c #\9))

130 (char=? c #\-)))

131 (define (boundary-occurrences text id)

132 (let ((tl (string-length text)) (il (string-length id)))

133 (let loop ((i 0) (hits '()))

134 (cond

135 ((> (+ i il) tl) (reverse hits))

136 ((and (equal? (substring text i (+ i il)) id)

137 (or (= i 0) (not (id-char? (string-ref text (- i 1)))))

138 (or (= (+ i il) tl) (not (id-char? (string-ref text (+ i il))))))

139 (loop (+ i il) (cons i hits)))

140 (else (loop (+ i 1) hits))))))

141

142 ;; ------------------------------------------------------------------

143 ;; Root population. Every operation that looks beyond one file derives

144 ;; its population from discovery's census -- with the denominator kept,

145 ;; never a filtered list -- and reads every candidate INSIDE the lock.

146 ;; ------------------------------------------------------------------

147 ;; A root-wide destructive operation may only trust a population it can

148 ;; PROVE complete. Discovery reports what it could not walk, and three

149 ;; of its classes mean referrers could exist UNSEEN: unreadable

150 ;; directories, contested candidates (collisions), and symlinked

151 ;; directories (deliberately unwalked -- and the F3a containment escape

152 ;; is the standing reason to distrust them). Any of those REFUSES the

153 ;; operation; skips for reason 'not-a-source-format or

154 ;; 'not-a-regular-file are accepted BY DESIGN -- a .txt or a socket is

155 ;; outside the document population the ruled independent pass covers.

156 ;; Returns #f when the census is trustworthy, or a refusal naming what

157 ;; is not.

158 (define (population-guard coord census)

159 (let ((unwalkable

160 (append

161 (map (lambda (d) (list d 'unreadable-directory))

162 (census-unreadable-dirs census))

163 (map (lambda (c) (list (candidate-path c) 'contested-candidate))

164 (census-collisions census))

165 (let loop ((rest (census-skipped census)) (out '()))

166 (cond ((null? rest) (reverse out))

167 ((eq? (skip-reason (car rest)) 'symlinked-directory)

168 (loop (cdr rest)

169 (cons (list (skip-path (car rest)) 'symlinked-directory) out)))

170 (else (loop (cdr rest) out))))

171 ;; DISCOVERY DROPS DOT-PREFIXED NAMES WITHOUT A CENSUS RECORD

172 ;; (entries-of skips them, files AND directories), so a note

173 ;; in `.hidden/` or a `.foo.sgd` is invisible and the census

174 ;; still reads COMPLETE -- the guard failing at its own job

175 ;; (reviewer MEDIUM, 2026-08-25). discovery's skip is shared

176 ;; with F2a/F2b and correctly hides this coordinator's OWN

177 ;; `.folio-*` artifacts; so rather than change it, the guard

178 ;; independently scans the root's top level for any dot-entry

179 ;; that is NOT one of those artifacts and treats it as an

180 ;; unwalked location. Top level is where a `.hidden` dir or a

181 ;; dot-note would sit; anything under it is unreachable by

182 ;; discovery regardless.

183 (dot-intruders coord census))))

184 (if (null? unwalkable)

185 #f

186 (%txn-refuse 'population-unprovable

187

                         (format "a root-wide operation cannot prove its referrer scan complete: ~a location(s) could not be walked: ~a -- refusing rather than renaming or deleting around unseen referrers"

188 (length unwalkable) unwalkable)

189 retryable: #t))))

190

191 ;; The coordinator's own well-known artifacts, which discovery is RIGHT

192 ;; to hide. A dot-entry matching one of these prefixes is expected; any

193 ;; other dot-entry is a note or directory discovery silently dropped.

194 (define (artifact-dot-name? name)

195 (or (equal? name coordination-file-name)

196 (equal? name transaction-manifest-name)

197 (string-starts-with? name staging-prefix)

198 (string-starts-with? name backup-prefix)

199 (string-starts-with? name ".folio-coordination-probe-")))

200

201 (define (dot-intruders coord census)

202 (let ((root (coordinator-root coord)))

203 (let loop ((names (guard (e (#t '())) (or (directory-list root) '())))

204 (out '()))

205 (cond

206 ((null? names) (reverse out))

207 ((and (string-starts-with? (car names) ".")

208 (not (artifact-dot-name? (car names))))

209 (loop (cdr names)

210 (cons (list (path-join root (car names)) 'hidden-unwalked) out)))

211 (else (loop (cdr names) out))))))

212

213 (define (root-population coord)

214 ;; Returns (census . entries) where each entry is

215 ;; (list rel-path abs-path format bytes-or-#f). Bytes are read for

216 ;; every candidate; a read failure carries #f and refuses downstream

217 ;; when the file matters. Discovery's candidate records carry the

218 ;; path and format; the census keeps the denominator.

219 (let* ((root (coordinator-root coord))

220 (census (discover-sources root))

221 (entries

222 (map (lambda (c)

223 (let* ((path (candidate-path c))

224 (rel (path-relative root path))

225 (bytes (guard (e (#t #f)) (read-file-bytes path))))

226 (list rel path (candidate-format c) bytes)))

227 (census-candidates census))))

228 (cons census entries)))

229

230 ;; ------------------------------------------------------------------

231 ;; Referrer discovery for one id (or several), across the population.

232 ;; Returns (list semantic-sites raw-only troubles) where

233 ;; semantic-sites: (rel-path descriptor node field) per rewritable site

234 ;; raw-only: (rel-path context) occurrences with no rewritable span

235 ;; troubles: (rel-path reason) files that carry the id but could

236 ;; not be inspected -- unrewritable by definition.

237 ;; The DECLARATION site (the id field of the owning node) is excluded;

238 ;; callers that rewrite it (rename) handle it explicitly on the target.

239 ;; ------------------------------------------------------------------

240 (define (find-referrers coord entries ids)

241 (let loop ((rest entries) (semantic '()) (raw-only '()) (troubles '()))

242 (if (null? rest)

243 (list (reverse semantic) (reverse raw-only) (reverse troubles))

244 (let* ((entry (car rest))

245 (rel (list-ref entry 0))

246 (fmt (list-ref entry 2))

247 (bytes (list-ref entry 3)))

248 (cond

249 ((not bytes)

250 (loop (cdr rest) semantic raw-only

251 (cons (list rel "unreadable") troubles)))

252 (else

253 (let* ((text (utf8->string bytes))

254 (hits (apply append

255 (map (lambda (id) (boundary-occurrences text id)) ids))))

256 (cond

257 ((null? hits) (loop (cdr rest) semantic raw-only troubles))

258 ((eq? fmt 'md)

259 ;; Markdown notes are never rewritten by this

260 ;; coordinator (M-track); an id referenced from one

261 ;; is unrewritable BY POLICY and refuses upstream.

262 (loop (cdr rest) semantic

263

                             (cons (list rel (format "~a occurrence(s) in a Markdown note this coordinator does not rewrite" (length hits)))

264 raw-only)

265 troubles))

266 (else

267 (let ((d (%txn-bounded-descriptor coord bytes text rel

268 (revision-of-bytes bytes)

269 (format "referrer ~a" rel))))

270 (if (txn-refusal? d)

271 (loop (cdr rest) semantic raw-only

272 (cons (list rel (txn-refusal-message d)) troubles))

273 (let ((sites (reference-sites d ids)))

274 ;; Every boundary hit must be accounted for by

275 ;; a rewritable site or the declaration site;

276 ;; the arithmetic is the guard.

277 (let* ((decl (declaration-sites d ids))

278 (accounted (+ (length sites) (length decl))))

279 (if (= accounted (length hits))

280 (loop (cdr rest)

281 (append semantic

282 (map (lambda (s) (cons rel s)) sites))

283 raw-only troubles)

284 (loop (cdr rest)

285 (append semantic

286 (map (lambda (s) (cons rel s)) sites))

287

                                            (cons (list rel (format "~a raw occurrence(s) with no rewritable span (prose, code, or a query spec)"

288 (- (length hits) accounted)))

289 raw-only)

290 troubles)))))))))))))))

291

292 ;; Rewritable reference sites: related/transclude `node:` fields whose

293 ;; value is one of `ids`. Returned as (node field) pairs.

294 (define (reference-sites d ids)

295 (let walk ((pending (descriptor-nodes d)) (out '()))

296 (if (null? pending)

297 (reverse out)

298 (let* ((n (car pending))

299 (rest (append (inspected-node-children n) (cdr pending))))

300 (if (memq (inspected-node-name n) '(related transclude))

301 (let ((f (let lp ((fs (inspected-node-fields n)))

302 (cond ((null? fs) #f)

303 ((and (eq? (field-name (car fs)) 'node)

304 (member (field-value (car fs)) ids))

305 (car fs))

306 (else (lp (cdr fs)))))))

307 (walk rest (if f (cons (list n f) out) out)))

308 (walk rest out))))))

309

310 ;; Declaration sites: nodes whose OWN id is one of `ids` (the positional

311 ;; id field). Rename rewrites these on the owning document.

312 (define (declaration-sites d ids)

313 (let walk ((pending (descriptor-nodes d)) (out '()))

314 (if (null? pending)

315 (reverse out)

316 (let* ((n (car pending))

317 (rest (append (inspected-node-children n) (cdr pending))))

318 (if (member (inspected-node-id n) ids)

319 (walk rest (cons n out))

320 (walk rest out))))))

321

322 ;; ------------------------------------------------------------------

323 ;; INSERT

324 ;; ------------------------------------------------------------------

325 (define (folio-insert-node! coord path container-id kind expected-revision

326 (keys: (id #f) (title #f) (status #f)

327 (priority #f) (due #f) (tags #f)

328 (timestamp #f) (author #f) (commit #f)

329 (body-text #f)))

330 (unless (coordinator? coord) (error "folio-insert-node!: coord must be a coordinator"))

331 (unless (memq kind work-item-kinds)

332

        (error (format "folio-insert-node!: inserting a ~a is SCOPED OUT of F3b by ruling (2026-08-25), not unsupported -- work-item kinds are ~a; structural-container surgery needs its own phase, so extend rather than redesign" kind work-item-kinds)))

333 ;; Door validation, symmetric with the journal doors.

334 (case kind

335 ((task decision question)

336 (unless (and (string? id) (valid-node-id? id))

337 (error (format "folio-insert-node!: a ~a needs an id in flat node-id syntax" kind)))

338 (unless (and (string? title) (> (string-length title) 0))

339 (error (format "folio-insert-node!: a ~a needs a nonempty title" kind)))

340 (let ((bad (%txn-value-error kind 'status status)))

341 (when bad (error (string-append "folio-insert-node!: " bad)))))

342 ((update)

343 (unless (string? timestamp)

344 (error "folio-insert-node!: an update needs a timestamp"))

345 (unless (and (string? id) (valid-node-id? id))

346

           (error "folio-insert-node!: an update needs an id -- an id-less @update renders as an invalid manuscript (measured: the inspector requires the id positional)"))))

347 (when body-text (%txn-require-safe-journal-text "folio-insert-node!" body-text))

348 (when (eq? kind 'task)

349 (when priority

350 (let ((bad (%txn-value-error 'task 'priority priority)))

351 (when bad (error (string-append "folio-insert-node!: " bad)))))

352 (when due

353 (let ((bad (%txn-value-error 'task 'due due)))

354 (when bad (error (string-append "folio-insert-node!: " bad)))))

355 (when tags

356 (let ((bad (%txn-value-error 'task 'tags tags)))

357 (when bad (error (string-append "folio-insert-node!: " bad))))))

358 (let ((stage

359 (lambda (d source rev)

360 (stage-insert d source rev container-id kind

361 (render-work-item kind id: id title: title status: status

362 priority: priority due: due tags: tags

363 timestamp: timestamp author: author

364 commit: commit body-text: body-text)

365 id))))

366 (%txn-run-structural coord path expected-revision stage container-id)))

367

368 ;; Containers are found by TREE WALK on `inspected-node-id`, not through

369 ;; `descriptor-node-by-id`: the folio id index covers the folio vocabulary

370 ;; (D12's node-id namespace), and a SECTION's id lives in the core

371 ;; anchor-kind namespace -- `@section["Tasks" id: "tasks"]` is exactly how

372 ;; the estate spells its containers, so insertion must reach it. The walk

373 ;; carries its own three-way answer (absent/unique/ambiguous), mirroring

374 ;; the index's contract.

375 ;; A node "carries" an id for containment purposes when either the folio

376 ;; vocabulary declared it (inspected-node-id) or -- for CORE nodes like

377 ;; `@section["Tasks" id: "tasks"]` -- an `id:` argument field holds it.

378 ;; The two are different NAMESPACES by D12; this lookup spans both only

379 ;; to ADDRESS a container, never to rewrite anything: rename touches the

380 ;; folio namespace alone.

381 (define (node-carries-id? n id)

382 (or (equal? (inspected-node-id n) id)

383 (let lp ((fs (inspected-node-fields n)))

384 (cond ((null? fs) #f)

385 ((and (eq? (field-name (car fs)) 'id)

386 (equal? (field-value (car fs)) id)) #t)

387 (else (lp (cdr fs)))))))

388

389 (define (find-container d source container-id rev)

390 (let walk ((pending (descriptor-nodes d)) (found '()))

391 (if (null? pending)

392 (cond

393 ((null? found)

394 (%txn-refuse 'unknown-node

395 (format "no node with id ~s exists in this document" container-id)

396 current-revision: rev))

397 ((null? (cdr found)) (car found))

398 (else

399 (%txn-refuse 'ambiguous-node

400 (format "container id ~s names ~a nodes in this document; resolution is refused"

401 container-id (length found))

402 current-revision: rev)))

403 (let ((n (car pending)))

404 (walk (append (inspected-node-children n) (cdr pending))

405 (if (node-carries-id? n container-id)

406 (cons n found)

407 found))))))

408

409 (define (stage-insert d source rev container-id kind rendered new-id)

410 (let ((container (find-container d source container-id rev)))

411 (cond

412 ((txn-refusal? container) container)

413 ((not (memq (inspected-node-name container) container-kinds-for-insert))

414 (%txn-refuse 'scoped-out

415

                        (format "inserting into a ~a is SCOPED OUT of F3b by ruling (2026-08-25), not unsupported -- extend the containment table if a later phase rules it in" (inspected-node-name container))

416 current-revision: rev

417 target-context: (%txn-node-context source container)))

418 ((and new-id (not (eq? (descriptor-id-status d new-id) 'absent)))

419 (%txn-refuse 'insert-id-taken

420 (format "id ~s is already declared in this document" new-id)

421 current-revision: rev))

422 (else

423 (let ((at (%txn-body-insertion-point source container)))

424 (if (not at)

425 (%txn-refuse 'update-target-has-no-body

426

                               (format "container ~s has neither a braced body nor an @end block to insert into" container-id)

427 current-revision: rev)

428 (let* ((staged (%txn-splice source at at (string-append "\n" rendered)))

429 (byte-at (%txn-scalar->byte-offset source at))

430 (pre-total (descriptor-node-count d))

431 (pre-outside (- pre-total (%txn-subtree-count container))))

432 (list staged byte-at 0 0

433 #f rendered new-id

434 #f ;; delta variable (body optional); the check

435 ;; below carries the outside-container invariant

436 (lambda (staged-d)

437 (insert-check staged-d container-id kind new-id

438 pre-outside rev))))))))))

439

440 (define (insert-check staged-d container-id kind new-id pre-outside rev)

441 (let ((c2 (let walk ((pending (descriptor-nodes staged-d)))

442 (cond ((null? pending) #f)

443 ((node-carries-id? (car pending) container-id)

444 (car pending))

445 (else (walk (append (inspected-node-children (car pending))

446 (cdr pending))))))))

447 (cond

448 ((not c2)

449 (%txn-refuse 'postcheck-failed

450 (format "the container ~s vanished from the staged document" container-id)

451 current-revision: rev))

452 ((and new-id (not (eq? (descriptor-id-status staged-d new-id) 'unique)))

453 (%txn-refuse 'postcheck-failed

454 (format "the inserted node's id ~s did not land uniquely" new-id)

455 current-revision: rev))

456 ((and new-id

457 (not (let walk ((pending (inspected-node-children c2)))

458 (cond ((null? pending) #f)

459 ((equal? (inspected-node-id (car pending)) new-id) #t)

460 (else (walk (append (inspected-node-children (car pending))

461 (cdr pending))))))))

462 (%txn-refuse 'postcheck-failed

463 (format "the inserted node ~s did not land inside container ~s" new-id container-id)

464 current-revision: rev))

465 ((not (= (- (descriptor-node-count staged-d) (%txn-subtree-count c2))

466 pre-outside))

467 (%txn-refuse 'postcheck-failed

468 (format "the insert escaped its container: the node count outside ~s moved" container-id)

469 current-revision: rev))

470 (else #f))))

471

472 ;; ------------------------------------------------------------------

473 ;; DELETE

474 ;; ------------------------------------------------------------------

475 (define (folio-delete-node! coord path node-id expected-revision)

476 (unless (coordinator? coord) (error "folio-delete-node!: coord must be a coordinator"))

477 (let ((stage

478 (lambda (d source rev)

479 (stage-delete coord d source rev node-id))))

480 (%txn-run-structural coord path expected-revision stage node-id)))

481

482 (define (stage-delete coord d source rev node-id)

483 (let ((node (find-container d source node-id rev)))

484 (cond

485 ((txn-refusal? node) node)

486 ((not (memq (inspected-node-name node) work-item-kinds))

487 (%txn-refuse 'scoped-out

488

                        (format "deleting a ~a is SCOPED OUT of F3b by ruling (2026-08-25), not unsupported -- F3b deletes work items; container deletion needs its own phase" (inspected-node-name node))

489 current-revision: rev

490 target-context: (%txn-node-context source node)))

491 (else

492 ;; Every id the deletion would remove must be unreferenced across

493 ;; the WHOLE ROOT -- both passes, absolute refusal.

494 (let* ((doomed (cons node-id (%txn-subtree-declared-ids node)))

495 (doomed (filter string? doomed))

496 (population (root-population coord))

497 (guard-refusal (population-guard coord (car population)))

498 (found (find-referrers coord (cdr population) doomed))

499 (semantic (list-ref found 0))

500 (raw-only (list-ref found 1))

501 (troubles (list-ref found 2)))

502 (cond

503 (guard-refusal guard-refusal)

504 ((pair? troubles)

505 (%txn-refuse 'referrer-uninspectable

506

                              (format "cannot prove ~s unreferenced: ~a file(s) carrying its id could not be inspected: ~a"

507 node-id (length troubles) troubles)

508 current-revision: rev retryable: #t))

509 ((or (pair? semantic) (pair? raw-only))

510 (%txn-refuse 'node-referenced

511

                              (format "deleting ~s would strand ~a semantic reference(s) and ~a raw occurrence(s): ~a~a -- deletion refuses while referrers exist (silent knowledge loss is the outcome this door exists to prevent)"

512 node-id (length semantic) (length raw-only)

513 (map car semantic) (map car raw-only))

514 current-revision: rev

515 target-context: (%txn-node-context source node)))

516 (else

517 (let* ((sp (inspected-node-span node))

518 (start (span-scalar-start sp))

519 (end (span-scalar-end sp))

520 (staged (%txn-splice source start end ""))

521 (byte-start (%txn-scalar->byte-offset source start))

522 (byte-end (%txn-scalar->byte-offset source end))

523 (subtree (%txn-subtree-count node)))

524 (list staged byte-start (- byte-end byte-start) 0

525 (substring source start end) #f node-id

526 ;; The exact delta is noisy for deletions: adjacent

527 ;; inter-node whitespace TEXT nodes merge when a

528 ;; span vanishes (measured: a 3-node subtree's

529 ;; removal moved the count by 4). The id-absence

530 ;; and persistence checks carry the invariant.

531 #f

532 (lambda (staged-d)

533 (cond

534 ((not (eq? (descriptor-id-status staged-d node-id) 'absent))

535 (%txn-refuse 'postcheck-failed

536 (format "~s still declared after its deletion" node-id)

537 current-revision: rev))

538 (else #f)))

539 doomed)))))))))

540

541 (define (filter pred xs)

542 (let loop ((rest xs) (out '()))

543 (cond ((null? rest) (reverse out))

544 ((pred (car rest)) (loop (cdr rest) (cons (car rest) out)))

545 (else (loop (cdr rest) out)))))

546

547 ;; ------------------------------------------------------------------

548 ;; THE CROSS-FILE PUBLICATION ENGINE

549 ;;

550 ;; Order is the contract (see manifest.sgl's header): stage everything,

551 ;; VERIFY everything, then backups -> temps -> MANIFEST (the atomic

552 ;; commit point) -> renames -> clear manifest -> drop backups. A crash

553 ;; before the manifest lands leaves only debris the next writer's

554 ;; recovery sweeps (nothing was renamed); a crash after it leaves a

555 ;; validated set the next writer COMPLETES. The txn id is derived from

556 ;; the operation's own content -- this toolchain deliberately exposes no

557 ;; clock or randomness to library code, and a content-derived id is

558 ;; reproducible in transcripts.

559 ;; ------------------------------------------------------------------

560 (define (content-txn-id op-label parts)

561 (substring (revision-hex (revision-of-bytes

562 (string->utf8 (apply string-append op-label parts))))

563 0 12))

564

565 ;; staged-list entries: (list rel-path abs-path pre-bytes staged-source)

566 ;; Returns per-file (list rel pre-rev post-rev) after full publication.

567 (define (publish-file-set! coord txn-id op-label staged-list)

568 (let* ((root (coordinator-root coord))

569 (entries

570 (map (lambda (s)

571 (let* ((rel (list-ref s 0))

572 (abs (list-ref s 1))

573 (pre-bytes (list-ref s 2))

574 (staged-bytes (string->utf8 (list-ref s 3)))

575 (dir (path-dirname abs))

576 (base (path-basename abs))

577 (temp-name (string-append staging-prefix base "." txn-id ".tmp"))

578 (backup-name (string-append backup-prefix base "." txn-id))

579 (pre-rev (revision-of-bytes pre-bytes))

580 (post-rev (revision-of-bytes staged-bytes)))

581 ;; Backups first, temps second, both hash-verified:

582 ;; an unverified restore artifact is the thing the

583 ;; estate's sabotage-restore discipline exists for.

584 (write-file-bytes (path-join dir backup-name) pre-bytes)

585 (unless (equal? (revision-of-file (path-join dir backup-name)) pre-rev)

586 (error "publish-file-set!: backup hash mismatch after write"))

587 (write-file-bytes (path-join dir temp-name) staged-bytes)

588 (unless (equal? (revision-of-file (path-join dir temp-name)) post-rev)

589 (error "publish-file-set!: staged temp hash mismatch after write"))

590 (list rel abs pre-rev post-rev

591 (path-relative root (path-join dir temp-name))

592 (path-relative root (path-join dir backup-name)))))

593 staged-list)))

594 ;; THE COMMIT POINT.

595 (write-transaction-manifest! root txn-id op-label

596 (map (lambda (e)

597 (mentry (list-ref e 0) (list-ref e 2)

598 (list-ref e 4) (list-ref e 3)

599 (list-ref e 3)

600 (list-ref e 5) (list-ref e 2)))

601 entries))

602 ;; Renames. From here a crash is COMPLETED by recovery.

603 (for-each (lambda (e)

604 (rename-file (path-join root (list-ref e 4)) (list-ref e 1)))

605 entries)

606 (clear-transaction-manifest! root)

607 (for-each (lambda (e)

608 (guard (x (#t #f))

609 (delete-file (path-join root (list-ref e 5)))))

610 entries)

611 (map (lambda (e) (list (list-ref e 0) (list-ref e 2) (list-ref e 3)))

612 entries)))

613

614 ;; ------------------------------------------------------------------

615 ;; RENAME ID WITH REFERENCE REWRITE

616 ;; ------------------------------------------------------------------

617 (define (folio-rename-id! coord old-id new-id expected-revision)

618 (unless (coordinator? coord) (error "folio-rename-id!: coord must be a coordinator"))

619 (unless (and (string? old-id) (valid-node-id? old-id))

620 (error "folio-rename-id!: old-id must use flat node-id syntax"))

621 (unless (and (string? new-id) (valid-node-id? new-id))

622 (error "folio-rename-id!: new-id must use flat node-id syntax"))

623 (when (equal? old-id new-id)

624 (error "folio-rename-id!: old and new ids are identical"))

625 (coordinator-transact coord

626 (lambda (recovery-actions)

627 (%txn-stamp-recovery

628 (rename-under-lock coord old-id new-id expected-revision)

629 recovery-actions))))

630

631 (define (rename-under-lock coord old-id new-id expected-revision)

632 (let* ((population (root-population coord))

633 (census (car population))

634 (entries (cdr population))

635 (guard-refusal (population-guard coord census)))

636 (if guard-refusal

637 guard-refusal

638 ;; 1. The NEW id must be completely fresh -- no boundary occurrence

639 ;; anywhere, prose included. Conservative by design.

640 (let ((taken

641 (filter (lambda (e)

642 (and (list-ref e 3)

643 (pair? (boundary-occurrences (utf8->string (list-ref e 3)) new-id))))

644 entries)))

645 (if (pair? taken)

646 (%txn-refuse 'rename-target-taken

647 (format "new id ~s already occurs in: ~a -- a rename must land in a fresh name"

648 new-id (map car taken)))

649 ;; 2. Exactly ONE document declares the old id (D9 workspace

650 ;; uniqueness; the estate's live duplicates refuse here rather

651 ;; than being picked between).

652 (let ((owners

653 (filter (lambda (e)

654 (and (eq? (list-ref e 2) 'sgd)

655 (list-ref e 3)

656 (let* ((text (utf8->string (list-ref e 3)))

657 (hits (boundary-occurrences text old-id)))

658 (and (pair? hits)

659 (let ((d (%txn-bounded-descriptor

660 coord (list-ref e 3) text

661 (list-ref e 0)

662 (revision-of-bytes (list-ref e 3))

663 (format "document ~a" (list-ref e 0)))))

664 (and (descriptor? d)

665 (pair? (declaration-sites d (list old-id)))))))))

666 entries)))

667 (cond

668 ((null? owners)

669 (%txn-refuse 'unknown-node

670 (format "no document in this root declares node id ~s" old-id)))

671 ((pair? (cdr owners))

672 (%txn-refuse 'ambiguous-rename

673

                                (format "node id ~s is declared in ~a documents (~a); a workspace-ambiguous id cannot be renamed -- D9 presumes uniqueness and this coordinator refuses to pick"

674 old-id (length owners) (map car owners))))

675 (else

676 (rename-with-owner coord old-id new-id expected-revision

677 entries (car owners))))))))))

678

679 (define (rename-with-owner coord old-id new-id expected-revision entries owner)

680 (let* ((owner-rel (list-ref owner 0))

681 (owner-bytes (list-ref owner 3))

682 (owner-rev (revision-of-bytes owner-bytes)))

683 (cond

684 ;; 3. Structural: exact revision match on the OWNING document,

685 ;; never rebased (amendment 1).

686 ((not (equal? owner-rev expected-revision))

687 (%txn-refuse 'structural-revision-mismatch

688

                        (format "expected the owning document ~a at revision ~a but it is at ~a. Structural edits ALWAYS refuse on revision mismatch (D11 amendment 1); reread and re-decide."

689 owner-rel expected-revision owner-rev)

690 current-revision: owner-rev

691 diff: (format "-expected-revision ~a~%+current-revision ~a~%"

692 expected-revision owner-rev)))

693 (else

694 ;; 4. Referrer accounting: every raw occurrence must be a

695 ;; rewritable span or a declaration; anything else -- prose,

696 ;; code, query specs, Markdown notes, uninspectable files --

697 ;; refuses the WHOLE rename, absolutely.

698 (let* ((found (find-referrers coord entries (list old-id)))

699 (semantic (list-ref found 0))

700 (raw-only (list-ref found 1))

701 (troubles (list-ref found 2)))

702 (cond

703 ((pair? troubles)

704 (%txn-refuse 'referrer-uninspectable

705 (format "cannot account for every occurrence of ~s: ~a file(s) could not be inspected: ~a"

706 old-id (length troubles) troubles)

707 retryable: #t))

708 ((pair? raw-only)

709 (%txn-refuse 'unrewritable-reference

710

                              (format "~s occurs where no rewritable span exists -- ~a -- renaming would leave those stale (t-5e4329's defect class) or rewrite them blind; both refuse, with no override"

711 old-id raw-only)))

712 (else

713 (stage-rename-set coord old-id new-id entries owner semantic))))))))

714

715 ;; Stage every touched file, verify each, publish through the engine.

716 (define (stage-rename-set coord old-id new-id entries owner semantic)

717 (let* ((root (coordinator-root coord))

718 ;; Group semantic reference sites by file; the OWNER also gets

719 ;; its declaration site(s) rewritten.

720 (touched-rels

721 (let loop ((rest semantic) (out (list (list-ref owner 0))))

722 (cond ((null? rest) (reverse out))

723 ((member (car (car rest)) out) (loop (cdr rest) out))

724 (else (loop (cdr rest) (cons (car (car rest)) out))))))

725 (staged-or-refusal

726 (let loop ((rels touched-rels) (staged '()))

727 (if (null? rels)

728 (reverse staged)

729 (let ((s (stage-one-rename-file coord old-id new-id entries

730 (car rels) semantic)))

731 (if (txn-refusal? s)

732 s

733 (loop (cdr rels) (cons s staged))))))))

734 (if (txn-refusal? staged-or-refusal)

735 staged-or-refusal

736 ;; GRAPH CLOSURE over the staged set: zero boundary occurrences

737 ;; of the old id remain anywhere it occurred.

738 (let ((leak

739 (filter (lambda (s)

740 (pair? (boundary-occurrences (list-ref s 3) old-id)))

741 staged-or-refusal)))

742 (if (pair? leak)

743 (%txn-refuse 'postcheck-failed

744 (format "rename closure failed: ~s still occurs in staged ~a"

745 old-id (map car leak)))

746 (let* ((txn-id (content-txn-id "rename-id"

747 (list old-id new-id

748 (revision-of-bytes (list-ref owner 3)))))

749 (published (publish-file-set! coord txn-id "rename-id"

750 staged-or-refusal)))

751 (sop-result-record

752 op: 'rename-id

753 files: (let zip ((ps published) (ss staged-or-refusal) (out '()))

754 (if (or (null? ps) (null? ss))

755 (reverse out)

756 (let ((p (car ps)) (s (car ss)))

757 (zip (cdr ps) (cdr ss)

758 (cons (sop-file (list-ref p 0) (list-ref p 1) (list-ref p 2)

759 (%txn-make-line-diff

760

                                                            (utf8->string (list-ref (assoc-entry entries (list-ref p 0)) 3))

761 (list-ref s 3)))

762 out)))))

763 node-id: new-id

764 detail: (format "renamed ~s -> ~s across ~a file(s); ~a reference site(s) rewritten"

765 old-id new-id (length touched-rels) (length semantic))

766 recovery: '())))))))

767

768 (define (assoc-entry entries rel)

769 (let loop ((rest entries))

770 (cond ((null? rest) #f)

771 ((equal? (car (car rest)) rel) (car rest))

772 (else (loop (cdr rest))))))

773

774 ;; Stage one file of the rename: rewrite its declaration site(s) (owner)

775 ;; and reference site(s), rear-most span first so earlier offsets stay

776 ;; valid; verify with the full single-file pipeline.

777 (define (stage-one-rename-file coord old-id new-id entries rel semantic)

778 (let* ((entry (assoc-entry entries rel))

779 (bytes (list-ref entry 3))

780 (text (utf8->string bytes))

781 (rev (revision-of-bytes bytes))

782 (d (%txn-bounded-descriptor coord bytes text rel rev

783 (format "document ~a" rel))))

784 (if (txn-refusal? d)

785 d

786 (let* ((decl (declaration-sites d (list old-id)))

787 (refs (let loop ((rest semantic) (out '()))

788 (cond ((null? rest) (reverse out))

789 ((equal? (car (car rest)) rel)

790 (loop (cdr rest) (cons (cdr (car rest)) out)))

791 (else (loop (cdr rest) out)))))

792 ;; Spans to rewrite: each declaration node's ID FIELD (the

793 ;; positional first argument) and each reference site's

794 ;; node field. All must have spans or the file refuses.

795 (spans

796 (append

797 (map (lambda (n)

798 (let lp ((fs (inspected-node-fields n)))

799 (cond ((null? fs) #f)

800 ((and (not (field-name (car fs)))

801 (equal? (field-value (car fs)) old-id))

802 (field-span (car fs)))

803 (else (lp (cdr fs))))))

804 decl)

805 (map (lambda (site) (field-span (list-ref site 1)))

806 refs))))

807 (if (memq #f spans)

808 (%txn-refuse 'rebase-span-invalid

809

                               (format "a rewrite site for ~s in ~a has no recorded span; refusing a blind rewrite" old-id rel)

810 current-revision: rev)

811 (let* ((replacement (%txn-escape-string-literal new-id))

812 (ordered (sort-spans-desc spans))

813 (staged

814 (let loop ((rest ordered) (s text))

815 (if (null? rest)

816 s

817 (loop (cdr rest)

818 (%txn-splice s (span-scalar-start (car rest))

819 (span-scalar-end (car rest))

820 replacement)))))

821 ;; Verify through the standard pipeline with a

822 ;; coarse byte region spanning all rewrites.

823 (byte-lo (%txn-scalar->byte-offset text

824 (span-scalar-start (list-ref ordered (- (length ordered) 1)))))

825 (byte-hi (%txn-scalar->byte-offset text

826 (span-scalar-end (car ordered))))

827 (bad (%txn-verify-staged coord rel bytes text rev

828 staged (descriptor-ids d)

829 byte-lo (- byte-hi byte-lo)

830 0

831 (lambda (staged-d)

832 (rename-file-check staged-d rel old-id new-id

833 (pair? decl) rev))

834 'postcheck-failed

835 (descriptor-node-count d)

836 0

837 (list old-id))))

838 (if bad

839 bad

840 (list rel (list-ref entry 1) bytes staged))))))))

841

842 (define (sort-spans-desc spans)

843 ;; Insertion sort, descending by scalar start; site counts are small.

844 (let loop ((rest spans) (out '()))

845 (if (null? rest)

846 out

847 (loop (cdr rest)

848 (let ins ((xs out))

849 (cond ((null? xs) (list (car rest)))

850 ((> (span-scalar-start (car rest)) (span-scalar-start (car xs)))

851 (cons (car rest) xs))

852 (else (cons (car xs) (ins (cdr xs))))))))))

853

854 (define (rename-file-check staged-d rel old-id new-id owner? rev)

855 (cond

856 ((not (eq? (descriptor-id-status staged-d old-id) 'absent))

857 (%txn-refuse 'postcheck-failed

858 (format "~s still declared in staged ~a" old-id rel)

859 current-revision: rev))

860 ((and owner? (not (eq? (descriptor-id-status staged-d new-id) 'unique)))

861 (%txn-refuse 'postcheck-failed

862 (format "~s is not uniquely declared in the staged owner ~a" new-id rel)

863 current-revision: rev))

864 (else #f)))

865

866 ;; ------------------------------------------------------------------

867 ;; MOVE

868 ;;

869 ;; Same-file: one staged document, extract + reinsert, no reference is

870 ;; affected (D12 references address document + node, and neither

871 ;; changes). Cross-file: the moved node LEAVES its document, so every

872 ;; `related`/`transclude` whose `document:` names the source AND whose

873 ;; `node:` names the moved id would silently go stale -- exactly

874 ;; t-5e4329's class -- so those `document:` fields are rewritten to the

875 ;; destination's slug in the same manifest transaction, with the same

876 ;; raw-accounting refusal as rename for anything unrewritable.

877 ;; ------------------------------------------------------------------

878 (define (folio-move-node! coord source-path node-id dest-path dest-container-id

879 expected-source-revision

880 (keys: (expected-dest-revision #f)))

881 (unless (coordinator? coord) (error "folio-move-node!: coord must be a coordinator"))

882 (let ((source-path (%txn-require-contained-path coord source-path))

883 (dest-path (%txn-require-contained-path coord dest-path)))

884 (coordinator-transact coord

885 (lambda (recovery-actions)

886 (%txn-stamp-recovery

887 (if (equal? source-path dest-path)

888 (move-same-file coord source-path node-id dest-container-id

889 expected-source-revision)

890 (move-cross-file coord source-path node-id dest-path dest-container-id

891 expected-source-revision expected-dest-revision))

892 recovery-actions)))))

893

894 (define (read-doc coord path label)

895 ;; (list bytes text rev descriptor) or a refusal.

896 (if (not (file-exists? path))

897 (%txn-refuse 'unknown-node (format "no such file: ~a" path))

898 (let* ((bytes (read-file-bytes path))

899 (text (utf8->string bytes))

900 (rev (revision-of-bytes bytes)))

901 (if (not (%txn-bytes-equal? (string->utf8 text) bytes))

902 (%txn-refuse 'encoding-not-roundtrip

903 (format "~a's bytes do not survive UTF-8 round-trip" path)

904 current-revision: rev)

905 (let ((d (%txn-bounded-descriptor coord bytes text path rev label)))

906 (if (txn-refusal? d)

907 d

908 (list bytes text rev d)))))))

909

910 (define (movable-node d text node-id rev)

911 ;; The node, checked movable (work item), or a refusal.

912 (let ((node (find-container d text node-id rev)))

913 (cond

914 ((txn-refusal? node) node)

915 ((not (memq (inspected-node-name node) work-item-kinds))

916 (%txn-refuse 'scoped-out

917

                        (format "moving a ~a is SCOPED OUT of F3b by ruling (2026-08-25), not unsupported -- F3b moves work items" (inspected-node-name node))

918 current-revision: rev))

919 (else node))))

920

921 (define (move-same-file coord path node-id dest-container-id expected-revision)

922 (let ((doc (read-doc coord path (format "document ~a" (path-basename path)))))

923 (if (txn-refusal? doc)

924 doc

925 (let ((bytes (list-ref doc 0)) (text (list-ref doc 1))

926 (rev (list-ref doc 2)) (d (list-ref doc 3)))

927 (cond

928 ((not (equal? rev expected-revision))

929 (%txn-refuse 'structural-revision-mismatch

930

                              (format "expected ~a at revision ~a but it is at ~a; structural edits never rebase (amendment 1)"

931 path expected-revision rev)

932 current-revision: rev))

933 (else

934 (let ((node (movable-node d text node-id rev)))

935 (if (txn-refusal? node)

936 node

937 (let ((dest (find-container d text dest-container-id rev)))

938 (cond

939 ((txn-refusal? dest) dest)

940 ((not (memq (inspected-node-name dest) container-kinds-for-insert))

941 (%txn-refuse 'scoped-out

942

                                          (format "moving into a ~a is SCOPED OUT of F3b by ruling" (inspected-node-name dest))

943 current-revision: rev))

944 (else

945 (let* ((sp (inspected-node-span node))

946 (del-start (span-scalar-start sp))

947 (del-end (span-scalar-end sp))

948 (moved-text (substring text del-start del-end))

949 (insert-at (%txn-body-insertion-point text dest)))

950 (cond

951 ((not insert-at)

952 (%txn-refuse 'update-target-has-no-body

953 (format "container ~s has no body to move into" dest-container-id)

954 current-revision: rev))

955 ((and (>= insert-at del-start) (<= insert-at del-end))

956 (%txn-refuse 'move-into-self

957 (format "~s cannot be moved into its own extent" node-id)

958 current-revision: rev))

959 (else

960 (let* ((after-delete (%txn-splice text del-start del-end ""))

961 (adj (if (> insert-at del-end)

962 (- insert-at (- del-end del-start))

963 insert-at))

964 (staged (%txn-splice after-delete adj adj

965 (string-append "\n" moved-text "\n")))

966 (lo (if (< adj del-start) adj del-start))

967 (hi-scalar (if (> del-end insert-at) del-end insert-at))

968 (byte-lo (%txn-scalar->byte-offset text lo))

969 (byte-hi (%txn-scalar->byte-offset text hi-scalar))

970 (bad (%txn-verify-staged coord path bytes text rev

971 staged (descriptor-ids d)

972 byte-lo (- byte-hi byte-lo) 0

973 (lambda (staged-d)

974

                                                                      (move-check staged-d node-id dest-container-id rev))

975 'postcheck-failed

976 (descriptor-node-count d)

977 #f '())))

978 (if bad

979 bad

980 (let* ((staged-bytes (string->utf8 staged))

981 (new-rev (revision-of-bytes staged-bytes)))

982 (%txn-publish! path staged-bytes)

983 (sop-result-record

984 op: 'move-node

985 files: (list (sop-file path rev new-rev

986 (%txn-make-line-diff text staged)))

987 node-id: node-id

988 detail: (format "moved ~s into ~s (same file)" node-id dest-container-id)

989 recovery: '()))))))))))))))))))

990

991 (define (move-check staged-d node-id dest-container-id rev)

992 (let ((c2 (let walk ((pending (descriptor-nodes staged-d)))

993 (cond ((null? pending) #f)

994 ((node-carries-id? (car pending) dest-container-id) (car pending))

995 (else (walk (append (inspected-node-children (car pending))

996 (cdr pending))))))))

997 (cond

998 ((not (eq? (descriptor-id-status staged-d node-id) 'unique))

999 (%txn-refuse 'postcheck-failed

1000 (format "~s is not uniquely declared after the move" node-id)

1001 current-revision: rev))

1002 ((not c2)

1003 (%txn-refuse 'postcheck-failed

1004 (format "destination container ~s vanished" dest-container-id)

1005 current-revision: rev))

1006 ((not (let walk ((pending (inspected-node-children c2)))

1007 (cond ((null? pending) #f)

1008 ((equal? (inspected-node-id (car pending)) node-id) #t)

1009 (else (walk (append (inspected-node-children (car pending))

1010 (cdr pending)))))))

1011 (%txn-refuse 'postcheck-failed

1012 (format "~s did not land inside ~s" node-id dest-container-id)

1013 current-revision: rev))

1014 (else #f))))

1015

1016 (define (move-cross-file coord source-path node-id dest-path dest-container-id

1017 expected-source-revision expected-dest-revision)

1018 (let ((sdoc (read-doc coord source-path "the source document")))

1019 (if (txn-refusal? sdoc)

1020 sdoc

1021 (let ((ddoc (read-doc coord dest-path "the destination document")))

1022 (if (txn-refusal? ddoc)

1023 ddoc

1024 (let ((s-bytes (list-ref sdoc 0)) (s-text (list-ref sdoc 1))

1025 (s-rev (list-ref sdoc 2)) (s-d (list-ref sdoc 3))

1026 (d-bytes (list-ref ddoc 0)) (d-text (list-ref ddoc 1))

1027 (d-rev (list-ref ddoc 2)) (d-d (list-ref ddoc 3)))

1028 (cond

1029 ((not (equal? s-rev expected-source-revision))

1030 (%txn-refuse 'structural-revision-mismatch

1031

                                    (format "source ~a moved past the expected revision; structural edits never rebase" source-path)

1032 current-revision: s-rev))

1033 ((and expected-dest-revision (not (equal? d-rev expected-dest-revision)))

1034 (%txn-refuse 'structural-revision-mismatch

1035 (format "destination ~a moved past the expected revision" dest-path)

1036 current-revision: d-rev))

1037 (else

1038 (let ((node (movable-node s-d s-text node-id s-rev)))

1039 (if (txn-refusal? node)

1040 node

1041 (move-cross-with-node coord source-path dest-path

1042 dest-container-id node-id node

1043 s-bytes s-text s-rev s-d

1044 d-bytes d-text d-rev d-d)))))))))))

1045

1046 (define (move-cross-with-node coord source-path dest-path dest-container-id

1047 node-id node s-bytes s-text s-rev s-d

1048 d-bytes d-text d-rev d-d)

1049 (let* ((moved-ids (cons node-id (filter string? (%txn-subtree-declared-ids node))))

1050 (dest (find-container d-d d-text dest-container-id d-rev)))

1051 (cond

1052 ((txn-refusal? dest) dest)

1053 ((not (memq (inspected-node-name dest) container-kinds-for-insert))

1054 (%txn-refuse 'scoped-out

1055 (format "moving into a ~a is SCOPED OUT of F3b by ruling" (inspected-node-name dest))

1056 current-revision: d-rev))

1057 ;; The moved ids must be fresh in the destination document.

1058 ((let lp ((ids moved-ids))

1059 (cond ((null? ids) #f)

1060 ((not (eq? (descriptor-id-status d-d (car ids)) 'absent)) (car ids))

1061 (else (lp (cdr ids)))))

1062 => (lambda (id)

1063 (%txn-refuse 'insert-id-taken

1064 (format "id ~s already exists in the destination document" id)

1065 current-revision: d-rev)))

1066 (else

1067 ;; Referrer accounting root-wide: every occurrence of the moved

1068 ;; ids must be a rewritable document-scoped reference, the

1069 ;; declaration itself, or nothing -- the same absolute refusal

1070 ;; discipline as rename.

1071 (let* ((root (coordinator-root coord))

1072 (population (root-population coord))

1073 (guard-refusal (population-guard coord (car population)))

1074 (entries (cdr population))

1075 (found (find-referrers coord entries moved-ids))

1076 (semantic (list-ref found 0))

1077 (raw-only (list-ref found 1))

1078 (troubles (list-ref found 2)))

1079 (cond

1080 (guard-refusal guard-refusal)

1081 ((pair? troubles)

1082 (%txn-refuse 'referrer-uninspectable

1083 (format "cannot account for every occurrence of ~a: ~a" moved-ids troubles)

1084 retryable: #t))

1085 ((pair? raw-only)

1086 (%txn-refuse 'unrewritable-reference

1087

                              (format "moving ~s would strand raw occurrence(s): ~a -- refused, no override" node-id raw-only)))

1088 (else

1089 (stage-cross-move coord root entries source-path dest-path

1090 dest-container-id dest node-id node semantic

1091 s-bytes s-text s-rev s-d

1092 d-bytes d-text d-rev d-d))))))))

1093

1094 (define (stage-cross-move coord root entries source-path dest-path

1095 dest-container-id dest node-id node semantic

1096 s-bytes s-text s-rev s-d

1097 d-bytes d-text d-rev d-d)

1098 (let* ((source-rel (path-relative root source-path))

1099 (dest-rel (path-relative root dest-path))

1100 ;; The document identity a reference names is the D12 DOCUMENT

1101 ;; ADDRESS -- the declared id of the ROOT NODE owning the moved

1102 ;; node (`@note["topics/f3a-fixture" ...]`), NOT the file's slug.

1103 ;; The first spelling here used the filesystem slug and the

1104 ;; smoke's own watcher fixture refuted it immediately.

1105 (source-slug (owning-root-id s-d node))

1106 (dest-slug (owning-root-id d-d dest))

1107 (sp (inspected-node-span node))

1108 (del-start (span-scalar-start sp))

1109 (del-end (span-scalar-end sp))

1110 (moved-text (substring s-text del-start del-end))

1111 (insert-at (%txn-body-insertion-point d-text dest)))

1112 (cond

1113 ((not insert-at)

1114 (%txn-refuse 'update-target-has-no-body

1115 (format "container ~s has no body to move into" dest-container-id)

1116 current-revision: d-rev))

1117 ((not source-slug)

1118 (%txn-refuse 'postcheck-failed

1119 "the moved node's owning root declares no document id; its references cannot be re-addressed"

1120 current-revision: s-rev))

1121 ((not dest-slug)

1122 (%txn-refuse 'postcheck-failed

1123

                        "the destination's owning root declares no document id; references to the moved node could not name it there"

1124 current-revision: d-rev))

1125 (else

1126 (let* ((staged-source (%txn-splice s-text del-start del-end ""))

1127 (staged-dest (%txn-splice d-text insert-at insert-at

1128 (string-append "\n" moved-text "\n")))

1129 ;; Rewrite each referrer's `document:` field where it names

1130 ;; the SOURCE slug for one of the moved ids (a reference in

1131 ;; the source or dest document themselves is handled on the

1132 ;; already-staged text below, so those are excluded here).

1133 (ref-files (referrer-document-rewrites entries semantic

1134 source-rel dest-rel

1135 source-slug dest-slug))

1136 (staged-list

1137 (append

1138 (list (list source-rel source-path s-bytes staged-source)

1139 (list dest-rel dest-path d-bytes staged-dest))

1140 (if (txn-refusal? ref-files) '() ref-files))))

1141 (if (txn-refusal? ref-files)

1142 ref-files

1143 ;; Verify: source lost the ids, dest gained them uniquely.

1144 (let ((bad (or (verify-move-side coord source-rel s-bytes s-text s-rev s-d

1145 staged-source node-id 'gone

1146 (cons node-id (filter string? (%txn-subtree-declared-ids node))))

1147 (verify-move-side coord dest-rel d-bytes d-text d-rev d-d

1148 staged-dest node-id 'present '()))))

1149 (if bad

1150 bad

1151 (let* ((txn-id (content-txn-id "move-node"

1152 (list node-id source-rel dest-rel s-rev)))

1153 (published (publish-file-set! coord txn-id "move-node" staged-list)))

1154 (sop-result-record

1155 op: 'move-node

1156 files: (map (lambda (p)

1157 (sop-file (list-ref p 0) (list-ref p 1) (list-ref p 2) #f))

1158 published)

1159 node-id: node-id

1160 detail: (format "moved ~s from ~a to ~a (container ~s); ~a referrer file(s) redirected"

1161 node-id source-rel dest-rel dest-container-id

1162 (- (length staged-list) 2))

1163 recovery: '()))))))))))

1164

1165 ;; The id of the top-level root whose subtree holds `node` (by identity).

1166 ;; #f when the root declares no id -- callers refuse on it.

1167 (define (owning-root-id d node)

1168 (let roots ((rest (descriptor-nodes d)))

1169 (cond

1170 ((null? rest) #f)

1171 ((let walk ((pending (list (car rest))))

1172 (cond ((null? pending) #f)

1173 ((eq? (car pending) node) #t)

1174 (else (walk (append (inspected-node-children (car pending))

1175 (cdr pending))))))

1176 (inspected-node-id (car rest)))

1177 (else (roots (cdr rest))))))

1178

1179 (define (strip-format-extension rel)

1180 (let ((n (string-length rel)))

1181 (cond ((and (> n 4) (equal? (substring rel (- n 4) n) ".sgd")) (substring rel 0 (- n 4)))

1182 ((and (> n 3) (equal? (substring rel (- n 3) n) ".md")) (substring rel 0 (- n 3)))

1183 (else rel))))

1184

1185 ;; Build staged rewrites of referrer files' `document:` fields. Returns

1186 ;; a list of (rel abs pre-bytes staged-text) or a refusal.

1187 (define (referrer-document-rewrites entries semantic source-rel dest-rel

1188 source-slug dest-slug)

1189 (let loop ((rels (let dedupe ((rest semantic) (out '()))

1190 (cond ((null? rest) (reverse out))

1191 ((or (equal? (car (car rest)) source-rel)

1192 (equal? (car (car rest)) dest-rel)

1193 (member (car (car rest)) out))

1194 (dedupe (cdr rest) out))

1195 (else (dedupe (cdr rest) (cons (car (car rest)) out))))))

1196 (out '()))

1197 (if (null? rels)

1198 (reverse out)

1199 (let* ((rel (car rels))

1200 (entry (assoc-entry entries rel))

1201 (bytes (list-ref entry 3))

1202 (text (utf8->string bytes))

1203 (sites (let lp ((rest semantic) (acc '()))

1204 (cond ((null? rest) (reverse acc))

1205 ((equal? (car (car rest)) rel)

1206 (lp (cdr rest) (cons (cdr (car rest)) acc)))

1207 (else (lp (cdr rest) acc)))))

1208 ;; Each site: (node field) -- rewrite the sibling

1209 ;; `document` field when it names the source slug.

1210 (doc-spans

1211 (let lp ((rest sites) (acc '()))

1212 (if (null? rest)

1213 (reverse acc)

1214 (let* ((n (list-ref (car rest) 0))

1215 (df (let f ((fs (inspected-node-fields n)))

1216 (cond ((null? fs) #f)

1217 ((eq? (field-name (car fs)) 'document) (car fs))

1218 (else (f (cdr fs)))))))

1219 (cond

1220 ((not df) (lp (cdr rest) acc))

1221 ((not (equal? (field-value df) source-slug))

1222 ;; Points at a different document carrying the

1223 ;; same id -- impossible under the freshness

1224 ;; checks above, refused defensively.

1225 (%txn-refuse 'postcheck-failed

1226

                                             (format "a reference in ~a pairs the moved id with document ~s, not the source ~s"

1227 rel (field-value df) source-slug)))

1228 ((not (field-span df))

1229 (%txn-refuse 'rebase-span-invalid

1230 (format "a document: field in ~a has no span" rel)))

1231 (else (lp (cdr rest) (cons (field-span df) acc)))))))))

1232 (if (txn-refusal? doc-spans)

1233 doc-spans

1234 (let* ((replacement (%txn-escape-string-literal dest-slug))

1235 (ordered (sort-spans-desc doc-spans))

1236 (staged (let sp ((rest ordered) (s text))

1237 (if (null? rest) s

1238 (sp (cdr rest)

1239 (%txn-splice s (span-scalar-start (car rest))

1240 (span-scalar-end (car rest))

1241 replacement))))))

1242 (loop (cdr rels)

1243 (cons (list rel (list-ref entry 1) bytes staged) out))))))))

1244

1245 (define (verify-move-side coord rel bytes text rev d staged node-id expect allowed-lost)

1246 (%txn-verify-staged coord rel bytes text rev staged (descriptor-ids d)

1247 0 (bytevector-length bytes)

1248 0

1249 (lambda (staged-d)

1250 (cond

1251 ((and (eq? expect 'gone)

1252 (not (eq? (descriptor-id-status staged-d node-id) 'absent)))

1253 (%txn-refuse 'postcheck-failed

1254 (format "~s still in the source after the move" node-id)

1255 current-revision: rev))

1256 ((and (eq? expect 'present)

1257 (not (eq? (descriptor-id-status staged-d node-id) 'unique)))

1258 (%txn-refuse 'postcheck-failed

1259 (format "~s not uniquely present in the destination" node-id)

1260 current-revision: rev))

1261 (else #f)))

1262 'postcheck-failed

1263 (descriptor-node-count d)

1264 #f allowed-lost))))

1265