test/f1b-profile-probe.sgl

1;;; F1b -- the content profile, inspected WITHOUT the author runtime.

2;;;

3;;; This probe imports `(folio doc profile)` and `(folio doc model)` and nothing

4;;; from the evaluation side. That is deliberate and is half the reason the

5;;; profile lives in its own module: the gate must be able to read a profile's

6;;; declarations -- its predicates, its witnesses, its describer -- without

7;;; linking the author runtime. A profile whose declarations can only be

8;;; inspected by loading the machinery that consumes them is a profile nobody

9;;; can cheaply check.

10;;;

11;;; `(sigil test)` IS NOT USED, and must not be: a direct `sigil <file>` run

12;;; REGISTERS `test` forms and never executes them. Measured by F1a -- a file

13;;; asserting `1 = 2` printed nothing and exited 0. The harness below is

14;;; hand-rolled and the gate proves it can go red on every run through

15;;; `F1B_PROBE_SELFTEST`.

16;;;

17;;; The `F1B_REFUSED` / `F1B_ADMITTED` lines exist for the gate's EXACT

18;;; MEMBERSHIP assertion. They are emitted one per witness, classified through

19;;; `(folio doc model)`'s own predicates rather than through anything this file

20;;; knows, so the gate compares the profile's declaration against a literal

21;;; expectation and a fifth witness fails exactly as loudly as a missing one.

22(import (sigil core) (sigil fs) (sigil syntax)

23 (sigil doc model) (folio doc model) (folio doc profile))

25(define checks-run 0)

26(define checks-failed 0)

27(define (check label ok?)

28 (set! checks-run (+ checks-run 1))

29 (if (not ok?)

30 (begin (set! checks-failed (+ checks-failed 1))

31 (display (string-append " FAIL: " label)) (newline))))

33(define (string-has? haystack needle)

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

35 (let loop ((i 0))

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

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

38 (else (loop (+ i 1)))))))

