test/test-folio-doc-model.sgl

1;;; F1a -- the frozen `folio/doc` semantic model.

2;;;

3;;; Two instruments run over the same pressure manuscript on purpose. The

4;;; canonical DATUM is nested and lossless; the EVENT stream is flat and lossy.

5;;; A defect that satisfies both is much harder to construct than one that

6;;; satisfies a value compared against a re-serialization of itself.

7;;;

8;;; Locations are deliberately NOT part of the exact-datum literal. Hand-writing

9;;; byte offsets would be unreadable and would go stale on any manuscript edit --

10;;; the classic "check restates a number the artifact already knows". Instead

11;;; locations get their own EXHAUSTIVE arm: every located node's recorded span is

12;;; sliced back out of the real source file and compared to the text it was built

13;;; from. Stripping them from the literal is safe only because that arm exists,

14;;; and a positive control below proves the stripping is not hiding their absence.

15;;; WHY THE HTML AND TYPST ARMS ARE NOT IN THIS FILE. Measured, not assumed:

16;;; `(sigil doc render html)` imports `(sigil doc presentation)`, which imports

17;;; `(sigil doc verify)`, which imports `(sigil shell)`. Under `sigil test` that

18;;; library does not resolve for this package and the whole file fails to LOAD --

19;;; which would take every arm below down with it, silently trading 25 real

20;;; assertions for one load error. Those two renderings are asserted instead by

21;;; `test/f1a-publication-probe.sgl`, which the gate runs as a direct script

22;;; where the library does resolve. Splitting them also means the publication

23;;; fallback is proved through a DIFFERENT invocation path than the model suite.

24;;; `(folio doc)` re-exports the whole `(sigil doc)` surface, so it is the only

25;;; document import needed here -- which is itself a small check that the

26;;; profile's public face is complete.

27(import (sigil test) (sigil core) (sigil fs) (sigil syntax) (folio doc))

28(load "test/fixtures/folio-pressure.sgl")

30;; ---------------------------------------------------------------------------

31;; helpers

32;; ---------------------------------------------------------------------------

