test/fixtures/folio-pressure.sgl

1;;; The F1a pressure manuscript, built against real authored source.

2;;;

3;;; F1a freezes the MODEL and deliberately ships no reader, so this fixture is

4;;; how the freeze gets exercised against real bytes rather than against

5;;; synthetic locations. `folio-pressure-project.txt` is authored `#lang

6;;; folio/doc` source; every node below is constructed with a location computed

7;;; from that file, so `(source-slice-at (folio-node-location node))` returns

8;;; the exact authored text the node came from. A location that does not

9;;; correspond to real source cannot pass.

10;;;

11;;; NEEDLES MUST BE UNIQUE, AND THAT IS ENFORCED. `located` refuses a needle

12;;; occurring zero times OR more than once. The failure this prevents is quiet:

13;;; an ambiguous needle silently resolves to the FIRST match, so the fixture

14;;; would build, the suite would pass, and a node's recorded span would point at

15;;; the wrong region of the document. A test whose fixture is subtly wrong is

16;;; worse than no test, so ambiguity is an error here, not a preference.

17;;;

18;;; NOTE ON SCOPE, CORRECTED AFTER REVIEW: an earlier version of this comment

19;;; claimed the manuscript deliberately carries the vocabulary the leakage arm

20;;; forbids, and thereby proves that arm is correctly scoped. That was simply

21;;; false -- the manuscript contains none of `sqlite|fts5|json-rpc|mcp|slate`.

22;;; The arm's scoping is real (the rest of `src/folio/` is a working MCP server

23;;; and is full of those words), but this file is not what demonstrates it, and

24;;; a comment asserting evidence that does not exist is worse than no comment.

25;;; LOADED, NOT IMPORTED, and that is forced rather than stylistic. Measured:

26;;; under `sigil test` this package builds a native test harness, and a

27;;; `(fixtures …)` library on `-L test` does not resolve from inside it -- the

28;;; whole test file fails to LOAD, taking every assertion with it. No existing

29;;; folio test defines a helper library, so the pattern had no prior art here.

30;;; `(load …)` does work under that harness (probed, with a deliberate failing

31;;; assertion to confirm the runner still reports failures through it), so both

32;;; the model suite and the publication probe pull this file in with `load` and

33;;; supply the imports themselves. Paths are relative to the repository root.

34 (define fixture-source "test/fixtures/folio-pressure-project.txt")

35 (define fixture-manuscript (read-file-string fixture-source))

37 (define (starts-at? needle at)

38 (let ((n (string-length needle)))

39 (and (<= (+ at n) (string-length fixture-manuscript))

40 (string=? needle (substring fixture-manuscript at (+ at n))))))

41 (define (count-occurrences needle)

42 (let loop ((at 0) (seen 0))

43 (if (> (+ at (string-length needle)) (string-length fixture-manuscript)) seen

44 (loop (+ at 1) (if (starts-at? needle at) (+ seen 1) seen)))))

45 (define (find-only needle)

46 (let ((total (count-occurrences needle)))

47 (if (= total 0) (error "fixture needle not found" needle)

48 (if (> total 1) (error "fixture needle is not unique" needle total)

49 (let loop ((at 0))

50 (if (starts-at? needle at) at (loop (+ at 1))))))))

52 ;; Byte position and byte span, scalar line and column -- the same shape

53 ;; every other srcloc in this estate uses. The manuscript carries Greek,

54 ;; Japanese and an astral-plane emoji precisely so these two measures

55 ;; disagree and a byte/scalar confusion cannot pass unnoticed.