40(define (raises? thunk)

41 (guard (exn (else #t)) (thunk) #f))

43;; The witness's kind, named through the model's own record predicates. This

44;; file deliberately does not carry a parallel list of kind names.

45(define (kind-of node)

46 (cond ((note? node) "note")

47 ((project? node) "project")

48 ((milestone? node) "milestone")

49 ((phase? node) "phase")

50 ((task? node) "task")

51 ((decision? node) "decision")

52 ((question? node) "question")

53 ((update? node) "update")

54 ((related? node) "related")

55 ((query? node) "query")

56 ((transclude? node) "transclude")

57 (else "not-a-folio-node")))

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

60;; The declaration, emitted for the gate to compare by membership.

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

62(for-each (lambda (w) (display (string-append "F1B_REFUSED " (kind-of w))) (newline))

63 folio-refused-witnesses)

64(for-each (lambda (w) (display (string-append "F1B_ADMITTED " (kind-of w))) (newline))

65 folio-admitted-witnesses)

67;; ---------------------------------------------------------------------------

68;; The witness lists are non-empty and name no value twice. `make-content-profile`

69;; already refuses an empty list; asserting it here means the probe's own

70;; iteration below is over something rather than over nothing.

71;; ---------------------------------------------------------------------------

72(check "refused witnesses are declared" (pair? folio-refused-witnesses))

73(check "admitted witnesses are declared" (pair? folio-admitted-witnesses))

75;; ---------------------------------------------------------------------------

76;; THE ANTI-NARROWING FLOOR, re-asserted from the consuming side.

77;;

78;; `make-content-profile` already enforces this at construction, so a green here

79;; is not new information about today's tree -- it is the arm that keeps being

80;; true if the constructor's own check is ever weakened. The witness list is

81;; obtained from `core-block-witnesses`, i.e. derived from sigil-doc, never

82;; restated here.

83;; ---------------------------------------------------------------------------

84(define core-witnesses (core-block-witnesses))

85(check "core block witnesses are a non-empty population" (pair? core-witnesses))

86(for-each

87 (lambda (w)

88 (check "folio-section-child? admits every core block witness"

89 (folio-section-child? w))

90 (check "folio-doc-node? admits every core block witness"

91 (folio-doc-node? w)))

92 core-witnesses)

94;; ---------------------------------------------------------------------------

95;; The declarations hold against the predicate itself.

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

97(for-each

98 (lambda (w)

99 (check (string-append "folio-section-child? REFUSES the declared-refused " (kind-of w))

100 (not (folio-section-child? w)))

101 (check (string-append "folio-doc-node? admits the refused witness " (kind-of w))

102 (folio-doc-node? w)))

103 folio-refused-witnesses)

104

105(for-each

106 (lambda (w)

107 (check (string-append "folio-section-child? admits the declared-admitted " (kind-of w))

108 (folio-section-child? w))

109 (check (string-append "folio-doc-node? admits the admitted witness " (kind-of w))

110 (folio-doc-node? w)))

111 folio-admitted-witnesses)

112

113;; A profile that admitted nothing beyond the core floor would extend nothing

114;; while satisfying every check above.

115(check "at least one admitted witness is NOT a core block node"

116 (let loop ((xs folio-admitted-witnesses))

117 (cond ((null? xs) #f)

118 ((not (block-node? (car xs))) #t)

119 (else (loop (cdr xs))))))

120

121;; ---------------------------------------------------------------------------

122;; THE FLOOR ON REFUSAL. Both predicates must reject values that are no

123;; profile's node. Without this, `(lambda (x) #t)` satisfies "every declared

124;; witness is a node of this language" for free and the guard above is worth

125;; nothing -- the hole SD-P7's own adversarial review found in its first draft.

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

127(for-each

128 (lambda (junk)

129 (check "folio-doc-node? rejects a non-node" (not (folio-doc-node? junk)))

130 (check "folio-section-child? rejects a non-node" (not (folio-section-child? junk))))

131 (list 'a-symbol 42 "a string" #t #f '() (lambda (x) x)))

132

133;; ---------------------------------------------------------------------------

134;; TWO INDEPENDENTLY-WRITTEN PREDICATES MUST AGREE.

135;;

136;; `note-child?` lives in `(folio doc model)`, is not exported, and is what

137;; `make-note` actually enforces. `folio-section-child?` lives in

138;; `(folio doc profile)` and is what a `@section` under that note enforces. They

139;; are the same rule written twice in two modules, which is a drift risk, so the

140;; agreement is MEASURED rather than asserted in a comment: for every witness in

141;; play, constructing a note with that witness as its only child must succeed

142;; exactly when the profile's predicate admits it.

143;;

144;; This is a differential between two implementations, not a check of a value

145;; against itself.

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

147(define agreement-location (make-srcloc "f1b-profile-probe" 1 1 0 0))

148(define (note-accepts? child)

149 (not (raises?

150 (lambda ()

151 (make-note "topics/f1b-agreement" "agreement" '() (list child)

152 agreement-location)))))

153(for-each

154 (lambda (w)

155 (check (string-append "make-note and folio-section-child? agree on " (kind-of w))

156 (eq? (note-accepts? w) (folio-section-child? w))))

157 (append core-witnesses folio-admitted-witnesses folio-refused-witnesses))

158

159;; ---------------------------------------------------------------------------

160;; THE DESCRIBER. It must NAME in folio's vocabulary and LOCATE, because the

161;; core model can do neither for a foreign node -- `node-location` is a closed

162;; enumeration over the core kinds and RAISES on a milestone.

163;; ---------------------------------------------------------------------------

164(define described-milestone

165 (folio-describe-refusal

166 (make-milestone "m-described" "a described refusal" 'planned '()

167 (make-srcloc "f1b-described.sgd" 42 7 100 20))))

168(check "the describer returns a string" (string? described-milestone))

169(check "the describer names the language" (string-has? described-milestone "folio/doc:"))

170(check "the describer names folio's own class"

171 (string-has? described-milestone "structural container"))

172(check "the describer LOCATES the offending child -- file"

173 (string-has? described-milestone "f1b-described.sgd"))

174(check "the describer LOCATES the offending child -- line and column"

175 (string-has? described-milestone ":42:7:"))

176

177;; A core node can be located by the core model, so the describer must use that

178;; rather than degrading to unlocated.

179(define described-text

180 (folio-describe-refusal

181 (make-text "not a block" (make-srcloc "f1b-described.sgd" 9 3 40 11))))

182(check "the describer locates a CORE node too" (string-has? described-text "f1b-described.sgd:9:3:"))

183(check "the describer classifies a non-block core node"

184 (string-has? described-text "not a block node"))

185

186;; It must not raise on a value that is no node at all -- a describer that

187;; crashed would turn a clear refusal into a failure far from its cause.

188(define described-junk (folio-describe-refusal 'a-bare-symbol))

189(check "the describer survives a non-node" (string? described-junk))

190(check "the describer says so plainly"

191 (string-has? described-junk "not a folio/doc node at all"))

192;; "Unlocated" is spelled as STARTS-WITH rather than as "contains no colon",

193;; which is what I wrote first and which was simply wrong: every message

194;; contains `folio/doc:`, so the check failed on a correct product. A located

195;; message begins with its file, so the discriminator is the PREFIX.

196(check "the describer adds no location it does not have"

197 (and (>= (string-length described-junk) 10)

198 (string=? (substring described-junk 0 10) "folio/doc:")))

199

200;; ---------------------------------------------------------------------------

201;; The profile value itself carries what it was built with.

202;; ---------------------------------------------------------------------------

203(check "the profile is a content profile" (content-profile? folio-content-profile))

204(check "the profile names folio/doc"

205 (string=? (content-profile-name folio-content-profile) "folio/doc"))

206(check "the profile carries a describer"

207 (procedure? (content-profile-describer folio-content-profile)))

208(check "the profile's section-child predicate is the one asserted above"

209 (eq? (content-profile-section-child-predicate folio-content-profile)

210 folio-section-child?))

211(check "the profile's node predicate is the one asserted above"

212 (eq? (content-profile-node-predicate folio-content-profile) folio-doc-node?))

213

214;; ---------------------------------------------------------------------------

215;; Self-test: prove THIS harness can go red, on this run, before its green is

216;; allowed to mean anything.

217;; ---------------------------------------------------------------------------

218(if (getenv "F1B_PROBE_SELFTEST")

219 (check "deliberate failure injected by F1B_PROBE_SELFTEST" #f))

220

221(display (string-append "F1B_PROFILE_PROBE checks=" (number->string checks-run)

222 " failed=" (number->string checks-failed)))

223(newline)

224(if (> checks-failed 0)

225 (error "F1b profile probe failed" checks-failed))