33(define (source-tuple? x) (and (pair? x) (eq? (car x) 'source)))

34(define (strip-locations value)

35 (cond ((source-tuple? value) 'source)

36 ((pair? value) (map strip-locations value))

37 (else value)))

38(define (contains-source-tuple? value)

39 (cond ((source-tuple? value) #t)

40 ((pair? value) (let loop ((xs value))

41 (cond ((not (pair? xs)) #f)

42 ((contains-source-tuple? (car xs)) #t)

43 (else (loop (cdr xs))))))

44 (else #f)))

45(define (member-of? x xs) (and (memq x xs) #t))

46(define (intersection a b)

47 (let loop ((xs a) (out '()))

48 (cond ((null? xs) (reverse out))

49 ((memq (car xs) b) (loop (cdr xs) (cons (car xs) out)))

50 (else (loop (cdr xs) out)))))

51(define (string-has? haystack needle)

52 (let ((h (string-length haystack)) (n (string-length needle)))

53 (let loop ((i 0))

54 (cond ((> (+ i n) h) #f)

55 ((string=? needle (substring haystack i (+ i n))) #t)

56 (else (loop (+ i 1)))))))

57(define a-loc (locate-text "@task[\"t-note01\" status: ready priority: low]"))

59;; ---------------------------------------------------------------------------

60;; Locations: EVERY located node, not a sample.

61;; ---------------------------------------------------------------------------

62(test "every recorded span slices back to the exact source it was built from"

63 (assert-true (> (length fixture-location-expectations) 60))

64 (for-each

65 (lambda (entry)

66 (let ((node (car entry)) (needle (cadr entry)))

67 (assert-equal needle (source-slice-at (folio-node-location node)))))

68 fixture-location-expectations))

70;; The astral-plane emoji makes byte position and scalar column disagree by

71;; three. A model that stored character indices in a byte field would still

72;; pass every ASCII case above and fail here.

73(test "unicode spans are byte positions, not character indices"

  (let* ((needle "Several scripts at once, so that byte spans and scalar columns disagree:\nκαλημέρα κόσμε, 日本語のテキスト, and a rocket 🚀 far past the basic plane.")

75 (loc (locate-text needle)))

76 (assert-equal needle (source-slice-at loc))

77 ;; The byte span exceeds the scalar length precisely because of the

78 ;; non-ASCII runs; if these were equal the fixture would be measuring ASCII.

79 (assert-true (> (srcloc-span loc) (string-length needle)))))

81;; LINE AND COLUMN WERE NEVER ASSERTED ANYWHERE before review: the exhaustive

82;; span arm uses only position+span, and the datum test strips the whole

83;; `(source …)` tuple. A `locate-text` returning line 1 column 1 for every node

84;; would have passed all thirty tests. These pin real values on nodes that sit

85;; before and after the astral-plane character, so a scalar/byte confusion in

86;; the column counter cannot hide behind the ASCII-only cases.

87(test "locations carry real line and column, not placeholders"

88 (let ((early (locate-text "@project[\"projects/folio-sigil-doc\""))

89 (late (locate-text "@transclude[node: \"t-f1a01\"]")))

90 (assert-equal 1 (srcloc-column early))

91 (assert-equal 3 (srcloc-line early))

92 (assert-equal 1 (srcloc-column late))

93 ;; The note root sits well past the emoji, so its line must be far from 1.

94 (assert-true (> (srcloc-line late) 130))

95 ;; Column is a SCALAR count: a node indented by one tab-free space starts at

96 ;; column 1, and the two differ in line but not column, which is only

97 ;; meaningful because the lines themselves differ.

98 (assert-true (> (srcloc-line late) (srcloc-line early)))

99 ;; And the byte position must outrun the scalar index by exactly the

100 ;; multi-byte weight accumulated before it.

101 (assert-true (> (srcloc-position late) (srcloc-line late)))))

102

103;; ---------------------------------------------------------------------------

104;; Canonical form

105;; ---------------------------------------------------------------------------

106(test "canonical datum of the note root is exact"

107 (assert-equal

108 '(note (id "topics/folio-doc-freeze-notes")

109 (title "Notes taken while freezing the model")

110 (tags "folio" "freeze" "0.1")

111 (children

112

             (paragraph (children (text "Metadata on a note is ordinary declared data: an address for identity, a title\nfor the outline, and tags for filtering, none of it computed by author code." source)) source)

113 (related (kind mentions) (document "projects/folio-sigil-doc") (node "t-f1a01")

114 (label (text "the freeze task" source)) source)

115 (task (id "t-note01") (title "Record the reopen gap for the mutation phase")

116 (status ready) (priority low) (tags) (due #f) (children) source)

117 (transclude (document #f) (node "t-f1a01") source))

118 source)

119 (strip-locations (folio->datum pressure-note))))

120

121;; POSITIVE CONTROL for the arm above: `strip-locations` collapses `(source …)`

122;; tuples, so an implementation that emitted NO locations at all would produce a

123;; literal that still matched. This proves the tuples are really there.

124(test "the canonical datum really does carry locations"

125 (assert-true (contains-source-tuple? (folio->datum pressure-note)))

126 (assert-true (contains-source-tuple? (folio->datum pressure-project))))

127

128(test "debug rendering is the canonical string, not a second serialization"

129 (assert-equal (folio->string pressure-project) (folio->debug pressure-project))

130 (assert-equal (folio->string pressure-note) (folio->debug pressure-note)))

131

132(test "the event stream of the whole project is exact"

133 (assert-equal

134 '((project "projects/folio-sigil-doc" active)

135

      (text "Turn Folio from a Markdown-convention server into a local-first semantic\nknowledge workspace whose canonical source is ")

136 (text "(folio doc model)")

137 (related follows-procedure "procedures/plan-driven-execution-loop" #f)

138 (text "the plan-driven execution loop")

139 (related governed-by-workflow "topics/folio-architecture" "t-arch01")

140 (term "source-of-truth")

141 (text "Authored source files")

142

      (text " are authoritative, and every derived table is\ndisposable: deleting the index and rebuilding it must produce the same graph.")

143 (milestone "m-first-edition" active)

144 (phase "p-freeze-estate" 1 done)

145 (task "t-f0a1" done high)

146 (update "u-f0review" "2026-08-10T09:14:00Z" "fable" "3a7a0eb")

147 (text "Independent re-execution in a detached worktree reproduced every recorded count.")

148 (phase "p-freeze-model" 2 active)

149

      (text "The vocabulary frozen in this phase is deliberately small, because a universal\nontology is not a first-edition deliverable.")

150 (task "t-f1a01" active high)

151 (related blocks #f "t-f1a02")

152 (task "t-f1a02" ready medium)

153 (task "t-f1a03" blocked low)

154 (related depends-on "topics/sigil-doc-passive-parse-api" #f)

155 (task "t-f1a04" inbox #f)

156 (task "t-f1a05" cancelled #f)

157 (decision "d-profile" accepted)

158 (text "Reusing one surface grammar is what makes a single toolchain pay off in five\ndifferent places at once.")

159 (related supports "topics/folio-sigil-doc-implementation-plan" "d-one")

160 (decision "d-flat-ids" superseded)

161 (decision "d-compact-address" rejected)

162 (text "Only a form that can be semantically reasoned about should be spelled at all.")

163 (decision "d-reopen-policy" proposed)

164

      (text "Today the transition relation admits no edge out of a finished item, while the\nshipping product still offers to reopen one, so one of the two has to move.")

165 (decision "d-two-grammars" accepted)

166 (related supersedes #f "d-flat-ids")

167 (question "q-compact-address" answered)

168

      (text "Answered no for the first edition: only a form that can be semantically reasoned\nabout is spelled at all, so the explicit two-part address is the only one.")

169 (question "q-reopen" open)

170 (text "The frozen relation ")

171 (text "task-transition-allowed?")

172 (text " draws no edge out of a\nfinished item, while the shipping product still offers to reopen one.")

173 (phase "p-passive-inspect" 3 planned)

174 (text "Trust levels")

175 (text "trust level")

176 (text "what it may do")

177 (text "passive tier")

178 (text "parse syntax and inspect declared fields")

179 (text "trusted tier")

180 (text "evaluate author forms after an explicit grant")

181 (task "t-f2a01" ready #f)

182 (question "q-subject-index" deferred)

183 (phase "p-publication" 4 paused)

184 (text "Where the rules actually live")

185 (text "Rules are referenced rather than reproduced, as in ")

186 (reference "reading")

187 (text "this very section")

188 (text ",\nand the published plan lives at ")

189 (url-link "https://codeberg.org/sigil/folio")

190 (text "the folio repository")

191 (text "Source fidelity: untouched bytes stay exact.")

192 (text "Identity: a move never changes a stable local id.")

193 (text "Honesty about derived state: rebuilding yields the same answers.")

194 (text "(folio-update-field! coordinator id: \"t-f1a01\" field: 'status value: 'done)")

195 (glossary)

196 (text "Locations that are not ASCII")

197

      (text "Several scripts at once, so that byte spans and scalar columns disagree:\nκαλημέρα κόσμε, 日本語のテキスト, and a rocket 🚀 far past the basic plane.")

198 (task "t-unicode" ready #f)

199 (query "q-ready-work")

200 (transclude "topics/instrument-failure-taxonomy" "s-shape-15"))

201 (folio-events pressure-project)))

202

203;; The one place folio duplicates sigil-doc's logic is the per-node event

204;; mapping for core nodes, because the fold visits nodes one at a time. This

205;; arm is what stops the copy drifting from the original.

206(test "on a pure sigil-doc document, folio-events equals document-events"

207 ;; EVERY core kind `folio-events` classifies, not just the ones that happen to

208 ;; match. Review found the earlier version covered 6 of 12: `video`, `term`,

209 ;; `term-reference`, `glossary`, `example` and `project-check` were never in a

210 ;; document passed to the differential, so a change to any of their event

211 ;; shapes upstream would have left this arm green.

212 (let* ((loc a-loc)

213 (core (make-document 'article "Core only" '("Someone")

214 (list (make-paragraph (list (make-text "prose" loc)

215 (make-code "inline" loc)

216 (make-url-link "https://example.com/a" (list (make-text "link" loc)) loc)

217 (make-term-reference "a-term" #f loc)

218 (make-reference "target" #f loc))

219 loc)

220 (make-anchor "target" loc)

221 (make-code-block "sigil" "(display 1)" loc)

222 (make-video "https://example.com/v" 'url #f 'omit loc)

223 (make-term "a-term" "A term" '("alias")

224 (list (make-paragraph (list (make-text "definition" loc)) loc)) loc)

225 (make-glossary loc)

226 (make-example "an-example" 'inline "(display 1)" "sigil" #f 'bytecode

227 'stdout "1" "" 5 'source loc)

228 (make-project-check "a-check" "." (list "main.sgl") 'dev 'bytecode "ok" 5 loc))

229 loc)))

230 ;; Only the EVENTS half is a real differential: `folio-events` reimplements

231 ;; sigil-doc's per-node mapping, so the two can drift. The datum half was

232 ;; asserted here before review and was a tautology -- `folio->datum`'s else

233 ;; branch IS `(document->datum n)`, so it compared an expression with itself

234 ;; and could not fail. Removed rather than left looking like evidence.

235 (assert-equal (document-events core) (folio-events core))))

236

237;; The model reimplements sigil-doc's unexported `valid-id?` as `valid-node-id?`.

238;; This is the differential that keeps the copy honest: over an enumerated

239;; candidate set, our predicate must agree CASE BY CASE with whether sigil-doc's

240;; own `make-anchor` accepts the same string. If sigil-doc's grammar moves, this

241;; goes red instead of the two silently diverging.

242(test "the node-id grammar agrees with sigil-doc's own valid-id?"

243 (let* ((loc a-loc)

244 (candidates (list "t-a3f2" "first-script" "0abc" "a-b-c" "z" "9"

245 "topics/foo" "Topics" "a--b" "trailing-" "-leading"

246 "a.b" "a_b" "a b" "" "a#b" "../x" "UPPER" "aBc"))

247 (ours (map valid-node-id? candidates))

248 (theirs (map (lambda (c)

249 (guard (e (#t #f)) (make-anchor c loc) #t))

250 candidates)))

251 (assert-equal theirs ours)

252 ;; POSITIVE CONTROL: the candidate set must contain BOTH accepted and

253 ;; rejected strings, or agreement is free.

254 (assert-true (member-of? #t ours))

255 (assert-true (member-of? #f ours))))

256

257;; ---------------------------------------------------------------------------

258;; D12 -- the two grammars, and that they never become one

259;; ---------------------------------------------------------------------------

260(test "node ids stay flat and never admit a slash"

261 (assert-true (valid-node-id? "t-a3f2"))

262 (assert-true (valid-node-id? "p-freeze-model"))

263 (assert-true (valid-node-id? "0abc"))

264 (assert-true (not (valid-node-id? "topics/foo")))

265 (assert-true (not (valid-node-id? "Topics")))

266 (assert-true (not (valid-node-id? "a--b")))

267 (assert-true (not (valid-node-id? "trailing-")))

268 (assert-true (not (valid-node-id? "a.b")))

269 (assert-true (not (valid-node-id? ""))))

270

271(test "document addresses are a separate grammar admitting slash and interior dot"

272 (assert-true (valid-document-id? "topics/folio-architecture"))

273 (assert-true (valid-document-id? "archive/tasks/kiln-push-triggers"))

274 (assert-true (valid-document-id? "sigil-as-a-language-people-can-love-to-write"))

275 ;; The seven real version-numbered notes in the estate.

276 (assert-true (valid-document-id? "topics/sigil-1.0-security-review"))

277 (assert-true (valid-document-id? "topics/sigil-cps-dce-bce-v0.14.5-baseline"))

278 ;; Refusals that matter.

279 (assert-true (not (valid-document-id? "../etc/passwd")))

280 (assert-true (not (valid-document-id? ".claude/rules/folio-link-syntax")))

281 (assert-true (not (valid-document-id? "topics//foo")))

282 (assert-true (not (valid-document-id? "topics/foo/")))

283 (assert-true (not (valid-document-id? "topics/foo..bar")))

284 (assert-true (not (valid-document-id? "Topics/Foo")))

285 (assert-true (not (valid-document-id? "enclave-latency--scale"))))

286

287;; D12's SUB-RULING: there is no compact `#` address spelling in the first

288;; edition. It is refused by the grammar, so it cannot be smuggled through any

289;; constructor that takes a document address.

290(test "the compact hash address spelling is refused everywhere it could appear"

291 (assert-true (not (valid-document-id? "topics/foo#t-a3f2")))

292 (assert-error (make-related "topics/foo#t-a3f2" #f 'related-to #f a-loc))

293 (assert-error (make-transclude "topics/foo#t-a3f2" #f a-loc))

294 (assert-error (make-note "topics/foo#t-a3f2" "Title" '() '() a-loc))

295 ;; and a slashed value can never be accepted where a NODE id belongs

296 (assert-error (make-related #f "topics/foo" 'related-to #f a-loc))

297 (assert-error (make-task "topics/foo" "Title" 'ready #f '() #f '() a-loc)))

298

299;; ---------------------------------------------------------------------------

300;; D6 -- `ready` is a state, and priority is not

301;; ---------------------------------------------------------------------------

302(test "the priority set is disjoint from every status set"

303 (let ((priorities (folio-task-priorities)))

304 (assert-equal '() (intersection priorities (folio-task-statuses)))

305 (assert-equal '() (intersection priorities (folio-container-statuses)))

306 (assert-equal '() (intersection priorities (folio-decision-statuses)))

307 (assert-equal '() (intersection priorities (folio-question-statuses)))

308 ;; POSITIVE CONTROL: the intersection helper can actually find an overlap,

309 ;; so the four empty results above are evidence rather than a free pass.

310 (assert-equal '(ready) (intersection '(ready) (folio-task-statuses)))))

311

312(test "ready is a status, never a priority, and next does not exist"

313 (assert-true (task-status? 'ready))

314 (assert-true (not (task-priority? 'ready)))

315 (assert-true (not (task-status? 'next)))

316 (assert-true (not (member-of? 'next (folio-task-statuses))))

317 (assert-error (make-task "t-x" "T" 'next #f '() #f '() a-loc))

318 ;; a priority passed where a status belongs, and the reverse

319 (assert-error (make-task "t-x" "T" 'high #f '() #f '() a-loc))

320 (assert-error (make-task "t-x" "T" 'ready 'ready '() #f '() a-loc)))

321

322(test "the frozen transition relation is exactly D6's diagram"

323 (assert-true (task-transition-allowed? 'inbox 'ready))

324 (assert-true (task-transition-allowed? 'ready 'active))

325 (assert-true (task-transition-allowed? 'active 'blocked))

326 (assert-true (task-transition-allowed? 'blocked 'ready))

327 (assert-true (task-transition-allowed? 'blocked 'active))

328 (assert-true (task-transition-allowed? 'ready 'done))

329 (assert-true (task-transition-allowed? 'active 'cancelled))

330 ;; refusals

331 (assert-true (not (task-transition-allowed? 'inbox 'active)))

332 (assert-true (not (task-transition-allowed? 'inbox 'done)))

333 (assert-true (not (task-transition-allowed? 'blocked 'done)))

334 ;; REOPEN EDGES -- these two assertions asserted refusal until 2026-08-25.

335 ;; The flip is a RULING, not a weakened test: D6 was amended 2026-08-11

336 ;; (decisions/2026-08-11-reopen-is-an-update-not-a-state) to add

337 ;; `done -> ready` and `cancelled -> ready`. Destination is `ready`, an

338 ;; EXISTING state -- there is NO `reopened` state -- and the event is

339 ;; recorded as an `@update` that F3 lands atomically with the transition.

340 (assert-true (task-transition-allowed? 'done 'ready))

341 (assert-true (task-transition-allowed? 'cancelled 'ready))

342 ;; ... and `ready` is the ONLY exit from a finished item: the ruling added

343 ;; exactly two edges, not a general thaw.

344 (assert-true (not (task-transition-allowed? 'done 'active)))

345 (assert-true (not (task-transition-allowed? 'done 'done)))

346 (assert-true (not (task-transition-allowed? 'done 'cancelled)))

347 (assert-true (not (task-transition-allowed? 'cancelled 'active)))

348 (assert-true (not (task-transition-allowed? 'cancelled 'done)))

349 (assert-true (not (task-transition-allowed? 'ready 'next))))

350

351;; ---------------------------------------------------------------------------

352;; Containment: structural containers nest downward only

353;; ---------------------------------------------------------------------------

354(test "a phase may not contain a phase or a milestone"

355 (let* ((loc a-loc)

356 (inner (make-phase "p-inner" "Inner" 'planned 1 '() loc))

357 (stone (make-milestone "m-inner" "Inner" 'planned '() loc)))

358 (assert-error (make-phase "p-outer" "Outer" 'planned 1 (list inner) loc))

359 (assert-error (make-phase "p-outer" "Outer" 'planned 1 (list stone) loc))

360 ;; but a project and a milestone may both hold a phase

361 (assert-true (phase? (car (project-children

362 (make-project "projects/p" "P" 'active '() (list inner) loc)))))

363 (assert-true (phase? (car (milestone-children

364 (make-milestone "m-outer" "Outer" 'planned (list inner) loc)))))))

365

366(test "a work item may not contain a structural container"

367 (let* ((loc a-loc)

368 (ph (make-phase "p-inner" "Inner" 'planned 1 '() loc))

369 (stone (make-milestone "m-inner" "Inner" 'planned '() loc)))

370 (assert-error (make-task "t-x" "T" 'ready #f '() #f (list ph) loc))

371 (assert-error (make-task "t-x" "T" 'ready #f '() #f (list stone) loc))

372 (assert-error (make-decision "d-x" "D" 'proposed (list ph) loc))

373 ;; a note is a ROOT, so it may not appear as anyone's child either

374 (assert-error (make-task "t-x" "T" 'ready #f '() #f

375 (list (make-note "topics/n" "N" '() '() loc)) loc))))

376

377(test "a note may not contain a milestone or a phase"

378 (let* ((loc a-loc)

379 (ph (make-phase "p-inner" "Inner" 'planned 1 '() loc))

380 (stone (make-milestone "m-inner" "Inner" 'planned '() loc)))

381 (assert-error (make-note "topics/n" "N" '() (list ph) loc))

382 (assert-error (make-note "topics/n" "N" '() (list stone) loc))))

383

384;; An update is append-only narrative. A historical record that can contain a

385;; live work item stops being a record of what happened.

386(test "an update may not contain work items"

387 (let* ((loc a-loc)

388 (t (make-task "t-x" "T" 'ready #f '() #f '() loc)))

389 (assert-error (make-update #f "2026-08-11" #f #f (list t) loc))

390 ;; ordinary blocks and relationships are fine

391 (assert-true (update? (make-update #f "2026-08-11" #f #f

392 (list (make-paragraph (list (make-text "narrative" loc)) loc)

393 (make-related #f "t-x" 'mentions #f loc))

394 loc)))))

395

396;; ---------------------------------------------------------------------------

397;; `phase` is an ORDERED, non-executable container

398;; ---------------------------------------------------------------------------

399(test "phase order must be positive, unique and strictly increasing in one parent"

400 (let* ((loc a-loc)

401 (p1 (make-phase "p-one" "One" 'done 1 '() loc))

402 (p2 (make-phase "p-two" "Two" 'active 2 '() loc))

403 (p2b (make-phase "p-two-b" "Two again" 'active 2 '() loc)))

404 (assert-true (project? (make-project "projects/p" "P" 'active '() (list p1 p2) loc)))

405 ;; out of order

406 (assert-error (make-project "projects/p" "P" 'active '() (list p2 p1) loc))

407 ;; duplicate slot

408 (assert-error (make-project "projects/p" "P" 'active '() (list p2 p2b) loc))

409 (assert-error (make-milestone "m-x" "M" 'active (list p2 p1) loc))

410 ;; zero and negative orders are not orders

411 (assert-error (make-phase "p-zero" "Zero" 'planned 0 '() loc))

412 (assert-error (make-phase "p-neg" "Neg" 'planned -1 '() loc))))

413

414(test "the pressure manuscript's phases are ordered 1, 2, 3, 4"

415 (let ((orders (let loop ((xs (milestone-children

416 (car (let find ((cs (project-children pressure-project)))

417 (if (milestone? (car cs)) cs (find (cdr cs)))))))

418 (out '()))

419 (cond ((null? xs) (reverse out))

420 ((phase? (car xs)) (loop (cdr xs) (cons (phase-order (car xs)) out)))

421 (else (loop (cdr xs) out))))))

422 ;; Derived from the milestone rather than pinned blind: the assertion is

423 ;; that the orders are exactly 1..n in document order, so adding a phase

424 ;; changes n without silently weakening the check.

425 (assert-equal (let count ((i 1) (out '()))

426 (if (> i (length orders)) (reverse out) (count (+ i 1) (cons i out))))

427 orders)

428 (assert-true (>= (length orders) 4))))

429

430;; ---------------------------------------------------------------------------

431;; Constructor misuse

432;; ---------------------------------------------------------------------------

433(test "constructors reject invalid semantic values"

434 (let ((loc a-loc))

435 (assert-error (make-note "Not An Address" "T" '() '() loc))

436 (assert-error (make-note "topics/n" "" '() '() loc))

437 (assert-error (make-note "topics/n" "T" (list "Bad Tag") '() loc))

438 (assert-error (make-project "projects/p" "P" 'running '() '() loc))

439 (assert-error (make-milestone "m x" "M" 'active '() loc))

440 (assert-error (make-phase "p-x" "P" 'active "1" '() loc))

441 (assert-error (make-task "t-x" "T" 'ready #f '() "not-a-date" '() loc))

442 (assert-error (make-decision "d-x" "D" 'maybe '() loc))

443 (assert-error (make-question "q-x" "Q" 'unknown '() loc))

444 (assert-error (make-update #f "11/08/2026" #f #f '() loc))

445 (assert-error (make-update #f "2026-08-11" #f "NOTHEX!" '() loc))

446 (assert-error (make-related #f #f 'related-to #f loc))

447 (assert-error (make-related "topics/f" #f "not-a-symbol" #f loc))

448 (assert-error (make-transclude #f #f loc))

449 ;; a label must be inline nodes, not blocks

450 (assert-error (make-related "topics/f" #f 'mentions

451 (list (make-paragraph (list (make-text "b" loc)) loc)) loc))

452 ;; locations are validated, not trusted

453 (assert-error (make-task "t-x" "T" 'ready #f '() #f '() "not-a-srcloc"))))

454

455;; A query carries DATA. This is the model's runtime passivity witness: nothing

456;; callable can be stored in a folio record, so reading a document cannot

457;; execute anything a document supplied.

458(test "a query spec may never carry code"

459 (let ((loc a-loc))

460 (assert-error (make-query "q-x" #f (lambda (x) x) loc))

461 (assert-error (make-query "q-x" #f (list 'and (lambda (x) x)) loc))

462 (assert-error (make-query "q-x" #f (list 'and (list 'status car)) loc))

463 (assert-error (make-query "q-x" #f (vector 1 2 3) loc))

464 (assert-true (query? (make-query "q-x" "T" '(and (kind task) (status ready)) loc)))

465 (assert-equal '(and (kind task) (status ready))

466 (query-spec (make-query "q-x" #f '(and (kind task) (status ready)) loc)))))

467

468;; An unresolved marker's whole job is to name what the reader cannot see, so a

469;; query with neither id nor title -- which rendered as a bare

470;; "[unresolved folio query]" and satisfied every marker assertion while naming

471;; nothing -- is refused at construction.

472(test "a query must carry an identity its unresolved marker can name"

473 (let ((loc a-loc))

474 (assert-error (make-query #f #f '(and) loc))

475 (assert-true (query? (make-query "q-x" #f '(and) loc)))

476 (assert-true (query? (make-query #f "Titled" '(and) loc)))

477 (assert-true (string-has? (unresolved-query-text (make-query "q-named" #f '(and) loc))

478 "q-named"))

479 (assert-true (string-has? (unresolved-query-text (make-query #f "Only a title" '(and) loc))

480 "Only a title"))))

481

482;; A spec is legally a bare scalar as well as a list. Consing it onto the field

483;; tag produced an IMPROPER list for those, making `query` the one node whose

484;; datum SHAPE varied with its value.

485(test "a scalar query spec still yields a proper datum"

486 (let* ((loc a-loc)

487 (d (folio->datum (make-query "q-scalar" #f 'inbox loc))))

488 (assert-equal '(query (id "q-scalar") (title #f) (spec inbox) source)

489 (strip-locations d))

490 (assert-true (list? d))

491 (assert-true (list? (car (cdr (cdr (cdr d))))))))

492

493;; ---------------------------------------------------------------------------

494;; Defensive ownership

495;; ---------------------------------------------------------------------------

496(test "aggregate ownership is mutation-proof on the way in and on the way out"

497 (let* ((loc a-loc)

498 (tag (string-copy "owned"))

499 (tags (list tag))

500 (child (make-paragraph (list (make-text "body" loc)) loc))

501 (children (list child))

502 (note (make-note "topics/owned" "Owned" tags children loc)))

503 ;; mutate the caller's inputs

504 (set-car! tags "changed")

505 (string-set! tag 0 #\X)

506 (set-car! children (make-text "wrong" loc))

507 (assert-equal '("owned") (note-tags note))

508 (assert-true (paragraph? (car (note-children note))))

509 ;; mutate what the accessors handed back

510 (let ((out-tags (note-tags note)) (out-children (note-children note)))

511 (set-car! out-tags "changed again")

512 (set-car! out-children (make-text "wrong again" loc))

513 (assert-equal '("owned") (note-tags note))

514 (assert-true (paragraph? (car (note-children note)))))

515 ;; strings are copied too, not shared

516 (let ((title (note-title note)))

517 (string-set! title 0 #\Z)

518 (assert-equal "Owned" (note-title note)))))

519

520(test "task, related and query aggregates are owned as well"

521 (let* ((loc a-loc)

522 (tags (list (string-copy "alpha")))

523 (t (make-task "t-own" "Owned task" 'ready 'high tags "2026-08-20" '() loc))

524 (label (list (make-text "label" loc)))

525 (r (make-related "topics/f" #f 'mentions label loc))

526 (spec (list 'and (list 'status 'ready)))

527 (q (make-query "q-owned" #f spec loc)))

528 (set-car! tags "changed")

529 (set-car! label (make-text "changed" loc))

530 (set-car! (cadr spec) 'kind)

531 (assert-equal '("alpha") (task-tags t))

532 (assert-equal "label" (text-content (car (related-label r))))

533 (assert-equal '(and (status ready)) (query-spec q))

534 (let ((out (task-tags t)))

535 (set-car! out "changed")

536 (assert-equal '("alpha") (task-tags t)))

537 ;; A location handed out must be a FRESH object, not the one the record

538 ;; holds. Before review this line compared `(srcloc-position (task-location

539 ;; t))` with itself, which passes even if the accessor returns the stored

540 ;; srcloc directly -- it was the only assertion for a property the module

541 ;; header advertises, and it could not fail.

542 (assert-true (not (eq? (task-location t) (task-location t))))

543 (assert-true (not (eq? (task-location t) loc)))

544 (assert-equal (srcloc-position loc) (srcloc-position (task-location t)))

545 (assert-equal (srcloc-span loc) (srcloc-span (task-location t)))))

546

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

548;; Publication fallback -- the document must still mean something with no Folio

549;; ---------------------------------------------------------------------------

550(define lowered-project (folio-document->publication pressure-project #f))

551(define lowered-note (folio-document->publication pressure-note #f))

552(define plain-project (folio->plain pressure-project))

553(define published-plain (document->plain lowered-project))

554

555(test "the lowering produces a real sigil-doc document, not a folio one"

556 (assert-true (document? lowered-project))

557 (assert-equal 'article (document-kind lowered-project))

558 (assert-true (document? lowered-note))

559 ;; every child is a core block node -- that is what makes it renderable by a

560 ;; backend that has never heard of a task

561 (for-each (lambda (child) (assert-true (block-node? child)))

562 (document-children lowered-project)))

563

564;; The failure this guards is SILENT: a lowering that dropped statuses would

565;; still produce valid HTML and a valid PDF, and would simply say less.

566(test "every work item status survives folio rendering and the lowering"

567 (for-each

568 (lambda (word)

569 (assert-true (string-has? plain-project word))

570 (assert-true (string-has? published-plain word)))

571 ;; Every status the pressure manuscript actually uses: six task states, two

572 ;; decision states, two question states, and the container states.

573 ;; ALL EIGHTEEN frozen status values, enumerated from the model rather than

574 ;; from the ones the manuscript happened to use. Review found four --

575 ;; proposed, rejected, deferred, paused -- that were never constructed,

576 ;; rendered or asserted anywhere: a vocabulary property asserted from a

577 ;; sample of the members someone thought of.

578 (list "[done]" "[active]" "[ready]" "[blocked]" "[inbox]" "[cancelled]"

579 "[accepted]" "[superseded]" "[rejected]" "[proposed]"

580 "[answered]" "[open]" "[deferred]" "[planned]" "[paused]")))

581

582;; The list above is hand-written, so this pins it to the model: every status in

583;; every frozen set must appear in the rendering. Deriving the requirement from

584;; the model means adding a status value cannot silently go unexercised.

585(test "every frozen status value is exercised by the pressure manuscript"

586 (let ((all (append (folio-task-statuses) (folio-container-statuses)

587 (folio-decision-statuses) (folio-question-statuses))))

588 (for-each

589 (lambda (sym)

590 (let ((word (string-append "[" (symbol->string sym) "]")))

591 (assert-true (string-has? plain-project word))

592 (assert-true (string-has? published-plain word))))

593 all)

594 ;; POSITIVE CONTROL: a status word that is not in any frozen set must be

595 ;; absent, proving the search above can distinguish present from absent.

596 (assert-true (not (string-has? plain-project "[next]")))

597 (assert-true (not (string-has? plain-project "[archived]")))))

598

599(test "unresolved query and transclusion markers reach both renderings"

600 (for-each

601 (lambda (rendered)

602 (assert-true (string-has? rendered unresolved-marker-prefix))

603 (assert-true (string-has? rendered "q-ready-work"))

604 (assert-true (string-has? rendered "topics/instrument-failure-taxonomy"))

605 (assert-true (string-has? rendered "s-shape-15")))

606 (list plain-project published-plain)))

607

608;; POSITIVE CONTROL for the arm above: remove the derived nodes and the markers

609;; must disappear. Without this, the assertions would pass for a renderer that

610;; printed the marker unconditionally.

611(test "the markers are present because the nodes are, and vanish without them"

612 (let* ((loc a-loc)

613 (without (make-project "projects/p" "P" 'active '()

614 (list (make-paragraph (list (make-text "no derived nodes here" loc)) loc))

615 loc))

616 (rendered (document->plain (folio-document->publication without #f))))

617 (assert-true (not (string-has? rendered unresolved-marker-prefix)))

618 (assert-true (not (string-has? rendered "q-ready-work")))))

619

620;; UPDATE IDENTITY, PINNED BY VALUE IN ALL THREE VIEWS.

621;; The event literal above already pins it, but only the datum and the events

622;; saw it; the two rendered views did not. With the corpus's only update

623;; carrying #f, `update-id` replaced by a constant #f passed everything --

624;; demonstrated by review with a real sabotage, not argued. These three

625;; assertions are what make the id VALUE observable rather than merely present.

626(test "a declared update id reaches the datum, the plain text and the lowering"

627 (assert-true (string-has? plain-project "u-f0review"))

628 (assert-true (string-has? published-plain "u-f0review"))

629 (assert-true (string-has? (folio->string pressure-project) "u-f0review"))

630 ;; NEGATIVE CONTROL: an id that was never declared must not appear, so the

631 ;; three assertions above cannot be satisfied by a renderer that prints every

632 ;; string it can reach.

633 (assert-true (not (string-has? plain-project "u-not-declared")))

634 (assert-true (not (string-has? published-plain "u-not-declared"))))

635

636(test "an external link survives lowering with its href intact"

637 (assert-true (string-has? published-plain "https://codeberg.org/sigil/folio")))

638

639;; The F5 seam is frozen into the signature now, and refuses rather than

640;; silently ignoring an argument it cannot honour.

641(test "a prepared view is refused rather than quietly dropped"

642 (assert-error (folio-document->publication pressure-project 'some-prepared-view)))

643

644(test "only a root may be lowered"

645 (assert-error (folio-document->publication

646 (make-task "t-x" "T" 'ready #f '() #f '() a-loc) #f)))