56 (define (utf8-width c)

57 (let ((n (char->integer c)))

58 (cond ((<= n #x7f) 1) ((<= n #x7ff) 2) ((<= n #xffff) 3) (else 4))))

59 (define (byte-count text end)

60 (let loop ((i 0) (n 0)) (if (= i end) n (loop (+ i 1) (+ n (utf8-width (string-ref text i)))))))

61 (define (byte->char-index byte-position)

62 (let loop ((i 0) (bytes 0))

63 (cond ((= bytes byte-position) i)

64 ((or (> bytes byte-position) (= i (string-length fixture-manuscript)))

65 (error "location is not on a UTF-8 scalar boundary" byte-position))

66 (else (loop (+ i 1) (+ bytes (utf8-width (string-ref fixture-manuscript i))))))))

67 (define (source-slice-at loc)

68 (let ((start (byte->char-index (srcloc-position loc)))

69 (end (byte->char-index (+ (srcloc-position loc) (srcloc-span loc)))))

70 (substring fixture-manuscript start end)))

71 (define (line-column at)

72 (let loop ((i 0) (line 1) (column 1))

73 (if (= i at) (cons line column)

74 (if (char=? (string-ref fixture-manuscript i) #\newline)

75 (loop (+ i 1) (+ line 1) 1)

76 (loop (+ i 1) line (+ column 1))))))

77 (define (locate-text needle)

78 (let* ((at (find-only needle)) (lc (line-column at)))

79 (make-srcloc fixture-source (car lc) (cdr lc)

80 (byte-count fixture-manuscript at)

81 (byte-count needle (string-length needle)))))

83 ;; Every located node is recorded with the needle it was built from, so the

84 ;; gate can assert the slice for EVERY node rather than for a sample.

85 (define fixture-location-expectations '())

86 (define (located needle make)

87 (let ((node (make (locate-text needle))))

88 (set! fixture-location-expectations

89 (cons (list node needle) fixture-location-expectations))

90 node))

91 (define (txt s) (located s (lambda (loc) (make-text s loc))))

92 (define (para needle children) (located needle (lambda (loc) (make-paragraph children loc))))

    (define (cell needle) (located needle (lambda (loc) (make-table-cell (list (para needle (list (txt needle)))) loc))))

    (define (bullet needle) (located needle (lambda (loc) (make-list-item (list (para needle (list (txt needle)))) loc))))

96 ;; ---------------------------------------------------------------

97 ;; The project root

98 ;; ---------------------------------------------------------------

99 (define intro-paragraph

100

      (para "Turn Folio from a Markdown-convention server into a local-first semantic\nknowledge workspace whose canonical source is @code{(folio doc model)}"

101

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

102 (located "(folio doc model)" (lambda (loc) (make-code "(folio doc model)" loc))))))

103

104 (define procedure-edge

105 (located "@related[document: \"procedures/plan-driven-execution-loop\" kind: follows-procedure]"

106 (lambda (loc) (make-related "procedures/plan-driven-execution-loop" #f 'follows-procedure

107 (list (txt "the plan-driven execution loop")) loc))))

108 (define workflow-edge

109 (located "@related[document: \"topics/folio-architecture\" node: \"t-arch01\" kind: governed-by-workflow]"

110 (lambda (loc) (make-related "topics/folio-architecture" "t-arch01" 'governed-by-workflow #f loc))))

111

112 (define source-term

113 (located "@term[\"source-of-truth\" name: \"source of truth\"]"

114 (lambda (loc)

115 (make-term "source-of-truth" "source of truth" '()

116

            (list (para "@emph{Authored source files} are authoritative, and every derived table is\ndisposable: deleting the index and rebuilding it must produce the same graph."

117 (list (located "Authored source files"

118 (lambda (e) (make-emphasis (list (txt "Authored source files")) e)))

119

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

120 loc))))

121

122 ;; ---- phase 1 ---------------------------------------------------

123 (define manifest-task

124 (located "@task[\"t-f0a1\" status: done priority: high tags: (list \"inventory\") due: \"2026-08-09\"]"

125 (lambda (loc) (make-task "t-f0a1" "Produce the canonical corpus manifest"

126 'done 'high (list "inventory") "2026-08-09" '() loc))))

127 (define review-update

128 ;; A REAL id, not #f. With the corpus's only update carrying #f, every

129 ;; assertion about update identity was value-blind: a `update-id` accessor

130 ;; replaced by a constant #f satisfied all of them. Review demonstrated

131 ;; exactly that with an owned sabotage rather than asserting it.

132 (located "@update[\"u-f0review\" timestamp: \"2026-08-10T09:14:00Z\" author: \"fable\" commit: \"3a7a0eb\"]"

133 (lambda (loc)

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

135 (list (para "Independent re-execution in a detached worktree reproduced every recorded count."

136 (list (txt "Independent re-execution in a detached worktree reproduced every recorded count."))))

137 loc))))

138 (define freeze-estate-phase

139

      (located "@phase[\"p-freeze-estate\" title: \"Freeze the current estate and safety baseline\" status: done order: 1]"

140 (lambda (loc) (make-phase "p-freeze-estate" "Freeze the current estate and safety baseline"

141 'done 1 (list manifest-task review-update) loc))))

142

143 ;; ---- phase 2 ---------------------------------------------------

144 (define blocks-edge

145 (located "@related[node: \"t-f1a02\" kind: blocks]"

146 (lambda (loc) (make-related #f "t-f1a02" 'blocks #f loc))))

147 (define depends-edge

148 (located "@related[document: \"topics/sigil-doc-passive-parse-api\" kind: depends-on]"

149 (lambda (loc) (make-related "topics/sigil-doc-passive-parse-api" #f 'depends-on #f loc))))

150 (define supports-edge

151 (located "@related[document: \"topics/folio-sigil-doc-implementation-plan\" node: \"d-one\" kind: supports]"

152 (lambda (loc) (make-related "topics/folio-sigil-doc-implementation-plan" "d-one" 'supports #f loc))))

153 ;; Direction matters and was backwards before review: the ACCEPTED decision

154 ;; supersedes the superseded one, not the other way round.

155 (define supersedes-edge

156 (located "@related[node: \"d-flat-ids\" kind: supersedes]"

157 (lambda (loc) (make-related #f "d-flat-ids" 'supersedes #f loc))))

158

159 (define model-task

160 (located "@task[\"t-f1a01\" status: active priority: high tags: (list \"model\" \"freeze\")]"

161 (lambda (loc) (make-task "t-f1a01" "Immutable records for the whole vocabulary"

162 'active 'high (list "model" "freeze") #f (list blocks-edge) loc))))

163 (define reader-task

164 (located "@task[\"t-f1a02\" status: ready priority: medium tags: (list \"reader\")]"

165 (lambda (loc) (make-task "t-f1a02" "Build the profile reader and prove delegation parity"

166 'ready 'medium (list "reader") #f '() loc))))

167 (define inspector-task

168 (located "@task[\"t-f1a03\" status: blocked priority: low]"

169 (lambda (loc) (make-task "t-f1a03" "Wire the passive inspector into the index"

170 'blocked 'low '() #f (list depends-edge) loc))))

171 (define inbox-task

172 (located "@task[\"t-f1a04\" status: inbox]"

173 (lambda (loc) (make-task "t-f1a04" "Decide whether a phase may carry a due date"

174 'inbox #f '() #f '() loc))))

175 (define cancelled-task

176 (located "@task[\"t-f1a05\" status: cancelled]"

177 (lambda (loc) (make-task "t-f1a05" "Fork the prose grammar for folio"

178 'cancelled #f '() #f '() loc))))

179

180 (define compact-question

181 (located "@question[\"q-compact-address\" title: \"Should a compact address spelling exist?\" status: answered]"

182 (lambda (loc)

183 (make-question "q-compact-address" "Should a compact address spelling exist?" 'answered

184

            (list (para "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."

185

                    (list (txt "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."))))

186 loc))))

187 ;; The open question is not decoration: the frozen transition relation has no

188 ;; edge out of `done`, and the shipping product exposes a reopen operation.

189 ;; The manuscript records that as an OPEN question rather than resolving it.

190 (define reopen-question

191 (located "@question[\"q-reopen\" title: \"May a done work item return to ready?\" status: open]"

192 (lambda (loc)

193 (make-question "q-reopen" "May a done work item return to ready?" 'open

194

            (list (para "The frozen relation @code{task-transition-allowed?} draws no edge out of a\nfinished item, while the shipping product still offers to reopen one."

195 (list (txt "The frozen relation ")

196 (located "task-transition-allowed?" (lambda (c) (make-code "task-transition-allowed?" c)))

197

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

198 loc))))

199

200 (define profile-decision

201

      (located "@decision[\"d-profile\" title: \"folio/doc is a prelude and profile, not a new language\" status: accepted]"

202 (lambda (loc)

203 (make-decision "d-profile" "folio/doc is a prelude and profile, not a new language" 'accepted

204

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

205

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

206 supports-edge)

207 loc))))

208 (define superseded-decision

209 (located "@decision[\"d-flat-ids\" title: \"Loosen the node id grammar to admit slashes\" status: superseded]"

210 (lambda (loc)

211 (make-decision "d-flat-ids" "Loosen the node id grammar to admit slashes" 'superseded

212 '() loc))))

213 ;; `rejected` and `proposed` exist so that every one of the eighteen frozen

214 ;; status values is actually constructed by the manuscript. Review found

215 ;; four that were never built, rendered or asserted -- a vocabulary property

216 ;; asserted from the members someone happened to think of.

217 (define rejected-decision

218 (located "@decision[\"d-compact-address\" title: \"Add a compact doc#node address spelling\" status: rejected]"

219 (lambda (loc)

220 (make-decision "d-compact-address" "Add a compact doc#node address spelling" 'rejected

221 (list (para "Only a form that can be semantically reasoned about should be spelled at all."

222 (list (txt "Only a form that can be semantically reasoned about should be spelled at all."))))

223 loc))))

224 (define proposed-decision

225 (located "@decision[\"d-reopen-policy\" title: \"Allow a done work item to return to ready\" status: proposed]"

226 (lambda (loc)

227 (make-decision "d-reopen-policy" "Allow a done work item to return to ready" 'proposed

228

            (list (para "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."

229

                    (list (txt "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."))))

230 loc))))

231 (define accepted-decision

232

      (located "@decision[\"d-two-grammars\" title: \"Node ids stay flat; document addresses are a second grammar\" status: accepted]"

233 (lambda (loc)

234 (make-decision "d-two-grammars" "Node ids stay flat; document addresses are a second grammar" 'accepted

235 (list supersedes-edge compact-question reopen-question) loc))))

236

237 (define freeze-model-phase

238 (located "@phase[\"p-freeze-model\" title: \"Freeze the folio/doc semantic model\" status: active order: 2]"

239 (lambda (loc)

240 (make-phase "p-freeze-model" "Freeze the folio/doc semantic model" 'active 2

241

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

242

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

243 model-task reader-task inspector-task inbox-task cancelled-task

244 profile-decision superseded-decision rejected-decision

245 proposed-decision accepted-decision)

246 loc))))

247

248 ;; ---- phase 3 ---------------------------------------------------

249 (define trust-table

250 (located "@table[columns: (list left left) caption: \"Trust levels\"]"

251 (lambda (loc)

252 (make-table (list (txt "Trust levels")) (list 'left 'left)

253 (list (located "@row[header: #t]@cell{trust level}@cell{what it may do}"

254 (lambda (r) (make-table-row #t (list (cell "trust level") (cell "what it may do")) r)))

255 (located "@row@cell{passive tier}@cell{parse syntax and inspect declared fields}"

256

                    (lambda (r) (make-table-row #f (list (cell "passive tier") (cell "parse syntax and inspect declared fields")) r)))

257 (located "@row@cell{trusted tier}@cell{evaluate author forms after an explicit grant}"

258

                    (lambda (r) (make-table-row #f (list (cell "trusted tier") (cell "evaluate author forms after an explicit grant")) r))))

259 loc))))

260 (define bounded-task

261 (located "@task[\"t-f2a01\" status: ready tags: (list \"passivity\")]"

262 (lambda (loc) (make-task "t-f2a01" "Parse untrusted sources in a bounded worker"

263 'ready #f (list "passivity") #f '() loc))))

264 (define deferred-question

265

      (located "@question[\"q-subject-index\" title: \"How should a subject index beyond glossary terms work?\" status: deferred]"

266 (lambda (loc) (make-question "q-subject-index"

267 "How should a subject index beyond glossary terms work?" 'deferred '() loc))))

268 (define inspect-phase

269

      (located "@phase[\"p-passive-inspect\" title: \"Passive inspection and dual-format discovery\" status: planned order: 3]"

270 (lambda (loc) (make-phase "p-passive-inspect" "Passive inspection and dual-format discovery"

271 'planned 3 (list trust-table bounded-task deferred-question) loc))))

272 ;; The fourth container status. Also the only phase with no children, which

273 ;; exercises the empty-container path through the lowering.

274 (define paused-phase

275

      (located "@phase[\"p-publication\" title: \"Publish a knowledgebase without a Folio runtime\" status: paused order: 4]"

276 (lambda (loc) (make-phase "p-publication" "Publish a knowledgebase without a Folio runtime"

277 'paused 4 '() loc))))

278

279 (define first-edition-milestone

280 (located "@milestone[\"m-first-edition\" title: \"First edition of the semantic workspace\" status: active]"

281 (lambda (loc) (make-milestone "m-first-edition" "First edition of the semantic workspace" 'active

282 (list freeze-estate-phase freeze-model-phase inspect-phase paused-phase) loc))))

283

284 ;; ---- ordinary Sigil Doc content --------------------------------

285 ;;

286 ;; NOTE FOR THE REVIEW: these sections are SIBLINGS of the folio nodes, not

287 ;; parents of them, and that is forced rather than chosen. `make-section`

288 ;; validates its children with sigil-doc's own `block-node?`, which is a

289 ;; closed enumeration of core kinds, so a `@task` can never be a child of a

290 ;; `@section`. The freeze therefore cannot express "a task underneath an

291 ;; ordinary heading" -- which is how folio notes are written today. This is

292 ;; recorded as a finding in the session log; it is a sigil-doc-side

293 ;; extensibility gap of the same family as B2, not something F1a can fix.

294 (define reading-section

295 (located "@section[\"reading\"]{Where the rules actually live}"

296 (lambda (loc)

297 (make-section "reading" (list (txt "Where the rules actually live"))

298 (list

299

              (para "Rules are referenced rather than reproduced, as in @ref[\"reading\"]{this very section},\nand the published plan lives at @url[\"https://codeberg.org/sigil/folio\"]{the folio repository}"

300 (list (txt "Rules are referenced rather than reproduced, as in ")

301 (located "this very section"

302 (lambda (r) (make-reference "reading" (list (txt "this very section")) r)))

303 (txt ",\nand the published plan lives at ")

304 ;; The node this whole phase waited for SD-P2 to land.

305 (located "@url[\"https://codeberg.org/sigil/folio\"]{the folio repository}"

306 (lambda (u) (make-url-link "https://codeberg.org/sigil/folio"

307 (list (txt "the folio repository")) u)))))

308 (located "@list[ordered: #t start: 1]"

309 (lambda (l) (make-item-list #t 1

310 (list (bullet "Source fidelity: untouched bytes stay exact.")

311 (bullet "Identity: a move never changes a stable local id.")

312 (bullet "Honesty about derived state: rebuilding yields the same answers."))

313 l)))

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

315 (lambda (c) (make-code-block "sigil"

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

317 ;; A declared `@term` obliges the publication to carry exactly one

318 ;; `@glossary` insertion point; `build-publication-index` refuses

319 ;; otherwise. Found by running the lowering, not by reading.

320 (located "@(glossary)" (lambda (g) (make-glossary g))))

321 loc))))

322

323 (define unicode-section

324 (located "@section[\"unicode\"]{Locations that are not ASCII}"

325 (lambda (loc)

326 (make-section "unicode" (list (txt "Locations that are not ASCII"))

327

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

328

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

329 loc))))

330

331 ;; A work item whose own title is non-ASCII, so a byte/scalar confusion

332 ;; shows up on a FOLIO node and not only on core prose.

333 (define unicode-task

334 (located "@task[\"t-unicode\" status: ready]"

335 (lambda (loc) (make-task "t-unicode" "Prove καλημέρα spans survive the round trip"

336 'ready #f '() #f '() loc))))

337

338 (define ready-query

339

      (located "@query[id: \"q-ready-work\" title: \"Everything ready and unblocked\" spec: (and (kind task) (status ready))]"

340 (lambda (loc) (make-query "q-ready-work" "Everything ready and unblocked"

341 '(and (kind task) (status ready)) loc))))

342 (define taxonomy-transclusion

343 (located "@transclude[document: \"topics/instrument-failure-taxonomy\" node: \"s-shape-15\"]"

344 (lambda (loc) (make-transclude "topics/instrument-failure-taxonomy" "s-shape-15" loc))))

345

346 (define pressure-project

347

      (located "@project[\"projects/folio-sigil-doc\" title: \"Folio as a semantic Sigil Doc workspace\" status: active tags: (list \"folio\" \"sigil-doc\" \"knowledge-graph\")]"

348 (lambda (loc)

349 (make-project "projects/folio-sigil-doc" "Folio as a semantic Sigil Doc workspace" 'active

350 (list "folio" "sigil-doc" "knowledge-graph")

351 (list intro-paragraph procedure-edge workflow-edge source-term

352 first-edition-milestone reading-section unicode-section

353 unicode-task ready-query taxonomy-transclusion)

354 loc))))

355

356 ;; ---------------------------------------------------------------

357 ;; The note root -- note metadata, and the same-document transclusion

358 ;; ---------------------------------------------------------------

359 (define mentions-edge

360 (located "@related[document: \"projects/folio-sigil-doc\" node: \"t-f1a01\" kind: mentions]"

361 (lambda (loc) (make-related "projects/folio-sigil-doc" "t-f1a01" 'mentions

362 (list (txt "the freeze task")) loc))))

363 (define note-task

364 (located "@task[\"t-note01\" status: ready priority: low]"

365 (lambda (loc) (make-task "t-note01" "Record the reopen gap for the mutation phase"

366 'ready 'low '() #f '() loc))))

367 ;; `document: #f` means "this document" -- the two-part address with its

368 ;; first part omitted, never a compact one-string spelling.

369 (define local-transclusion

370 (located "@transclude[node: \"t-f1a01\"]"

371 (lambda (loc) (make-transclude #f "t-f1a01" loc))))

372

373 (define pressure-note

374

      (located "@note[\"topics/folio-doc-freeze-notes\" title: \"Notes taken while freezing the model\" tags: (list \"folio\" \"freeze\" \"0.1\")]"

375 (lambda (loc)

376 (make-note "topics/folio-doc-freeze-notes" "Notes taken while freezing the model"

377 (list "folio" "freeze" "0.1")

378

            (list (para "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."

379

                    (list (txt "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.")))

380 mentions-edge note-task local-transclusion)

381 loc))))

382

383 (set! fixture-location-expectations (reverse fixture-location-expectations))