@tabnas/abnf 0.4.20 → 0.4.22

This diff represents the content of publicly available package versions that have been released to one of the supported registries. The information contained in this diff is provided for informational purposes only and reflects changes between package versions as they appear in their respective public registries.
@@ -0,0 +1,2038 @@
1
+ /* Copyright (c) 2026 Richard Rodger and other contributors, MIT License */
2
+
3
+ // Generated by ../embed-translate.js. Edit tabnas.plugin.json or alchemy/*,
4
+ // then run npm run embed.
5
+
6
+ type TranslationPart = Readonly<{
7
+ entry: string
8
+ source?: string
9
+ }>
10
+
11
+ type TranslationParts = Readonly<{
12
+ manifest: string
13
+ lift?: TranslationPart
14
+ embed?: TranslationPart
15
+ render?: TranslationPart
16
+ }>
17
+
18
+ const TRANSLATION: TranslationParts = Object.freeze({
19
+ manifest: `{
20
+ "$schema": "https://tabnas.dev/schema/plugin.schema.json",
21
+ "name": "@tabnas/abnf",
22
+ "go": "github.com/tabnas/abnf/go",
23
+ "rust": "tabnas-abnf",
24
+ "description": "ABNF (RFC 5234) grammar compiler for the tabnas engine. A host reads an ABNF document by compiling it: the tree it translates is the pure-data GrammarSpec the compiler emits (schema grammar-spec), which the render writes back as ABNF.",
25
+ "base": "@tabnas/bnf",
26
+ "engine": "@tabnas/parser",
27
+ "extensions": [
28
+ ".abnf"
29
+ ],
30
+ "languageId": "abnf",
31
+ "specDir": "test/spec",
32
+ "clib": {
33
+ "dir": "go/clib",
34
+ "library": "libtabnasabnf",
35
+ "abi": "v1",
36
+ "errorCodes": [
37
+ "usage",
38
+ "grammar",
39
+ "handle",
40
+ "internal"
41
+ ]
42
+ },
43
+ "errorCodes": [],
44
+ "docs": "https://tabnas.dev/docs/packages",
45
+ "repository": "https://github.com/tabnas/abnf",
46
+ "versionSource": "ts/package.json",
47
+ "translate": {
48
+ "reads": "tree",
49
+ "writes": "tree",
50
+ "root": "object",
51
+ "schema": "grammar-spec",
52
+ "render": "alchemy/render.alc",
53
+ "loss": [
54
+ "The grammar is written anew from its compiled spec: comments, blank lines and layout are not kept, each rule is written on one line, and the RFC 5234 core rules the compiler added (ALPHA, DIGIT and the rest) are not written, since the compiler adds them again wherever they are referenced.",
55
+ "A rule is written as the compiler rewrote it: a reference that led an alternative is written back where the alternatives the compiler put in its place still stand together, each followed by one same tail, and is otherwise written as those alternatives; a left recursion is written as the repetition it became, and alternatives the compiler left-factored with their shared prefix written in each of them again.",
56
+ "Where the compiler reordered a rule's alternatives to tell them apart (a longer lookahead ahead of a shorter one that begins with the same character, a keyword ahead of a character class that can take it), the alternatives that push a helper of the compiler's are put back in the order its numbers record, and the others are written in the compiled order: the rule compiles back the same, and the spec compiled back can differ in the order of the alternates other rules build through it, in the numbers of the compiler's helpers and in the order of its tokens, which is the order the lexer tries two tokens a place expects, so where a keyword and a class that can take it trade places the grammar compiled back accepts what the spec refused (start = ident / \\"if\\" ident with ident = %x61-7A: the spec refuses ifx, and the text compiles back to one that accepts it).",
57
+ "A left recursion that ran through another rule (P = Q, Q = P \\"+\\" / NR) is written as the compiler rewrote it, with the leading reference that closed the cycle left in place, and compiles back to another spec, since the compiler now substitutes that reference.",
58
+ "The start rule is written first, as ABNF's start rule is its first; a spec whose start rule was not its first rule compiles back with that rule moved first.",
59
+ "Terminals are written in RFC 5234's forms: a literal as a quoted string (with %s where it matches exactly and holds a letter) or, where a quoted string cannot hold it, as a numeric value of its code points, a range as %x and its ends, the class of every code point (GBNF's dot) as %x0-10FFFF, and a rule the compiler made a token of (CR = %x0D, referenced as CR) as that rule, after the others.",
60
+ "A rule the compiler made a token of, whose name is one the compiler could give its literal by itself (B = \\"b\\", or any name of capitals, digits and underscores where the literal holds a character past ASCII), cannot be told from that literal and is written as the literal: it compiles back with the token later in the token table, or under the name the literal gives it.",
61
+ "Repetitions are written in RFC 5234's forms, *A, 1*A, m*nA, [ A ] for an option over a group and 0*1A for an option over anything else; a repetition of a repetition, which another notation can write and RFC 5234 cannot, is put in a group of its own and compiles back with one more group.",
62
+ "An empty alternative, which RFC 5234 has no syntax for, is written as nothing between its slashes, which the compiler reads as one; in a rule whose alternatives the compiler emits as its open alternates, where it puts the empty one last wherever it stood, it is written first.",
63
+ "A spec compiled from another notation compiles back under ABNF's own settings: the group tag on every alternate, and lexer options the other notation adds (GBNF's exact lexing), are ABNF's, and a class of several members, which RFC 5234 cannot write, is written as the alternation of its members, each range a range and each character a string or a range of one, and compiles back as that alternation.",
64
+ "The tree builders every compiled grammar carries (@node$, @capture$, @bubble$ and @fold$, with their k settings) and its marks are not written, since the compiler makes them again from the rules: a spec whose builders or marks are others compiles back with the compiler's own, and recognises what it recognised.",
65
+ "A spec the render cannot write as ABNF is refused with TARGET_VALUE_UNREPRESENTABLE, naming what it met: an action (a value annotation's builders, a user action, the probe dispatcher of an optional prefix), a condition or a counter other than a repetition's, an error generator or an alternate modifier, a function reference where a rule or a count is due, a set of tokens at one place, a removal, a clear or the form that edits a rule already installed, a token no ABNF terminal matches (a negated class, a class holding a character past ASCII alone, a class whose flags change what it matches (no u on a class that is negated, reaches past U+FFFF or holds every code point, or u on one that holds a surrogate), a pattern that is neither one class nor an escaped literal, a case-sensitive literal holding a letter and a character no quoted string holds, a case-insensitive literal holding a character past ASCII and no ASCII letter, whose numeric value would match one case alone, a character past U+FFFF), a token set whose tokens are not the class its name gives, a rule with no alternate to open with, a sequence's step with more alternates than a step, a rule the compiler lifted to a token whose name another rule holds, a start that is not the start wrapper every grammar text compiles to (one open alternate that matches nothing and pushes a rule, closed by the end of the source alone), a rule name ABNF cannot spell, the empty name among them, a repetition bounded past what the compiler numbers, a repetition of no copies, whose item the spec does not keep, or a spec that gives its match tokens' order as a list of its own (Go's tokenOrder), whose rules' order, which ranks the tokens, is lost."
66
+ ]
67
+ }
68
+ }
69
+ `,
70
+ render: Object.freeze({ entry: "abnf-render", source: `; ABNF's render: a grammar-spec tree, the GrammarSpec the tabnas BNF
71
+ ; compiler (tabnas-bnf) emits for a grammar, written back as RFC 5234
72
+ ; ABNF. This is a library of definitions, each named \`abnf-...\`, which a
73
+ ; host links with its own program (alchemy's \`compile_sources\`); its entry
74
+ ; point is \`abnf-render\`, and nothing else here is the host's to call.
75
+ ;
76
+ ; A host reads an ABNF document by compiling it: the grammar-spec tree is
77
+ ; the pure-data GrammarSpec that \`abnfCompile(src, {recognition: false,
78
+ ; strict: true})\` writes (\`abnf_compile\` in Rust, \`AbnfCompile\` in Go;
79
+ ; the same text in all three runtimes, which tabnas-bnf's oracle tests
80
+ ; hold byte for byte), parsed as JSON. Its schema is \`grammar-spec\`,
81
+ ; shared with EBNF and GBNF, whose compilers emit the same shape; the
82
+ ; contract is the round trip: the text written here compiles back to the
83
+ ; spec it was written from.
84
+ ;
85
+ ; The spec is a compiled grammar, not the grammar's text, so the render
86
+ ; reads the compiler's shapes back into the notation:
87
+ ;
88
+ ; - A rule the author wrote is a rule of the spec that the spec's
89
+ ; \`meta.provenance\` does not name (a spec without it is read by the
90
+ ; names the compiler gives its rules, a helper's only where it has
91
+ ; the shape of its kind too, and the start wrapper by its shape);
92
+ ; every rule it names is the compiler's: a repetition's, an
93
+ ; option's or a group's helper (\`_gen<n>_star_...\`, \`_plus_\`, \`_opt_\`,
94
+ ; \`_rep_\`, \`_group\`), a sequence's chain steps (\`$alt<i>\`,
95
+ ; \`$step<j>\`), a left-factored tail (\`$fact<k>\`) and the start
96
+ ; wrapper. A helper is written where it is referenced, as the
97
+ ; construct it compiles: a repeat loop (the replace loop every \`*A\`
98
+ ; compiles to, its entry \`{c: {n.rep: 0}, r: <self>}\`) as \`*A\`, a plus
99
+ ; as \`1*A\`, an option over a group as \`[ ... ]\` and over anything else
100
+ ; as \`0*1A\`, a counted repetition as \`m*nA\` (its nested optionals
101
+ ; counted), a group as \`( ... )\`. A factored tail is expanded back
102
+ ; into the alternatives it was factored from, which the compiler
103
+ ; factors again, and alternatives that were each a group, which the
104
+ ; compiler factored into the first, are read back as the groups they
105
+ ; were.
106
+ ; - An alternative of a rule is read from the alternates the compiler
107
+ ; emitted for it: a chain of steps, one per segment of terminals and a
108
+ ; reference; a dispatcher's \`$alt<i>\` rules, the gap in their numbers
109
+ ; the empty alternative; or, for a rule whose every alternative is one
110
+ ; segment, its open alternates, each read as the tokens it consumes
111
+ ; (its \`s\` less the \`b\` it gives back) and the rule it pushes, the
112
+ ; lookahead copies the dispatch made of one alternative read as one,
113
+ ; the empty alternative first (the compiler puts it last wherever it
114
+ ; stood), and those that push a helper in the order of the helpers'
115
+ ; numbers, which the compiler gives them before it reorders the
116
+ ; alternatives to tell them apart.
117
+ ; - A leading reference the compiler substituted by the referenced rule's
118
+ ; alternatives is written back where those alternatives, each followed
119
+ ; by one same tail, still stand together.
120
+ ; - A token is written as the terminal it matches: a fixed token as a
121
+ ; quoted string, \`%s"..."\` where it holds a letter, a case-folding
122
+ ; match token as a quoted string, a range as \`%x<lo>-<hi>\` (a token
123
+ ; set the compiler laid over a contested range read back from its
124
+ ; name, once its tokens are found to be that range), \`[\\s\\S]\` (GBNF's
125
+ ; \`.\`) as \`%x0-10FFFF\`, and the engine's \`#TX\`, \`#NR\`, \`#ST\` and \`#VL\`
126
+ ; by their names. A string a quoted string cannot hold is written as a
127
+ ; numeric value, \`%x<hex>.<hex>\`, which the compiler reads as
128
+ ; case-insensitive where it holds a letter of ASCII and as exact where
129
+ ; it holds none: a case-folding string past ASCII with no such letter,
130
+ ; whose numeric value would match one case alone, is refused. A token
131
+ ; named for a rule the
132
+ ; compiler lifted to it (\`CR = %x0D\` becomes the token \`#CR\`) is
133
+ ; written as that rule, after the others, and referenced by name.
134
+ ; - An RFC 5234 core rule (ALPHA, DIGIT, ...) in the spec is not written,
135
+ ; since the compiler adds it again wherever it is referenced, and a
136
+ ; leading reference to one is written back as any other is.
137
+ ;
138
+ ; What a rule cannot be read back to is refused with
139
+ ; TARGET_VALUE_UNREPRESENTABLE, naming the rule: an action other than
140
+ ; the tree builders every compiled grammar carries (a value annotation's
141
+ ; builders, a user action, the probe dispatcher's), a condition or a
142
+ ; counter other than a repeat loop's, an error generator or an alternate
143
+ ; modifier (\`e\`, \`h\`), a function reference where a rule or a count is
144
+ ; due, a set of tokens at one place, the form that edits a rule already
145
+ ; installed (\`{alts, inject}\`), a removal, and a token no ABNF terminal
146
+ ; matches (a negated class, a class holding a character past ASCII
147
+ ; alone, a class whose flags change what it matches, a pattern that is
148
+ ; neither one class nor an escaped literal). A token set whose tokens
149
+ ; are not the class its name gives, a rule with no alternate to open
150
+ ; with, a sequence's step with more alternates than a step, and a rule
151
+ ; the compiler lifted to a token whose name another rule holds are
152
+ ; refused too. A spec serialized by Go, which writes its rules in name
153
+ ; order and its match tokens' order as a list of its own
154
+ ; (\`options.match.tokenOrder\`), is refused when that list holds two
155
+ ; tokens or more: the rules' order, which ranks the tokens (the order
156
+ ; the lexer tries two tokens a place expects), is lost. The tree
157
+ ; builders and the marks are not written: the compiler makes them again
158
+ ; from the rules.
159
+ ; A spec whose start is not the start wrapper every grammar text
160
+ ; compiles to (one open alternate that matches nothing and pushes a
161
+ ; rule, closed by the end of the source alone) is refused as well: its
162
+ ; text would compile back inside such a wrapper, whose close lets the
163
+ ; end of the source come after what the lexer skips.
164
+ ;
165
+ ; A spec compiled from another notation is written as far as ABNF can say
166
+ ; it: a class of several members (GBNF's and EBNF's \`[a-zA-Z_]\`) as the
167
+ ; alternation of its members, each range a range and each character a
168
+ ; string that matches it exactly, and an engine token by its name.
169
+ ;
170
+ ; The whole spec is materialized before a line is written: a rule's
171
+ ; alternatives are spread over its chain rules and helpers, which the
172
+ ; spec keeps elsewhere in its \`rule\` object.
173
+
174
+ ; ---- text and vectors
175
+
176
+ def abnf-at [v i]
177
+ get-path (as-path [i]) v
178
+
179
+ def abnf-num [n]
180
+ scalar-text csv-options n
181
+
182
+ def abnf-empty [s]
183
+ match s
184
+ case "" true
185
+ case _ false
186
+
187
+ def abnf-full [s]
188
+ match s
189
+ case "" false
190
+ case _ true
191
+
192
+ ; Whether the strings a and b are the same: a string cut by itself is two
193
+ ; empty strings, and by any other string it is not.
194
+ def abnf-same [a b]
195
+ match b
196
+ case "" (abnf-empty a)
197
+ case _
198
+ match (split b a)
199
+ case ["" ""] true
200
+ case _ false
201
+
202
+ def abnf-not [x]
203
+ match x
204
+ case true false
205
+ case false true
206
+
207
+ def abnf-less [a b]
208
+ match (compare a b)
209
+ case :less true
210
+ case _ false
211
+
212
+ def abnf-some [v]
213
+ match (count v)
214
+ case 0 false
215
+ case _ true
216
+
217
+ def abnf-none [v]
218
+ match (count v)
219
+ case 0 true
220
+ case _ false
221
+
222
+ def abnf-rest [v]
223
+ map (fn [i] (abnf-at v i)) (filter (fn [i] (match i (case 0 false) (case _ true))) (indices v))
224
+
225
+ def abnf-take [n v]
226
+ map (fn [i] (abnf-at v i)) (filter (fn [i] (abnf-less i n)) (indices v))
227
+
228
+ def abnf-drop [n v]
229
+ map (fn [i] (abnf-at v i)) (filter (fn [i] (abnf-not (abnf-less i n))) (indices v))
230
+
231
+ ; Whether s begins with the non-empty p, ends with it; s after its first
232
+ ; p, before its last.
233
+ def abnf-starts [p s]
234
+ match s
235
+ case "" false
236
+ case _ (abnf-empty (abnf-at (split p s) 0))
237
+
238
+ def abnf-ends [p s]
239
+ match s
240
+ case "" false
241
+ case _ (abnf-empty (top (split p s)))
242
+
243
+ def abnf-after [p s]
244
+ string-join p (abnf-rest (split p s))
245
+
246
+ def abnf-before [p s]
247
+ string-join p (pop (split p s))
248
+
249
+ def abnf-digits [s]
250
+ match s
251
+ case "" false
252
+ case _ (chars-within [[48 57]] s)
253
+
254
+ ; The items of two vectors, and of a vector of vectors, in order: each
255
+ ; item is named by its place, the places joined as text and read back.
256
+ def abnf-cat [a b]
257
+ abnf-flat [a b]
258
+
259
+ def abnf-flat [vv]
260
+ map
261
+ fn [t]
262
+ let [p (split "." t)]
263
+ get-path (as-path [(number (abnf-at p 0)) (number (abnf-at p 1))]) vv
264
+ filter abnf-full
265
+ split ","
266
+ string-join ","
267
+ map
268
+ fn [j]
269
+ string-join "," (map (fn [i] (string-join "." [(abnf-num j) (abnf-num i)])) (indices (abnf-at vv j)))
270
+ indices vv
271
+
272
+ ; Whether the string s is among the strings of v.
273
+ def abnf-among [s v]
274
+ abnf-some (filter (fn [x] (abnf-same x s)) v)
275
+
276
+ ; The items of v whose key is the first of its kind, in order.
277
+ def abnf-unique [keyf v]
278
+ let [ks (map keyf v)]
279
+ let [prev (abnf-cat ["\\u0000"] (pop (abnf-cat ks ["\\u0000"])))]
280
+ let [runs (filter (fn [i] (abnf-not (abnf-same (abnf-at ks i) (abnf-at prev i)))) (indices ks))]
281
+ map
282
+ fn [i] (abnf-at v i)
283
+ filter
284
+ fn [i]
285
+ abnf-none (filter (fn [j] (match (abnf-less j i) (case true (abnf-same (abnf-at ks j) (abnf-at ks i))) (case false false))) runs)
286
+ runs
287
+
288
+ def abnf-plus [a b]
289
+ length (string-join "" [(repeat a "x") (repeat b "x")])
290
+
291
+ def abnf-ones [n]
292
+ pop (split "x" (repeat n "x"))
293
+
294
+ def abnf-even [j]
295
+ abnf-some (filter (fn [d] (abnf-ends d (abnf-num j))) ["0" "2" "4" "6" "8"])
296
+
297
+ def abnf-fail [what]
298
+ fail :unrepresentable (string-join "" ["the grammar spec cannot be written as ABNF: " what])
299
+
300
+ ; ---- the spec
301
+
302
+ def abnf-rec [v]
303
+ match (kind v)
304
+ case :record v
305
+ case _ (record)
306
+
307
+ def abnf-vec [v]
308
+ match (kind v)
309
+ case :vector (as-vector v)
310
+ case _ []
311
+
312
+ def abnf-str [v]
313
+ match (kind v)
314
+ case :string v
315
+ case _ ""
316
+
317
+ def abnf-context [spec]
318
+ let [o (abnf-rec (get "options" spec))]
319
+ record
320
+ entry :rules (abnf-rec (get "rule" spec))
321
+ entry :fixed (abnf-rec (get-path (as-path ["fixed" "token"]) o))
322
+ entry :match (abnf-rec (get-path (as-path ["match" "token"]) o))
323
+ entry :sets (abnf-rec (get "tokenSet" o))
324
+ entry :prov (get-path (as-path ["meta" "provenance"]) spec)
325
+ entry :start (abnf-str (get-path (as-path ["rule" "start"]) o))
326
+
327
+ def abnf-rule [cx name]
328
+ get-path (as-path [name]) (get :rules cx)
329
+
330
+ def abnf-has [cx name]
331
+ match (kind (abnf-rule cx name))
332
+ case :record true
333
+ case _ false
334
+
335
+ ; A rule's alternates in one phase, the falsy placeholders the engine
336
+ ; skips left out.
337
+ def abnf-open [r]
338
+ filter (fn [alt] (match (kind alt) (case :record true) (case _ false))) (abnf-vec (get "open" r))
339
+
340
+ def abnf-close [r]
341
+ filter (fn [alt] (match (kind alt) (case :record true) (case _ false))) (abnf-vec (get "close" r))
342
+
343
+ ; The tokens an alternate matches: its \`s\`, a string of token names
344
+ ; between spaces or a list of them.
345
+ def abnf-s [alt]
346
+ let [s (get "s" alt)]
347
+ match (kind s)
348
+ case :string (filter abnf-full (split " " s))
349
+ case :vector (map abnf-str (as-vector s))
350
+ case _ []
351
+
352
+ def abnf-b [alt]
353
+ match (kind (get "b" alt))
354
+ case :number (get "b" alt)
355
+ case _ 0
356
+
357
+ def abnf-p [alt]
358
+ abnf-str (get "p" alt)
359
+
360
+ def abnf-r [alt]
361
+ abnf-str (get "r" alt)
362
+
363
+ def abnf-a [alt]
364
+ match (kind (get "a" alt))
365
+ case :string (get "a" alt)
366
+ case :missing ""
367
+ case :null ""
368
+ case _ "?"
369
+
370
+ ; Whether the compiler made the rule: provenance names every rule it
371
+ ; synthesized, and a spec without provenance is read by the names it
372
+ ; gives them.
373
+ def abnf-made [cx name]
374
+ match (kind (get :prov cx))
375
+ case :record
376
+ match (kind (get-path (as-path [name]) (get :prov cx)))
377
+ case :string true
378
+ case _ false
379
+ case _
380
+ match (abnf-some (abnf-rest (split "$" name)))
381
+ case true (abnf-split-name name)
382
+ case false
383
+ match (abnf-gen-kind name)
384
+ case ""
385
+ match (abnf-same name (get :start cx))
386
+ case true (abnf-wrapper (abnf-rule cx name))
387
+ case false false
388
+ case k (abnf-helper-shape cx name k)
389
+
390
+ ; The kind of helper a name gives, as the compiler names the helpers it
391
+ ; makes, \`_gen<n>_<kind>...\` with the kind a repetition's, an option's or
392
+ ; a group's (\`_gen3_star_x\`, \`_gen4_group\`), or "" for any other name: a
393
+ ; rule the author wrote may begin with \`_gen\` too (\`_general\`).
394
+ def abnf-gen-kind [name]
395
+ match (abnf-starts "_gen" name)
396
+ case false ""
397
+ case true
398
+ let [parts (split "_" (abnf-after "_gen" name))]
399
+ match (count parts)
400
+ case 1 ""
401
+ case _
402
+ match (match (abnf-digits (abnf-at parts 0)) (case true (abnf-among (abnf-at parts 1) ["star" "plus" "opt" "rep" "group"])) (case false false))
403
+ case true (abnf-at parts 1)
404
+ case false ""
405
+
406
+ ; Whether a name is one the compiler gives a rule it splits off another,
407
+ ; every part after a \`$\` one of its own: a dispatcher's alternative
408
+ ; (\`$alt<i>\`), a chain's step (\`$step<j>\`), a left-factored tail
409
+ ; (\`$fact<k>\`), a probe dispatcher (\`$pd<i>\`) and its parts (\`$probe\`,
410
+ ; \`$with\`, \`$no\`, numbered where the name was taken).
411
+ def abnf-split-name [name]
412
+ abnf-none (filter (fn [p] (abnf-not (abnf-split-part p))) (abnf-rest (split "$" name)))
413
+
414
+ def abnf-split-part [p]
415
+ abnf-some (filter (fn [k] (abnf-split-fits k p)) ["alt" "step" "fact" "pd" "probe" "with" "no"])
416
+
417
+ def abnf-split-fits [k p]
418
+ match (abnf-starts k p)
419
+ case false false
420
+ case true
421
+ match (abnf-after k p)
422
+ case "" (abnf-among k ["probe" "with" "no"])
423
+ case rest (abnf-digits rest)
424
+
425
+ ; A rule named as the compiler names a helper, in a spec that names no
426
+ ; provenance, is the compiler's where it has the shape the compiler gives
427
+ ; that kind, and the author's otherwise: a repetition's loop has its
428
+ ; guarded entry (\`{c: {n.rep: 0}, r: <self>}\`); a plus is its item and the
429
+ ; loop after it; an option one element and the empty alternative; a
430
+ ; counted repetition copies of one element, and the option or the loop
431
+ ; after them; a group any alternatives.
432
+ def abnf-helper-shape [cx name k]
433
+ match k
434
+ case "group" true
435
+ case "star" (abnf-some (filter (fn [alt] (abnf-loop-entry name alt)) (abnf-open (abnf-rule cx name))))
436
+ case _
437
+ let [alts (abnf-raw-alts cx name)]
438
+ match k
439
+ case "plus" (abnf-plus-shape alts)
440
+ case "opt" (abnf-opt-shape alts)
441
+ case _ (abnf-rep-shape alts)
442
+
443
+ def abnf-loop-entry [name alt]
444
+ match (abnf-same (abnf-r alt) name)
445
+ case false false
446
+ case true
447
+ let [c (get "c" alt)]
448
+ match (kind c)
449
+ case :record (abnf-loop-value c "n.rep" [0])
450
+ case _ false
451
+
452
+ def abnf-plus-shape [alts]
453
+ match (count alts)
454
+ case 1
455
+ let [seq (abnf-vec (abnf-at alts 0))]
456
+ match (count seq)
457
+ case 2 (abnf-same (abnf-helper-ref (abnf-at seq 1)) "star")
458
+ case _ false
459
+ case _ false
460
+
461
+ def abnf-opt-shape [alts]
462
+ match (count alts)
463
+ case 2
464
+ let [counts (map count alts)]
465
+ match (abnf-among "0" (map abnf-num counts))
466
+ case true (abnf-among "1" (map abnf-num counts))
467
+ case false false
468
+ case _ false
469
+
470
+ def abnf-rep-shape [alts]
471
+ match (count alts)
472
+ case 1
473
+ let [seq (abnf-vec (abnf-at alts 0))]
474
+ match (count seq)
475
+ case 0 true
476
+ case _
477
+ let [lead (match (abnf-among (abnf-helper-ref (top seq)) ["star" "opt"]) (case true (pop seq)) (case false seq))]
478
+ let [keys (map abnf-el-name lead)]
479
+ abnf-none (filter (fn [key] (match key (case "" true) (case _ (abnf-not (abnf-same key (abnf-at keys 0)))))) keys)
480
+ case _ false
481
+
482
+ ; The kind of helper an element references by name, or "".
483
+ def abnf-helper-ref [el]
484
+ match (get :k el)
485
+ case :ref (abnf-gen-kind (get :name el))
486
+ case _ ""
487
+
488
+ ; A token or a reference by its name, any other element "".
489
+ def abnf-el-name [el]
490
+ match (get :k el)
491
+ case :tok (string-join "" ["#" (get :name el)])
492
+ case :ref (string-join "" ["@" (get :name el)])
493
+ case _ ""
494
+
495
+ ; The start wrapper the compiler adds, which \`options.rule.start\` names:
496
+ ; one open alternate that consumes nothing and pushes the grammar's start
497
+ ; rule, and the end of the source, and nothing else, to close it.
498
+ def abnf-wrapper [r]
499
+ let [o (abnf-open r)]
500
+ match (count o)
501
+ case 1
502
+ let [a (abnf-at o 0)]
503
+ match (match (abnf-some (abnf-s a)) (case true false) (case false (abnf-full (abnf-p a))))
504
+ case false false
505
+ case true
506
+ let [c (abnf-close r)]
507
+ match (count c)
508
+ case 0 false
509
+ case _ (abnf-none (filter (fn [x] (abnf-not (abnf-wrapper-end x))) c))
510
+ case _ false
511
+
512
+ ; A close alternate that matches the end of the source and goes nowhere.
513
+ def abnf-wrapper-end [alt]
514
+ match (abnf-same (string-join " " (abnf-s alt)) "#ZZ")
515
+ case false false
516
+ case true (abnf-empty (abnf-target alt))
517
+
518
+ ; Every grammar text compiles to a start wrapper around its start rule,
519
+ ; and the wrapper's close lets the end of the source come after what the
520
+ ; lexer skips (\`ab \` where the grammar is \`ab\`). So the rule
521
+ ; \`options.rule.start\` names must be that wrapper: a spec that starts at
522
+ ; another rule, or at a wrapper without its close, would come back
523
+ ; accepting what it refuses.
524
+ def abnf-check-start [cx]
525
+ match (abnf-wrapper (abnf-rule cx (get :start cx)))
526
+ case true true
527
+ case false (abnf-fail (string-join "" ["the start rule " (get :start cx) " is not the start wrapper every grammar text compiles to (one open alternate that matches nothing and pushes a rule, closed by the end of the source alone)"]))
528
+
529
+ ; The kind the tree builders give a rule the author wrote: "user", or
530
+ ; "core" for an RFC 5234 core rule the compiler added.
531
+ def abnf-kind [r]
532
+ let [o (abnf-open r)]
533
+ match (count o)
534
+ case 0 "user"
535
+ case _
536
+ match (abnf-str (get-path (as-path ["k" "node$" "kind"]) (abnf-at o 0)))
537
+ case "core" "core"
538
+ case _ "user"
539
+
540
+ ; ---- what the spec may hold
541
+
542
+ ; Every alternate is one the compiler's tree-building grammars are made
543
+ ; of: the tokens it matches and gives back (\`s\`, \`b\`), the rule it pushes
544
+ ; or replaces itself with (\`p\`, \`r\`), the tree builders (\`a\`, \`k\`), group
545
+ ; tags, marks and per-rule scratch (\`g\`, \`m\`, \`u\`), and, in a repeat loop
546
+ ; alone, the loop's guard and counter (\`c\`, \`n\`). Anything more is a
547
+ ; construct the notation does not write: an error generator (\`e\`), an
548
+ ; alternate modifier (\`h\`), a function in place of a rule or a count, an
549
+ ; action other than the tree builders, another condition or counter.
550
+ def abnf-alt-keys ["s" "b" "p" "r" "a" "c" "n" "k" "g" "m" "u"]
551
+
552
+ def abnf-key-text [key]
553
+ match key
554
+ case "e" "e (an error generator)"
555
+ case "h" "h (an alternate modifier)"
556
+ case _ key
557
+
558
+ def abnf-check-alt [cx name alt]
559
+ let [extra (filter (fn [key] (match (abnf-among key abnf-alt-keys) (case true false) (case false (abnf-given (get key alt))))) (keys alt))]
560
+ match (count extra)
561
+ case 0 (abnf-check-parts cx name alt)
562
+ case _ (abnf-fail (string-join "" ["rule " name " has an alternate carrying " (string-join ", " (map abnf-key-text extra)) ", which is not written"]))
563
+
564
+ def abnf-check-parts [cx name alt]
565
+ let [a (abnf-a alt)]
566
+ match (abnf-among a ["" "@node$" "@capture$" "@bubble$" "@fold$"])
567
+ case false
568
+ match (abnf-starts "@probe" (abnf-action-text alt))
569
+ case true (abnf-fail (string-join "" ["rule " name " is the probe dispatcher the compiler makes for an optional prefix ([ X D ] Y), which is not read back"]))
570
+ case false (abnf-fail (string-join "" ["rule " name " carries an action (" (abnf-action-text alt) "), which is not written"]))
571
+ case true
572
+ let [tokens (abnf-check-s name (get "s" alt))]
573
+ let [next (count (map (fn [key] (abnf-check-next name key (get key alt))) ["p" "r"]))]
574
+ let [back (abnf-check-back name (get "b" alt))]
575
+ abnf-check-loop cx name alt
576
+
577
+ ; The tokens: a string of names between spaces, or a list of names, one
578
+ ; place each; a place holding a set of tokens (names between spaces, or a
579
+ ; list) chooses among them, which the render does not read back.
580
+ def abnf-check-s [name s]
581
+ match (kind s)
582
+ case :missing true
583
+ case :null true
584
+ case :string true
585
+ case :vector
586
+ match (abnf-none (filter (fn [t] (match (kind t) (case :string (abnf-some (abnf-rest (split " " t)))) (case _ true))) (as-vector s)))
587
+ case true true
588
+ case false (abnf-fail (string-join "" ["rule " name " has an alternate whose s holds, at one place, a set of tokens or something other than a token's name, which is not written"]))
589
+ case _ (abnf-fail (string-join "" ["rule " name " has an alternate whose s is not tokens, which is not written"]))
590
+
591
+ ; The rule an alternate pushes or replaces itself with: a name, or none;
592
+ ; a function reference (\`@name\`) chooses at run time and is not written.
593
+ def abnf-check-next [name key v]
594
+ match (kind v)
595
+ case :missing true
596
+ case :null true
597
+ case :boolean (match v (case false true) (case _ (abnf-fail (string-join "" ["rule " name " has an alternate whose " key " is not a rule, which is not written"]))))
598
+ case :string
599
+ match (abnf-starts "@" v)
600
+ case true (abnf-fail (string-join "" ["rule " name " has an alternate whose " key " is the function reference " v ", which is not written"]))
601
+ case false true
602
+ case _ (abnf-fail (string-join "" ["rule " name " has an alternate whose " key " is not a rule, which is not written"]))
603
+
604
+ def abnf-check-back [name v]
605
+ match (kind v)
606
+ case :missing true
607
+ case :null true
608
+ case :number true
609
+ case :boolean (match v (case false true) (case _ (abnf-fail (string-join "" ["rule " name " has an alternate whose b is not a count, which is not written"]))))
610
+ case _ (abnf-fail (string-join "" ["rule " name " has an alternate whose b is not a count (" (abnf-str v) "), which is not written"]))
611
+
612
+ ; A repeat loop's guard (\`c: {n.rep: 0}\`) and counter (\`n: {rep: 0}\` or
613
+ ; \`{rep: 1}\`), in the loop the compiler makes for a repetition and the
614
+ ; steps of its item, and nowhere else.
615
+ def abnf-loop-rule [cx name]
616
+ abnf-same (abnf-helper-kind cx (abnf-at (split "$" name) 0)) "star"
617
+
618
+ def abnf-check-loop [cx name alt]
619
+ let [c (get "c" alt)]
620
+ let [n (get "n" alt)]
621
+ match (match (abnf-given c) (case true true) (case false (abnf-given n)))
622
+ case false true
623
+ case true
624
+ match (abnf-loop-rule cx name)
625
+ case false (abnf-fail (string-join "" ["rule " name " carries a condition or a counter outside a repetition's loop, which is not written"]))
626
+ case true
627
+ match (match (abnf-given c) (case false true) (case true (match (kind c) (case :record (abnf-loop-value c "n.rep" [0])) (case _ false))))
628
+ case false (abnf-fail (string-join "" ["rule " name " carries a condition other than its loop's, which is not written"]))
629
+ case true
630
+ match (match (abnf-given n) (case false true) (case true (match (kind n) (case :record (abnf-loop-value n "rep" [0 1])) (case _ false))))
631
+ case false (abnf-fail (string-join "" ["rule " name " carries a counter other than its loop's, which is not written"]))
632
+ case true true
633
+
634
+ ; Whether an alternate gives a field: the engine reads a field that is
635
+ ; missing, null or false as one it does not give.
636
+ def abnf-given [v]
637
+ match (kind v)
638
+ case :missing false
639
+ case :null false
640
+ case :boolean (match v (case false false) (case _ true))
641
+ case _ true
642
+
643
+ def abnf-loop-value [rec key allowed]
644
+ match (keys rec)
645
+ case [only]
646
+ match (abnf-same only key)
647
+ case false false
648
+ case true
649
+ let [v (get-path (as-path [key]) rec)]
650
+ abnf-some (filter (fn [x] (match (compare v x) (case :equal true) (case _ false))) allowed)
651
+ case _ false
652
+
653
+ def abnf-action-text [alt]
654
+ match (kind (get "a" alt))
655
+ case :string (get "a" alt)
656
+ case :vector (string-join " " (map abnf-str (as-vector (get "a" alt))))
657
+ case _ "a function"
658
+
659
+ ; A rule's phases: a list of alternates each, or none; the form that edits
660
+ ; a rule already installed (\`{alts, inject}\`) is not written.
661
+ def abnf-check-phase [name phase v]
662
+ match (kind v)
663
+ case :missing true
664
+ case :null true
665
+ case :vector true
666
+ case :record (abnf-fail (string-join "" ["rule " name " gives its " phase " alternates as alts and an inject, which edits a rule already installed and is not written"]))
667
+ case _ (abnf-fail (string-join "" ["rule " name " gives its " phase " alternates in a form that is not a list, which is not written"]))
668
+
669
+ def abnf-check-rule [cx name]
670
+ let [r (abnf-rule cx name)]
671
+ match (kind r)
672
+ case :record
673
+ let [phases (count (map (fn [phase] (abnf-check-phase name phase (get phase r))) ["open" "close"]))]
674
+ match (count (abnf-open r))
675
+ case 0 (abnf-fail (string-join "" ["rule " name " has no alternate to open with, which no grammar text writes"]))
676
+ case _ (count (map (fn [alt] (abnf-check-alt cx name alt)) (abnf-cat (abnf-open r) (abnf-close r))))
677
+ case :null (abnf-fail (string-join "" ["rule " name " is removed, which is not written"]))
678
+ case _ (abnf-fail (string-join "" ["rule " name " is not a rule's alternates, which is not written"]))
679
+
680
+ ; A spec serialized by Go writes its keys in name order and its match
681
+ ; tokens' order in a list of its own (\`options.match.tokenOrder\`): the
682
+ ; rules' order, which decides the order the compiler gives the tokens
683
+ ; again, is lost, and with it which of two tokens that both match wins.
684
+ def abnf-check-order [spec]
685
+ let [order (get-path (as-path ["options" "match" "tokenOrder"]) spec)]
686
+ match (kind order)
687
+ case :vector
688
+ match (abnf-less (count (as-vector order)) 2)
689
+ case true true
690
+ case false (abnf-fail "it gives its match tokens' order as a list of its own (tokenOrder, Go's serialization, whose keys are in name order), and the order of the rules, which their precedence follows, is lost")
691
+ case _ true
692
+
693
+ def abnf-check [spec cx]
694
+ match (get "clear" spec)
695
+ case true (abnf-fail "it clears the grammar it is installed on, which is not written")
696
+ case _
697
+ let [order (abnf-check-order spec)]
698
+ let [start (abnf-check-start cx)]
699
+ let [rules (count (map (fn [name] (abnf-check-rule cx name)) (keys (get :rules cx))))]
700
+ abnf-check-sets cx (abnf-used cx)
701
+
702
+ ; ---- tokens
703
+
704
+ def abnf-bare [t]
705
+ abnf-after "#" t
706
+
707
+ def abnf-lit [text cs]
708
+ record
709
+ entry :k :lit
710
+ entry :text text
711
+ entry :cs cs
712
+
713
+ def abnf-class [pat flags]
714
+ record
715
+ entry :k :class
716
+ entry :pat pat
717
+ entry :flags flags
718
+
719
+ ; A pattern's escapes taken back off: an escaped backslash is a pair, any
720
+ ; other escape one backslash before the character it escapes.
721
+ def abnf-unescape [s]
722
+ string-join "\\\\" (map (fn [piece] (string-join "" (split "\\\\" piece))) (split "\\\\\\\\" s))
723
+
724
+ ; A match token's source, \`@~/^.../flags\`: a class, or a case-folding
725
+ ; literal.
726
+ def abnf-match-token [t m]
727
+ let [parts (split "/" m)]
728
+ let [flags (top parts)]
729
+ let [src (string-join "/" (pop (abnf-rest parts)))]
730
+ match (abnf-starts "^" src)
731
+ case false (abnf-fail (string-join "" ["the token " t " is the pattern " m ", which no ABNF terminal matches"]))
732
+ case true
733
+ let [body (abnf-after "^" src)]
734
+ match (abnf-starts "[" body)
735
+ case true
736
+ match (abnf-class-pattern body)
737
+ case false (abnf-fail (string-join "" ["the token " t " is the pattern " m ", which is not one class the render reads, and no ABNF terminal matches it"]))
738
+ case true
739
+ match (abnf-flags-fit body flags)
740
+ case true (abnf-class body flags)
741
+ case false (abnf-fail (string-join "" ["the token " t " is the class " m ", whose flags (" (match flags (case "" "none") (case _ flags)) ") change what it matches, and no ABNF terminal matches it"]))
742
+ case false
743
+ match flags
744
+ case "i"
745
+ match (abnf-escaped-literal body)
746
+ case true (abnf-lit (abnf-unescape body) false)
747
+ case false (abnf-fail (string-join "" ["the token " t " is the pattern " m ", which is not a literal the render reads, and no ABNF terminal matches it"]))
748
+ case _ (abnf-fail (string-join "" ["the token " t " is the pattern " m ", which no ABNF terminal matches"]))
749
+
750
+ ; Whether a pattern's body is one class as the compiler writes one:
751
+ ; \`[\`, an optional \`^\`, members each a \`\\uXXXX\` or \`\\u{X...}\` escape, alone
752
+ ; or the low end of a range, and \`]\` ending it; or \`[\\s\\S]\`, which
753
+ ; another notation's \`.\` compiles to.
754
+ def abnf-class-pattern [body]
755
+ match body
756
+ case "[\\\\s\\\\S]" true
757
+ case _
758
+ match (abnf-ends "]" body)
759
+ case false false
760
+ case true
761
+ let [inner (abnf-before "]" (abnf-after "[" body))]
762
+ match (abnf-some (filter (fn [c] (abnf-some (abnf-rest (split c inner)))) ["[" "]"]))
763
+ case true false
764
+ case false
765
+ let [pieces (split "\\\\u" (match (abnf-starts "^" inner) (case true (abnf-after "^" inner)) (case false inner)))]
766
+ match (abnf-empty (abnf-at pieces 0))
767
+ case false false
768
+ case true
769
+ let [members (abnf-rest pieces)]
770
+ match (count members)
771
+ case 0 false
772
+ case _
773
+ match (abnf-ends "-" (top members))
774
+ case true false
775
+ case false (abnf-none (filter (fn [m] (abnf-not (abnf-member-piece m))) members))
776
+
777
+ def abnf-member-piece [piece]
778
+ let [core (match (abnf-ends "-" piece) (case true (abnf-before "-" piece)) (case false piece))]
779
+ match (abnf-starts "{" core)
780
+ case true
781
+ match (abnf-ends "}" core)
782
+ case false false
783
+ case true
784
+ let [h (abnf-before "}" (abnf-after "{" core))]
785
+ match (abnf-among (abnf-num (length h)) ["1" "2" "3" "4" "5" "6"])
786
+ case false false
787
+ case true (abnf-hex-only h)
788
+ case false
789
+ match (length core)
790
+ case 4 (abnf-hex-only core)
791
+ case _ false
792
+
793
+ def abnf-hex-only [h]
794
+ match h
795
+ case "" false
796
+ case _ (chars-within [[48 57] [65 70] [97 102]] h)
797
+
798
+ ; Whether a pattern's body is a literal as the compiler escapes one: every
799
+ ; character a pattern reads otherwise (\`\\ ^ $ . * + ? ( ) [ ] { } |\`)
800
+ ; after a backslash, and a backslash before nothing else.
801
+ def abnf-meta-chars ["^" "$" "." "*" "+" "?" "(" ")" "[" "]" "{" "}" "|"]
802
+
803
+ def abnf-escaped-literal [body]
804
+ let [rest (abnf-strip-escapes abnf-strip-escapes abnf-meta-chars (string-join "" (split "\\\\\\\\" body)))]
805
+ match (abnf-some (abnf-rest (split "\\\\" rest)))
806
+ case true false
807
+ case false (abnf-none (filter (fn [c] (abnf-some (abnf-rest (split c rest)))) abnf-meta-chars))
808
+
809
+ def abnf-strip-escapes [self cs s]
810
+ match (count cs)
811
+ case 0 s
812
+ case _ (self self (pop cs) (string-join "" (split (string-join "" ["\\\\" (top cs)]) s)))
813
+
814
+ ; A token set's class, read back from its name, which the compiler gives
815
+ ; the class it lays over the atoms (\`rx_\` and the pattern, each character
816
+ ; that is not a letter or a digit an underscore, in capitals). Each member
817
+ ; of the pattern is a \`\\u\` escape, \`\\uXXXX\` or \`\\u{X...}\`, alone or the
818
+ ; low end of a range; the name keeps their digits and order.
819
+ def abnf-hex-lower [h]
820
+ string-join "a" (split "A" (string-join "b" (split "B" (string-join "c" (split "C" (string-join "d" (split "D" (string-join "e" (split "E" (string-join "f" (split "F" h)))))))))))
821
+
822
+ def abnf-hex-upper [h]
823
+ string-join "A" (split "a" (string-join "B" (split "b" (string-join "C" (split "c" (string-join "D" (split "d" (string-join "E" (split "e" (string-join "F" (split "f" h)))))))))))
824
+
825
+ def abnf-set-member [piece]
826
+ let [parts (split "_" piece)]
827
+ match (abnf-empty (abnf-at parts 0))
828
+ case true
829
+ record
830
+ entry :text (string-join "" ["\\\\u{" (abnf-hex-lower (abnf-at parts 1)) "}"])
831
+ entry :braced true
832
+ entry :range (match (count parts) (case 4 true) (case _ false))
833
+ case false
834
+ record
835
+ entry :text (string-join "" ["\\\\u" (abnf-hex-lower (abnf-at parts 0))])
836
+ entry :braced false
837
+ entry :range (match (count parts) (case 2 true) (case _ false))
838
+
839
+ def abnf-set-token [t]
840
+ let [rest (abnf-after "RX_" (abnf-bare t))]
841
+ match rest
842
+ case "__S_S" (abnf-class "[\\\\s\\\\S]" "u")
843
+ case _
844
+ let [pieces (split "_U" rest)]
845
+ let [members (map abnf-set-member (abnf-rest pieces))]
846
+ let [negated (abnf-same (abnf-at pieces 0) "__")]
847
+ let [body (string-join "" (map (fn [m] (string-join "" [(get :text m) (match (get :range m) (case true "-") (case false ""))])) members))]
848
+ let [pat (string-join "" ["[" (match negated (case true "^") (case false "")) body "]"])]
849
+ match (abnf-same (abnf-class-name pat) (abnf-bare t))
850
+ case false (abnf-fail (string-join "" ["the token set " t " names no class the render can read back"]))
851
+ case true
852
+ match negated
853
+ case true (abnf-class pat "u")
854
+ case false (abnf-class pat (match (abnf-some (filter (fn [m] (get :braced m)) members)) (case true "u") (case false "")))
855
+
856
+ ; The name the compiler gives a class's token: \`rx_\` and its pattern, every
857
+ ; character but a letter or a digit an underscore, in capitals, with the
858
+ ; underscores at the end taken off.
859
+ def abnf-class-name [pat]
860
+ let [u (abnf-hex-upper (string-join "U" (split "u" (string-join "S" (split "s" pat)))))]
861
+ let [n (string-join "_" (split "[" (string-join "_" (split "]" (string-join "_" (split "^" (string-join "_" (split "-" (string-join "_" (split "\\\\" (string-join "_" (split "{" (string-join "_" (split "}" u))))))))))))))]
862
+ abnf-trim-end (string-join "" ["RX_" n])
863
+
864
+ def abnf-trim-end [s]
865
+ match (abnf-ends "_" s)
866
+ case true (abnf-trim-end-once (abnf-before "_" s))
867
+ case false s
868
+
869
+ def abnf-trim-end-once [s]
870
+ match (abnf-ends "_" s)
871
+ case true (abnf-before "_" s)
872
+ case false s
873
+
874
+ ; ---- code points and the ranges a class holds
875
+
876
+ ; A code point, from its one to six hexadecimal digits in either case, as
877
+ ; three numbers, its bytes from the highest, each the place of its two
878
+ ; digits among \`abnf-hex-pairs\`: code points are ordered as these are.
879
+ def abnf-cp [h]
880
+ let [x (abnf-six (abnf-hex-upper h))]
881
+ let [high (abnf-pair-start x)]
882
+ let [rest (abnf-after high x)]
883
+ vector (abnf-pair-index high) (abnf-pair-index (abnf-pair-start rest)) (abnf-pair-index (abnf-pair-end rest))
884
+
885
+ def abnf-six [h]
886
+ string-join "" [(match (length h) (case 1 "00000") (case 2 "0000") (case 3 "000") (case 4 "00") (case 5 "0") (case _ "")) h]
887
+
888
+ def abnf-pair-start [x]
889
+ abnf-at (filter (fn [p] (abnf-starts p x)) abnf-hex-pairs) 0
890
+
891
+ def abnf-pair-end [x]
892
+ abnf-at (filter (fn [p] (abnf-ends p x)) abnf-hex-pairs) 0
893
+
894
+ def abnf-pair-index [p]
895
+ abnf-at (filter (fn [i] (abnf-same (abnf-at abnf-hex-pairs i) p)) (indices abnf-hex-pairs)) 0
896
+
897
+ def abnf-cp-order [a b]
898
+ match (compare (abnf-at a 0) (abnf-at b 0))
899
+ case :equal
900
+ match (compare (abnf-at a 1) (abnf-at b 1))
901
+ case :equal (compare (abnf-at a 2) (abnf-at b 2))
902
+ case other other
903
+ case other other
904
+
905
+ def abnf-cp-before [a b]
906
+ match (abnf-cp-order a b)
907
+ case :less true
908
+ case _ false
909
+
910
+ def abnf-cp-is [a b]
911
+ match (abnf-cp-order a b)
912
+ case :equal true
913
+ case _ false
914
+
915
+ ; The code point after one: its low byte one more, carried into the bytes
916
+ ; above it.
917
+ def abnf-cp-next [c]
918
+ match (abnf-at c 2)
919
+ case 255
920
+ match (abnf-at c 1)
921
+ case 255 (vector (abnf-plus (abnf-at c 0) 1) 0 0)
922
+ case _ (vector (abnf-at c 0) (abnf-plus (abnf-at c 1) 1) 0)
923
+ case _ (vector (abnf-at c 0) (abnf-at c 1) (abnf-plus (abnf-at c 2) 1))
924
+
925
+ def abnf-cp-max [cps]
926
+ abnf-at (filter (fn [c] (abnf-none (filter (fn [d] (abnf-cp-before c d)) cps))) cps) 0
927
+
928
+ def abnf-span [lo hi]
929
+ record
930
+ entry :lo lo
931
+ entry :hi hi
932
+
933
+ ; The members of a class's pattern, read as \`abnf-class-pattern\` admits
934
+ ; them: each a range, from its low end's digits to its high end's (a
935
+ ; character alone is a range of one); \`[\\s\\S]\` every code point. A
936
+ ; negated class's are the ones it excludes.
937
+ def abnf-class-hex-spans [body]
938
+ match body
939
+ case "[\\\\s\\\\S]" [(abnf-span "0" "10FFFF")]
940
+ case _
941
+ let [inner (abnf-before "]" (abnf-after "[" body))]
942
+ let [pieces (abnf-rest (split "\\\\u" (match (abnf-starts "^" inner) (case true (abnf-after "^" inner)) (case false inner))))]
943
+ let [lows (map (fn [p] (abnf-ends "-" p)) pieces)]
944
+ let [ends (abnf-cat [false] lows)]
945
+ map
946
+ fn [i]
947
+ let [lo (abnf-piece-hex (abnf-at pieces i))]
948
+ match (abnf-at lows i)
949
+ case true (abnf-span lo (abnf-piece-hex (abnf-at pieces (abnf-plus i 1))))
950
+ case false (abnf-span lo lo)
951
+ filter (fn [i] (abnf-not (abnf-at ends i))) (indices pieces)
952
+
953
+ def abnf-piece-hex [p]
954
+ let [core (match (abnf-ends "-" p) (case true (abnf-before "-" p)) (case false p))]
955
+ match (abnf-starts "{" core)
956
+ case true (abnf-before "}" (abnf-after "{" core))
957
+ case false core
958
+
959
+ def abnf-class-spans [body]
960
+ map (fn [s] (abnf-span (abnf-cp (get :lo s)) (abnf-cp (get :hi s)))) (abnf-class-hex-spans body)
961
+
962
+ ; Ranges sorted by their low ends and merged where they overlap or meet:
963
+ ; two lists of ranges hold the same code points when these are the same.
964
+ def abnf-spans-merged [spans]
965
+ let [sorted (abnf-spans-sorted spans)]
966
+ let [starts (filter (fn [i] (abnf-none (filter (fn [j] (match (abnf-less j i) (case true (abnf-not (abnf-cp-before (abnf-cp-next (get :hi (abnf-at sorted j))) (get :lo (abnf-at sorted i))))) (case false false))) (indices sorted)))) (indices sorted))]
967
+ map (fn [k] (abnf-block-span sorted starts k)) (indices starts)
968
+
969
+ def abnf-block-span [sorted starts k]
970
+ let [from (abnf-at starts k)]
971
+ let [members (filter (fn [i] (match (abnf-less i from) (case true false) (case false (abnf-before-start starts k i)))) (indices sorted))]
972
+ abnf-span (get :lo (abnf-at sorted from)) (abnf-cp-max (map (fn [i] (get :hi (abnf-at sorted i))) members))
973
+
974
+ def abnf-before-start [starts k i]
975
+ match (abnf-less (abnf-plus k 1) (count starts))
976
+ case true (abnf-less i (abnf-at starts (abnf-plus k 1)))
977
+ case false true
978
+
979
+ def abnf-spans-sorted [spans]
980
+ let [ranks (map (fn [i] (count (filter (fn [j] (match (abnf-cp-order (get :lo (abnf-at spans j)) (get :lo (abnf-at spans i))) (case :less true) (case :equal (abnf-less j i)) (case _ false))) (indices spans)))) (indices spans))]
981
+ map (fn [k] (abnf-at spans (abnf-at (filter (fn [i] (match (compare (abnf-at ranks i) k) (case :equal true) (case _ false))) (indices spans)) 0))) (indices spans)
982
+
983
+ def abnf-spans-same [a b]
984
+ match (compare (count a) (count b))
985
+ case :equal (abnf-none (filter (fn [i] (match (abnf-cp-is (get :lo (abnf-at a i)) (get :lo (abnf-at b i))) (case true (abnf-not (abnf-cp-is (get :hi (abnf-at a i)) (get :hi (abnf-at b i))))) (case false true))) (indices a)))
986
+ case _ false
987
+
988
+ ; Whether two lists of ranges hold every code point between them, each
989
+ ; once: a negated class's ranges and the ranges it matches.
990
+ def abnf-spans-tile [a b]
991
+ let [all (abnf-spans-sorted (abnf-cat (abnf-spans-merged a) (abnf-spans-merged b)))]
992
+ match (count all)
993
+ case 0 false
994
+ case _
995
+ match (match (abnf-cp-is (get :lo (abnf-at all 0)) (abnf-cp "0")) (case true (abnf-cp-is (get :hi (top all)) (abnf-cp "10FFFF"))) (case false false))
996
+ case false false
997
+ case true
998
+ let [nexts (abnf-rest all)]
999
+ abnf-none (filter (fn [i] (abnf-not (abnf-cp-is (get :lo (abnf-at nexts i)) (abnf-cp-next (get :hi (abnf-at all i)))))) (indices nexts))
1000
+
1001
+ ; Whether a class's flags are the ones it is matched with once its text is
1002
+ ; written and compiled back. Every compiler here gives \`u\` to a class that
1003
+ ; is negated, holds a character past U+FFFF or is \`[\\s\\S]\`, and to no
1004
+ ; other. Without \`u\` such a class matches one UTF-16 code unit, half of a
1005
+ ; character past U+FFFF, and with it one code point. A class of other
1006
+ ; characters matches the same either way, unless it holds a surrogate,
1007
+ ; which \`u\` matches only where it stands alone.
1008
+ def abnf-flags-fit [body flags]
1009
+ match (abnf-wants-u body)
1010
+ case true (abnf-same flags "u")
1011
+ case false
1012
+ match (abnf-holds-surrogate body)
1013
+ case true (abnf-empty flags)
1014
+ case false (abnf-among flags ["" "u"])
1015
+
1016
+ def abnf-wants-u [body]
1017
+ match body
1018
+ case "[\\\\s\\\\S]" true
1019
+ case _
1020
+ match (abnf-starts "[^" body)
1021
+ case true true
1022
+ case false (abnf-some (abnf-rest (split "\\\\u{" body)))
1023
+
1024
+ ; A class none of whose members is past U+FFFF holds a surrogate where a
1025
+ ; range's low end is not above U+DFFF and its high end not below U+D800.
1026
+ def abnf-holds-surrogate [body]
1027
+ abnf-some (filter (fn [s] (match (abnf-hex-from (get :lo s) ["E" "F"]) (case true false) (case false (abnf-hex-from (get :hi s) ["D8" "D9" "DA" "DB" "DC" "DD" "DE" "DF" "E" "F"])))) (abnf-class-hex-spans body))
1028
+
1029
+ def abnf-hex-from [h prefixes]
1030
+ let [x (abnf-hex-upper h)]
1031
+ match (length x)
1032
+ case 4 (abnf-some (filter (fn [p] (abnf-starts p x)) prefixes))
1033
+ case _ false
1034
+
1035
+ ; A token set is the class its name gives when the tokens it lays over
1036
+ ; that class are the class: their ranges, merged, are the class's ranges,
1037
+ ; or, for a negated class, every code point the class does not exclude.
1038
+ ; The compiler lays a contested class over the atoms of a partition, each
1039
+ ; a token of its own, and names the set for the class; the render writes
1040
+ ; the class the name gives, so a set whose tokens match anything else is
1041
+ ; refused.
1042
+ def abnf-check-sets [cx used]
1043
+ count (map (fn [k] (abnf-check-set cx (string-join "" ["#" k]))) (filter (fn [k] (match (abnf-starts "RX_" k) (case true (abnf-some (abnf-rest (split (string-join "" [" #" k " "]) used)))) (case false false))) (keys (get :sets cx))))
1044
+
1045
+ def abnf-check-set [cx t]
1046
+ let [cls (abnf-set-token t)]
1047
+ let [pat (get :pat cls)]
1048
+ let [spans (abnf-flat (map (fn [m] (abnf-member-spans cx t m)) (abnf-vec (get-path (as-path [(abnf-bare t)]) (get :sets cx)))))]
1049
+ let [own (abnf-class-spans pat)]
1050
+ match (match (abnf-starts "[^" pat) (case true (abnf-spans-tile own spans)) (case false (abnf-spans-same (abnf-spans-merged own) (abnf-spans-merged spans))))
1051
+ case true true
1052
+ case false (abnf-fail (string-join "" ["the token set " t " lays tokens over its class " pat " that match other characters than the class does, and the render writes the class the set's name gives"]))
1053
+
1054
+ def abnf-member-spans [cx t m]
1055
+ let [src (match (kind m) (case :string (abnf-str (get-path (as-path [m]) (get :match cx)))) (case _ ""))]
1056
+ let [body (abnf-after "^" (string-join "/" (pop (abnf-rest (split "/" src)))))]
1057
+ match (match (abnf-starts "@" src) (case true (match (abnf-class-pattern body) (case true (match (abnf-starts "[^" body) (case true false) (case false (abnf-flags-fit body (top (split "/" src)))))) (case false false))) (case false false))
1058
+ case true (abnf-class-spans body)
1059
+ case false (abnf-fail (string-join "" ["the token set " t " holds " (abnf-str m) ", which is not one class the render reads"]))
1060
+
1061
+ def abnf-engine-token [t]
1062
+ match t
1063
+ case "#TX" (record (entry :k :engine) (entry :name "TX"))
1064
+ case "#NR" (record (entry :k :engine) (entry :name "NR"))
1065
+ case "#ST" (record (entry :k :engine) (entry :name "ST"))
1066
+ case "#VL" (record (entry :k :engine) (entry :name "VL"))
1067
+ case _ (abnf-fail (string-join "" ["the token " t " is defined nowhere in the spec"]))
1068
+
1069
+ def abnf-token [cx t]
1070
+ let [f (get-path (as-path [t]) (get :fixed cx))]
1071
+ match (kind f)
1072
+ case :string (abnf-lit f true)
1073
+ case _
1074
+ let [m (get-path (as-path [t]) (get :match cx))]
1075
+ match (kind m)
1076
+ case :string (abnf-match-token t m)
1077
+ case _
1078
+ match (kind (get-path (as-path [(abnf-bare t)]) (get :sets cx)))
1079
+ case :vector (abnf-set-token t)
1080
+ case _ (abnf-engine-token t)
1081
+
1082
+ ; ---- reading a rule's alternatives
1083
+
1084
+ ; An element of an alternative as the spec holds it: a token, or a
1085
+ ; reference to a rule (the compiler's helpers among them).
1086
+ def abnf-tok-el [t]
1087
+ record
1088
+ entry :k :tok
1089
+ entry :name t
1090
+
1091
+ def abnf-ref-el [n]
1092
+ record
1093
+ entry :k :ref
1094
+ entry :name n
1095
+
1096
+ ; The tokens an alternate consumes, and the rule it hands over to.
1097
+ def abnf-consumed [alt]
1098
+ let [s (abnf-s alt)]
1099
+ let [b (abnf-b alt)]
1100
+ abnf-take (count (filter (fn [j] (abnf-not (abnf-less j b))) (indices s))) s
1101
+
1102
+ def abnf-target [alt]
1103
+ match (abnf-p alt)
1104
+ case "" (abnf-r alt)
1105
+ case p p
1106
+
1107
+ def abnf-entry-els [alt]
1108
+ let [toks (map abnf-tok-el (abnf-consumed alt))]
1109
+ match (abnf-target alt)
1110
+ case "" toks
1111
+ case to (push (abnf-ref-el to) toks)
1112
+
1113
+ def abnf-entry-key [alt]
1114
+ string-join "" [(string-join " " (abnf-consumed alt)) "|" (abnf-target alt)]
1115
+
1116
+ ; A rule whose alternatives are each one segment: its open alternates,
1117
+ ; each read as what it consumes and pushes, a dispatch's lookahead copies
1118
+ ; of one alternative read as one; the empty alternative first, which the
1119
+ ; compiler puts last wherever it stood, so that either place compiles
1120
+ ; back the same. An alternate that consumes nothing and pushes nothing is
1121
+ ; the empty alternative, or a guard that ends it on what may follow; two
1122
+ ; or more bare ones (\`a ::= | \`) are as many empty alternatives.
1123
+ def abnf-simple-alts [r]
1124
+ let [alts (abnf-flat (map (fn [alt] (map (fn [i] (abnf-entry-els alt)) (indices (abnf-ones (abnf-copies (abnf-open r) alt))))) (abnf-unique abnf-entry-key (abnf-open r))))]
1125
+ let [bare (count (filter abnf-bare-empty (abnf-open r)))]
1126
+ let [empties (match (abnf-some (filter abnf-none alts)) (case false []) (case true (map (fn [i] []) (indices (abnf-ones (match (abnf-less bare 2) (case true 1) (case false bare)))))))]
1127
+ abnf-cat empties (abnf-number-order (filter abnf-some alts))
1128
+
1129
+ ; How many times an alternative stands among the open alternates: the
1130
+ ; lookahead copies a dispatch makes of one alternative consume and push the
1131
+ ; same and look ahead at different tokens, and are one; alternates alike
1132
+ ; in everything are as many alternatives as there are of them.
1133
+ def abnf-copies [open alt]
1134
+ let [group (filter (fn [a] (abnf-same (abnf-entry-key a) (abnf-entry-key alt))) open)]
1135
+ let [counts (map (fn [a] (count (filter (fn [b] (abnf-same (abnf-whole-key b) (abnf-whole-key a))) group))) group)]
1136
+ abnf-at (filter (fn [c] (abnf-none (filter (fn [d] (abnf-less c d)) counts))) counts) 0
1137
+
1138
+ def abnf-whole-key [alt]
1139
+ string-join "" [(string-join " " (abnf-s alt)) "|" (abnf-num (abnf-b alt)) "|" (abnf-target alt)]
1140
+
1141
+ def abnf-bare-empty [alt]
1142
+ match (abnf-some (abnf-s alt))
1143
+ case true false
1144
+ case false (abnf-empty (abnf-target alt))
1145
+
1146
+ ; The compiler reorders a rule's alternatives to tell them apart (a
1147
+ ; longer lookahead first, a keyword ahead of a class that takes it), and
1148
+ ; numbers the helpers it makes for them, in the order the alternatives
1149
+ ; were written, before it does. So the alternatives that push a helper
1150
+ ; are put back in the order of the helpers' numbers, among their own
1151
+ ; places; the others keep theirs.
1152
+ def abnf-alt-number [alt]
1153
+ match (count alt)
1154
+ case 0 -1
1155
+ case _
1156
+ let [last (top alt)]
1157
+ match (get :k last)
1158
+ case :ref
1159
+ match (abnf-starts "_gen" (get :name last))
1160
+ case true
1161
+ let [d (abnf-at (split "_" (abnf-after "_gen" (get :name last))) 0)]
1162
+ match (abnf-digits d)
1163
+ case true (number d)
1164
+ case false -1
1165
+ case false -1
1166
+ case _ -1
1167
+
1168
+ def abnf-number-order [alts]
1169
+ let [nums (map abnf-alt-number alts)]
1170
+ let [slots (filter (fn [i] (abnf-not (abnf-less (abnf-at nums i) 0))) (indices alts))]
1171
+ let [rank (fn [i] (count (filter (fn [j] (match (compare (abnf-at nums j) (abnf-at nums i)) (case :less true) (case :equal (abnf-less j i)) (case _ false))) slots)))]
1172
+ let [ranks (map rank slots)]
1173
+ map (fn [i] (abnf-number-at alts nums slots ranks i)) (indices alts)
1174
+
1175
+ def abnf-number-at [alts nums slots ranks i]
1176
+ match (abnf-less (abnf-at nums i) 0)
1177
+ case true (abnf-at alts i)
1178
+ case false
1179
+ let [k (count (filter (fn [j] (abnf-less j i)) slots))]
1180
+ abnf-at alts (abnf-at slots (abnf-at (filter (fn [m] (match (compare (abnf-at ranks m) k) (case :equal true) (case _ false))) (indices slots)) 0))
1181
+
1182
+ ; The first alternative that is not empty: an option's.
1183
+ def abnf-filled [alts]
1184
+ abnf-at (filter abnf-some alts) 0
1185
+
1186
+ ; The steps of a chain, each a segment: the tokens its open alternate
1187
+ ; consumes and the rule it pushes, the next step named in its close.
1188
+ def abnf-chain-walk [self cx name depth acc]
1189
+ let [r (abnf-chain-step name (abnf-rule cx name))]
1190
+ let [els (abnf-cat acc (abnf-entry-els (abnf-at (abnf-open r) 0)))]
1191
+ match (count (abnf-close r))
1192
+ case 0 els
1193
+ case _
1194
+ match (abnf-r (abnf-at (abnf-close r) 0))
1195
+ case "" els
1196
+ case next
1197
+ match (abnf-less (count depth) 200)
1198
+ case false (abnf-fail (string-join "" ["rule " name " is a sequence of more than 200 segments, which the render does not follow"]))
1199
+ case true (self self cx next (push 1 depth) els)
1200
+
1201
+ def abnf-chain [cx name]
1202
+ abnf-chain-walk abnf-chain-walk cx name [] []
1203
+
1204
+ ; A dispatcher's alternatives: one rule per alternative, \`<rule>$alt<i>\`,
1205
+ ; and the empty one where a number is missing, or last.
1206
+ def abnf-head-name [name i]
1207
+ string-join "" [name "$alt" (abnf-num i)]
1208
+
1209
+ def abnf-dispatch-alts [cx name r]
1210
+ let [nums (indices (push 0 (abnf-open r)))]
1211
+ let [present (filter (fn [i] (abnf-has cx (abnf-head-name name i))) nums)]
1212
+ let [last (top present)]
1213
+ let [gaps (filter (fn [i] (match (abnf-less i last) (case true (abnf-not (abnf-among (abnf-num i) (map abnf-num present)))) (case false false))) nums)]
1214
+ let [empty (abnf-some (filter (fn [alt] (abnf-empty (abnf-target alt))) (abnf-open r)))]
1215
+ match (count gaps)
1216
+ case 0
1217
+ abnf-cat (map (fn [i] (abnf-chain cx (abnf-head-name name i))) present) (match empty (case true [[]]) (case false []))
1218
+ case 1
1219
+ map
1220
+ fn [i]
1221
+ match (abnf-has cx (abnf-head-name name i))
1222
+ case true (abnf-chain cx (abnf-head-name name i))
1223
+ case false []
1224
+ filter (fn [i] (abnf-not (abnf-less last i))) nums
1225
+ case _ (abnf-fail (string-join "" ["rule " name " dispatches to alternatives the render cannot place"]))
1226
+
1227
+ ; Whether the rule dispatches to \`$alt\` rules of its own.
1228
+ def abnf-dispatches [cx name r]
1229
+ abnf-some (filter (fn [alt] (abnf-starts (string-join "" [name "$alt"]) (abnf-target alt))) (abnf-open r))
1230
+
1231
+ ; A loop's item: what its continue alternate takes, a token it consumes,
1232
+ ; or the rule its iteration (\`<loop>$alt0\`) pushes.
1233
+ def abnf-loop-item [cx name r]
1234
+ let [conts (filter (fn [alt] (abnf-full (abnf-r alt))) (abnf-rest (abnf-open r)))]
1235
+ match (count conts)
1236
+ case 0 (abnf-fail (string-join "" ["the repetition " name " repeats nothing"]))
1237
+ case _
1238
+ let [c (abnf-at conts 0)]
1239
+ match (abnf-same (abnf-r c) name)
1240
+ case true
1241
+ match (abnf-consumed c)
1242
+ case [t] (abnf-tok-el t)
1243
+ case _ (abnf-fail (string-join "" ["the repetition " name " repeats more than one token"]))
1244
+ case false
1245
+ match (abnf-p (abnf-at (abnf-open (abnf-rule cx (abnf-r c))) 0))
1246
+ case "" (abnf-fail (string-join "" ["the repetition " name " repeats nothing"]))
1247
+ case item (abnf-ref-el item)
1248
+
1249
+ ; A tail repeat, \`X = prefix [ sep X ]\`, which the compiler makes a loop
1250
+ ; in the rule's close: the separator matched and the rule replaced.
1251
+ def abnf-is-tail [name r]
1252
+ match (count (abnf-close r))
1253
+ case 2
1254
+ let [c (abnf-at (abnf-close r) 0)]
1255
+ match (abnf-a c)
1256
+ case "@fold$" (abnf-same (abnf-r c) name)
1257
+ case _ false
1258
+ case _ false
1259
+
1260
+ ; The alternatives of a rule as the spec holds them, each a vector of
1261
+ ; elements; a tail repeat as its prefix and the option around its
1262
+ ; separator and itself.
1263
+ def abnf-raw-alts [cx name]
1264
+ let [r (abnf-rule cx name)]
1265
+ match (abnf-is-tail name r)
1266
+ case true
1267
+ let [prefix (map abnf-tok-el (abnf-consumed (abnf-at (abnf-open r) 0)))]
1268
+ let [sep (map abnf-tok-el (abnf-consumed (abnf-at (abnf-close r) 0)))]
1269
+ vector
1270
+ push
1271
+ record
1272
+ entry :k :tail
1273
+ entry :seq (push (abnf-ref-el name) sep)
1274
+ prefix
1275
+ case false
1276
+ match (abnf-dispatches cx name r)
1277
+ case true (abnf-dispatch-alts cx name r)
1278
+ case false
1279
+ match (count (abnf-close r))
1280
+ case 0 (abnf-simple-alts r)
1281
+ case _
1282
+ match (abnf-r (abnf-at (abnf-close r) 0))
1283
+ case "" (abnf-simple-alts r)
1284
+ case _ (vector (abnf-chain cx name))
1285
+
1286
+ ; A step of a sequence's chain, as the compiler makes one: one open
1287
+ ; alternate, a segment of the sequence, and at most one close alternate,
1288
+ ; which names the next step. A rule that replaces itself in its close and
1289
+ ; has more alternates than that is no chain the render reads back.
1290
+ def abnf-chain-step [name r]
1291
+ match (match (count (abnf-open r)) (case 1 (abnf-less (count (abnf-close r)) 2)) (case _ false))
1292
+ case true r
1293
+ case false (abnf-fail (string-join "" ["rule " name " replaces itself in its close as a sequence's step does, and has more alternates than a step, which is not read back"]))
1294
+
1295
+ ; ---- the compiler's helpers, read back
1296
+
1297
+ ; The kind of a helper the compiler named: \`_gen<n>_<kind>...\`.
1298
+ def abnf-helper-kind [cx name]
1299
+ match (abnf-made cx name)
1300
+ case false ""
1301
+ case true
1302
+ match (abnf-starts "_gen" name)
1303
+ case true
1304
+ let [parts (split "_" (abnf-after "_gen" name))]
1305
+ match (abnf-digits (abnf-at parts 0))
1306
+ case true (abnf-at parts 1)
1307
+ case false ""
1308
+ case false
1309
+ match (abnf-among "fact" (map (fn [p] (abnf-before-digits p)) (abnf-rest (split "$" name))))
1310
+ case true "fact"
1311
+ case false ""
1312
+
1313
+ def abnf-before-digits [p]
1314
+ match (abnf-starts "fact" p)
1315
+ case true (match (abnf-digits (abnf-after "fact" p)) (case true "fact") (case false p))
1316
+ case false p
1317
+
1318
+ ; An alternative with its factored tails expanded back: one whose last
1319
+ ; element is a left-factored tail (\`<rule>$fact<k>\`) is the prefix before
1320
+ ; it followed by each of the tail's alternatives in turn.
1321
+ def abnf-expand [self cx alt]
1322
+ match (count alt)
1323
+ case 0 [alt]
1324
+ case _
1325
+ let [last (top alt)]
1326
+ match (get :k last)
1327
+ case :ref
1328
+ match (abnf-helper-kind cx (get :name last))
1329
+ case "fact"
1330
+ let [prefix (pop alt)]
1331
+ abnf-flat (map (fn [tail] (self self cx (abnf-cat prefix tail))) (abnf-raw-alts cx (get :name last)))
1332
+ case _ [alt]
1333
+ case _ [alt]
1334
+
1335
+ def abnf-alts [cx name]
1336
+ abnf-flat (map (fn [alt] (abnf-split-group cx name alt)) (abnf-flat (map (fn [alt] (abnf-expand abnf-expand cx alt)) (abnf-raw-alts cx name))))
1337
+
1338
+ ; The compiler factors a rule's alternatives that are each one group
1339
+ ; (\`( A x ) | ( A y )\`) into the first group, whose sequence then ends in
1340
+ ; the rule's own factored tail (\`<rule>$fact<k>\`); such an alternative is
1341
+ ; read back as the groups it was, one alternative each.
1342
+ def abnf-split-group [cx name alt]
1343
+ match (count alt)
1344
+ case 1
1345
+ let [el (abnf-at alt 0)]
1346
+ match (get :k el)
1347
+ case :ref
1348
+ match (abnf-helper-kind cx (get :name el))
1349
+ case "group"
1350
+ let [inner (abnf-raw-alts cx (get :name el))]
1351
+ match (count inner)
1352
+ case 1
1353
+ let [seq (abnf-at inner 0)]
1354
+ match (abnf-owned-fact cx name seq)
1355
+ case true (map (fn [one] [(abnf-grp-el one)]) (abnf-expand abnf-expand cx seq))
1356
+ case false [alt]
1357
+ case _ [alt]
1358
+ case _ [alt]
1359
+ case _ [alt]
1360
+ case _ [alt]
1361
+
1362
+ def abnf-owned-fact [cx name seq]
1363
+ match (count seq)
1364
+ case 0 false
1365
+ case _
1366
+ let [last (top seq)]
1367
+ match (get :k last)
1368
+ case :ref
1369
+ match (abnf-helper-kind cx (get :name last))
1370
+ case "fact" (abnf-starts (string-join "" [name "$fact"]) (get :name last))
1371
+ case _ false
1372
+ case _ false
1373
+
1374
+ ; A group read back from a factored alternative: an element of its own,
1375
+ ; written as a group is.
1376
+ def abnf-grp-el [seq]
1377
+ record
1378
+ entry :k :grp
1379
+ entry :seq seq
1380
+
1381
+ ; The parts a repetition counts: the item, how many at least, how many
1382
+ ; at most ("" for no bound). A bounded one ends in nested options, each
1383
+ ; over a group of the item and the next option, the innermost over the
1384
+ ; item alone: \`[ A [ A [ A ] ] ]\`. The compiler numbers them as it makes
1385
+ ; them, the innermost group first, under the number it gave the
1386
+ ; repetition: group n, option n+1 over it, group n+2, ..., so the
1387
+ ; outermost option's number says how deep they go.
1388
+ def abnf-gen-number [name]
1389
+ number (abnf-at (split "_" (abnf-after "_gen" name)) 0)
1390
+
1391
+ def abnf-rep-chain [cx rep opt]
1392
+ let [n (abnf-gen-number rep)]
1393
+ let [inner-name (string-join "" ["_gen" (abnf-num n) "_group"])]
1394
+ match (abnf-has cx inner-name)
1395
+ case false (abnf-fail (string-join "" ["the repetition " rep " is not numbered as the compiler numbers one"]))
1396
+ case true
1397
+ let [inner (abnf-raw-alts cx inner-name)]
1398
+ match (count (abnf-at inner 0))
1399
+ case 1
1400
+ let [span (count (filter (fn [j] (abnf-not (abnf-less j n))) (indices (abnf-ones (abnf-plus (abnf-gen-number opt) 1)))))]
1401
+ record
1402
+ entry :item (abnf-at (abnf-at inner 0) 0)
1403
+ entry :depth (count (filter abnf-even (indices (abnf-ones span))))
1404
+ case _ (abnf-fail (string-join "" ["the repetition " rep " is not numbered as the compiler numbers one"]))
1405
+
1406
+ def abnf-rep-parts [cx name]
1407
+ let [seq (abnf-at (abnf-raw-alts cx name) 0)]
1408
+ let [last (match (count seq) (case 0 (abnf-fail (string-join "" ["the repetition " name " repeats its item no times, and the spec does not keep the item"]))) (case _ (top seq)))]
1409
+ let [lead (pop seq)]
1410
+ match (abnf-helper-kind cx (abnf-str (get :name last)))
1411
+ case "star"
1412
+ record
1413
+ entry :item (abnf-loop-item cx (get :name last) (abnf-rule cx (get :name last)))
1414
+ entry :min (count lead)
1415
+ entry :max ""
1416
+ case "opt"
1417
+ let [chain (abnf-rep-chain cx name (get :name last))]
1418
+ record
1419
+ entry :item (get :item chain)
1420
+ entry :min (count lead)
1421
+ entry :max (abnf-num (abnf-plus (count lead) (get :depth chain)))
1422
+ case _
1423
+ record
1424
+ entry :item (abnf-at seq 0)
1425
+ entry :min (count seq)
1426
+ entry :max (abnf-num (count seq))
1427
+
1428
+ ; Whether an option is over a group.
1429
+ def abnf-opt-group [cx name]
1430
+ let [alts (abnf-raw-alts cx name)]
1431
+ let [inner (abnf-at (abnf-filled alts) 0)]
1432
+ match (get :k inner)
1433
+ case :ref (abnf-same (abnf-helper-kind cx (get :name inner)) "group")
1434
+ case _ false
1435
+
1436
+ ; An element's structure as one string, a helper by what it compiles (a
1437
+ ; counted repetition by its item and counts, not by the nested options
1438
+ ; it compiles to, which are as deep as its count).
1439
+ def abnf-key [self cx el]
1440
+ match (get :k el)
1441
+ case :tok (get :name el)
1442
+ case :tail "[tail]"
1443
+ case :grp (string-join "" ["group(" (abnf-key-seq self cx (get :seq el)) ")"])
1444
+ case :ref
1445
+ let [name (get :name el)]
1446
+ match (abnf-helper-kind cx name)
1447
+ case "" (string-join "" ["@" name])
1448
+ case "star" (string-join "" ["*(" (self self cx (abnf-loop-item cx name (abnf-rule cx name))) ")"])
1449
+ case "rep"
1450
+ let [parts (abnf-rep-parts cx name)]
1451
+ string-join "" ["rep(" (abnf-num (get :min parts)) "," (get :max parts) "," (self self cx (get :item parts)) ")"]
1452
+ case kind (string-join "" [kind "(" (string-join "|" (map (fn [seq] (abnf-key-seq self cx seq)) (abnf-alts cx name))) ")"])
1453
+
1454
+ def abnf-key-seq [self cx seq]
1455
+ string-join " " (map (fn [e] (self self cx e)) seq)
1456
+
1457
+ def abnf-seq-keys [cx seq]
1458
+ map (fn [el] (abnf-key abnf-key cx el)) seq
1459
+
1460
+ ; ---- characters
1461
+
1462
+ ; A literal's characters as their code points, which a notation writes
1463
+ ; where a quoted string cannot hold a character, and the names the
1464
+ ; compiler derives from a literal's text.
1465
+
1466
+ ; The ASCII characters, each with its two hexadecimal digits.
1467
+ def abnf-ascii [["\\u0000" "00"] ["\\u0001" "01"] ["\\u0002" "02"] ["\\u0003" "03"] ["\\u0004" "04"] ["\\u0005" "05"] ["\\u0006" "06"] ["\\u0007" "07"] ["\\b" "08"] ["\\t" "09"] ["\\n" "0A"] ["\\u000b" "0B"] ["\\f" "0C"] ["\\r" "0D"] ["\\u000e" "0E"] ["\\u000f" "0F"] ["\\u0010" "10"] ["\\u0011" "11"] ["\\u0012" "12"] ["\\u0013" "13"] ["\\u0014" "14"] ["\\u0015" "15"] ["\\u0016" "16"] ["\\u0017" "17"] ["\\u0018" "18"] ["\\u0019" "19"] ["\\u001a" "1A"] ["\\u001b" "1B"] ["\\u001c" "1C"] ["\\u001d" "1D"] ["\\u001e" "1E"] ["\\u001f" "1F"] [" " "20"] ["!" "21"] ["\\"" "22"] ["#" "23"] ["$" "24"] ["%" "25"] ["&" "26"] ["'" "27"] ["(" "28"] [")" "29"] ["*" "2A"] ["+" "2B"] ["," "2C"] ["-" "2D"] ["." "2E"] ["/" "2F"] ["0" "30"] ["1" "31"] ["2" "32"] ["3" "33"] ["4" "34"] ["5" "35"] ["6" "36"] ["7" "37"] ["8" "38"] ["9" "39"] [":" "3A"] [";" "3B"] ["<" "3C"] ["=" "3D"] [">" "3E"] ["?" "3F"] ["@" "40"] ["A" "41"] ["B" "42"] ["C" "43"] ["D" "44"] ["E" "45"] ["F" "46"] ["G" "47"] ["H" "48"] ["I" "49"] ["J" "4A"] ["K" "4B"] ["L" "4C"] ["M" "4D"] ["N" "4E"] ["O" "4F"] ["P" "50"] ["Q" "51"] ["R" "52"] ["S" "53"] ["T" "54"] ["U" "55"] ["V" "56"] ["W" "57"] ["X" "58"] ["Y" "59"] ["Z" "5A"] ["[" "5B"] ["\\\\" "5C"] ["]" "5D"] ["^" "5E"] ["_" "5F"] ["\`" "60"] ["a" "61"] ["b" "62"] ["c" "63"] ["d" "64"] ["e" "65"] ["f" "66"] ["g" "67"] ["h" "68"] ["i" "69"] ["j" "6A"] ["k" "6B"] ["l" "6C"] ["m" "6D"] ["n" "6E"] ["o" "6F"] ["p" "70"] ["q" "71"] ["r" "72"] ["s" "73"] ["t" "74"] ["u" "75"] ["v" "76"] ["w" "77"] ["x" "78"] ["y" "79"] ["z" "7A"] ["{" "7B"] ["|" "7C"] ["}" "7D"] ["~" "7E"] ["\\u007f" "7F"]]
1468
+
1469
+ ; A piece of a literal's text: a run of its characters (\`:raw\`), or one
1470
+ ; character as its code point (\`:cp\`). A run is cut at each place it
1471
+ ; holds a character, which is put back as its code point between the
1472
+ ; pieces, and the empty runs are left out.
1473
+ def abnf-raw-seg [s]
1474
+ record
1475
+ entry :raw s
1476
+
1477
+ def abnf-cp-seg [h]
1478
+ record
1479
+ entry :cp h
1480
+
1481
+ def abnf-cut-seg [c h seg]
1482
+ match (kind (get :raw seg))
1483
+ case :string
1484
+ let [pieces (split c (get :raw seg))]
1485
+ abnf-flat (map (fn [i] (match i (case 0 [(abnf-raw-seg (abnf-at pieces 0))]) (case _ [(abnf-cp-seg h) (abnf-raw-seg (abnf-at pieces i))]))) (indices pieces))
1486
+ case _ [seg]
1487
+
1488
+ ; A string's pieces with each of the characters given cut out as its code
1489
+ ; point, in turn.
1490
+ def abnf-code-walk [self chars segs]
1491
+ match (count chars)
1492
+ case 0 segs
1493
+ case _
1494
+ let [ch (top chars)]
1495
+ self self (pop chars) (filter abnf-kept-seg (abnf-flat (map (fn [seg] (abnf-cut-seg (abnf-at ch 0) (abnf-at ch 1) seg)) segs)))
1496
+
1497
+ def abnf-kept-seg [seg]
1498
+ match (get :raw seg)
1499
+ case "" false
1500
+ case _ true
1501
+
1502
+ ; A literal's characters as their code points, in order: its ASCII
1503
+ ; characters cut out first, then each run of other characters taken
1504
+ ; apart.
1505
+ def abnf-codes [text]
1506
+ let [present (filter (fn [ch] (abnf-some (abnf-rest (split (abnf-at ch 0) text)))) abnf-ascii)]
1507
+ let [segs (abnf-code-walk abnf-code-walk present [(abnf-raw-seg text)])]
1508
+ abnf-flat (map (fn [seg] (abnf-wide-codes text seg)) segs)
1509
+
1510
+ ; The sixteen hexadecimal digits, and the 256 pairs of them.
1511
+ def abnf-hex-digits ["0" "1" "2" "3" "4" "5" "6" "7" "8" "9" "A" "B" "C" "D" "E" "F"]
1512
+
1513
+ def abnf-hex-pairs
1514
+ abnf-flat (map (fn [a] (map (fn [b] (string-join "" [a b])) abnf-hex-digits)) abnf-hex-digits)
1515
+
1516
+ ; The start of each block of 256 code points in the Basic Multilingual
1517
+ ; Plane, by which a character past ASCII is found.
1518
+ def abnf-blocks [0 256 512 768 1024 1280 1536 1792 2048 2304 2560 2816 3072 3328 3584 3840 4096 4352 4608 4864 5120 5376 5632 5888 6144 6400 6656 6912 7168 7424 7680 7936 8192 8448 8704 8960 9216 9472 9728 9984 10240 10496 10752 11008 11264 11520 11776 12032 12288 12544 12800 13056 13312 13568 13824 14080 14336 14592 14848 15104 15360 15616 15872 16128 16384 16640 16896 17152 17408 17664 17920 18176 18432 18688 18944 19200 19456 19712 19968 20224 20480 20736 20992 21248 21504 21760 22016 22272 22528 22784 23040 23296 23552 23808 24064 24320 24576 24832 25088 25344 25600 25856 26112 26368 26624 26880 27136 27392 27648 27904 28160 28416 28672 28928 29184 29440 29696 29952 30208 30464 30720 30976 31232 31488 31744 32000 32256 32512 32768 33024 33280 33536 33792 34048 34304 34560 34816 35072 35328 35584 35840 36096 36352 36608 36864 37120 37376 37632 37888 38144 38400 38656 38912 39168 39424 39680 39936 40192 40448 40704 40960 41216 41472 41728 41984 42240 42496 42752 43008 43264 43520 43776 44032 44288 44544 44800 45056 45312 45568 45824 46080 46336 46592 46848 47104 47360 47616 47872 48128 48384 48640 48896 49152 49408 49664 49920 50176 50432 50688 50944 51200 51456 51712 51968 52224 52480 52736 52992 53248 53504 53760 54016 54272 54528 54784 55040 55296 55552 55808 56064 56320 56576 56832 57088 57344 57600 57856 58112 58368 58624 58880 59136 59392 59648 59904 60160 60416 60672 60928 61184 61440 61696 61952 62208 62464 62720 62976 63232 63488 63744 64000 64256 64512 64768 65024 65280]
1519
+
1520
+ ; A piece of a literal that holds no ASCII character: characters of the
1521
+ ; Basic Multilingual Plane, each as its code point, in order. The run is
1522
+ ; cut at each character it holds, found a block of 256 at a time: the
1523
+ ; block of its least character is the last whose start that character is
1524
+ ; not below, the characters of that block the run holds are the escapes
1525
+ ; there it holds, and the rest of the run is taken the same way.
1526
+ def abnf-wide-codes [text seg]
1527
+ match (kind (get :raw seg))
1528
+ case :string
1529
+ let [raw (get :raw seg)]
1530
+ match (chars-within [[128 55295] [57344 65535]] raw)
1531
+ case false (abnf-fail (string-join "" ["the literal " (quoted text) " holds a character past U+FFFF, which the render does not spell as a numeric value"]))
1532
+ case true
1533
+ let [found (abnf-wide-chars abnf-wide-chars text raw [])]
1534
+ map (fn [piece] (get :cp piece)) (abnf-code-walk abnf-code-walk found [(abnf-raw-seg raw)])
1535
+ case _ [(get :cp seg)]
1536
+
1537
+ def abnf-wide-chars [self text run acc]
1538
+ match run
1539
+ case "" acc
1540
+ case _
1541
+ let [b (top (filter (fn [i] (chars-within [[(abnf-at abnf-blocks i) 65535]] run)) (indices abnf-blocks)))]
1542
+ let [hh (abnf-at abnf-hex-pairs b)]
1543
+ let [found (filter (fn [ch] (abnf-some (abnf-rest (split (abnf-at ch 0) run)))) (map (fn [l] [(unquoted (string-join "" ["\\"\\\\u" (abnf-hex-lower hh) (abnf-hex-lower l) "\\""])) (abnf-point-hex hh l)]) abnf-hex-pairs))]
1544
+ match (count found)
1545
+ case 0 (abnf-fail (string-join "" ["the literal " (quoted text) " holds a character the render cannot spell"]))
1546
+ case _ (self self text (abnf-strip-chars abnf-strip-chars found run) (abnf-cat acc found))
1547
+
1548
+ ; A code point's digits as ABNF writes them, without leading zeros.
1549
+ def abnf-point-hex [hh l]
1550
+ match hh
1551
+ case "00" l
1552
+ case _
1553
+ match (abnf-starts "0" hh)
1554
+ case true (string-join "" [(abnf-after "0" hh) l])
1555
+ case false (string-join "" [hh l])
1556
+
1557
+ def abnf-strip-chars [self chars s]
1558
+ match (count chars)
1559
+ case 0 s
1560
+ case _ (self self (pop chars) (string-join "" (split (abnf-at (top chars) 0) s)))
1561
+
1562
+ def abnf-has-letter [text]
1563
+ abnf-not (chars-within [[0 64] [91 96] [123 1114111]] text)
1564
+
1565
+ ; ---- token names
1566
+
1567
+ ; The name the compiler derives for a literal's token: the text in
1568
+ ; capitals, each character that is not a letter or a digit an underscore,
1569
+ ; the underscores at either end taken off, \`T\` when nothing is left, and a
1570
+ ; number after it when the name is taken. A token with any other name is a
1571
+ ; rule the compiler lifted to a token.
1572
+ def abnf-upper-pairs [["a" "A"] ["b" "B"] ["c" "C"] ["d" "D"] ["e" "E"] ["f" "F"] ["g" "G"] ["h" "H"] ["i" "I"] ["j" "J"] ["k" "K"] ["l" "L"] ["m" "M"] ["n" "N"] ["o" "O"] ["p" "P"] ["q" "Q"] ["r" "R"] ["s" "S"] ["t" "T"] ["u" "U"] ["v" "V"] ["w" "W"] ["x" "X"] ["y" "Y"] ["z" "Z"]]
1573
+
1574
+ def abnf-swap-walk [self pairs s]
1575
+ match (count pairs)
1576
+ case 0 s
1577
+ case _
1578
+ let [pair (top pairs)]
1579
+ self self (pop pairs) (string-join (abnf-at pair 1) (split (abnf-at pair 0) s))
1580
+
1581
+ def abnf-word-chars [[48 57] [65 90] [97 122]]
1582
+
1583
+ def abnf-base-name [text]
1584
+ let [up (abnf-swap-walk abnf-swap-walk abnf-upper-pairs text)]
1585
+ let [others (filter (fn [ch] (abnf-not (chars-within abnf-word-chars (abnf-at ch 0)))) abnf-ascii)]
1586
+ let [under (abnf-swap-walk abnf-swap-walk (map (fn [ch] [(abnf-at ch 0) "_"]) others) up)]
1587
+ let [pieces (split "_" under)]
1588
+ let [full (filter (fn [i] (abnf-full (abnf-at pieces i))) (indices pieces))]
1589
+ match (count full)
1590
+ case 0 "T"
1591
+ case _
1592
+ let [lo (abnf-at full 0)]
1593
+ let [hi (top full)]
1594
+ string-join "_" (map (fn [i] (abnf-at pieces i)) (filter (fn [i] (match (abnf-less i lo) (case true false) (case false (abnf-not (abnf-less hi i))))) (indices pieces)))
1595
+
1596
+ def abnf-derived [bare text]
1597
+ match (chars-within [[48 57] [65 90] [95 95]] bare)
1598
+ case false false
1599
+ case true
1600
+ match (chars-within [[0 127]] text)
1601
+ case false true
1602
+ case true
1603
+ let [base (abnf-base-name text)]
1604
+ match (abnf-same bare base)
1605
+ case true true
1606
+ case false
1607
+ match (abnf-starts base bare)
1608
+ case true (abnf-digits (abnf-after base bare))
1609
+ case false false
1610
+
1611
+ ; Every token name the alternates match, one string.
1612
+ def abnf-used [cx]
1613
+ let [rules (get :rules cx)]
1614
+ string-join ""
1615
+ vector
1616
+ " "
1617
+ string-join " "
1618
+ map
1619
+ fn [name]
1620
+ let [r (get-path (as-path [name]) rules)]
1621
+ string-join " " (abnf-flat (map abnf-s (abnf-cat (abnf-open r) (abnf-close r))))
1622
+ keys rules
1623
+ " "
1624
+
1625
+ ; ---- references written back
1626
+
1627
+ ; The compiler substitutes a reference that leads an alternative by the
1628
+ ; referenced rule's alternatives, each followed by what followed the
1629
+ ; reference (\`a = b "x"\`, \`b = "y" / "z"\` compiles \`a\` as \`"y" "x" / "z"
1630
+ ; "x"\`), and compiles the reference back to the same alternatives. So
1631
+ ; where a run of a rule's alternatives is another rule's alternatives,
1632
+ ; each followed by one same tail, the reference is written back in their
1633
+ ; place. A candidate is a rule the written file can name, with its
1634
+ ; alternatives' keys; a rule that is one reference (\`a = b\`) is none,
1635
+ ; since the compiler leaves such a rule a reference rather than
1636
+ ; substituting it.
1637
+ def abnf-candidates [cx names]
1638
+ filter
1639
+ fn [c] (abnf-not (abnf-alias-keys (get :keys c)))
1640
+ map (fn [n] (record (entry :name n) (entry :keys (map (fn [seq] (abnf-seq-keys cx seq)) (abnf-alts cx n))))) names
1641
+
1642
+ def abnf-alias-keys [ks]
1643
+ match (count ks)
1644
+ case 1
1645
+ match (count (abnf-at ks 0))
1646
+ case 1 (abnf-starts "@" (abnf-at (abnf-at ks 0) 0))
1647
+ case _ false
1648
+ case _ false
1649
+
1650
+ ; Whether alternatives are one alternative of one reference to a rule:
1651
+ ; a rule the compiler leaves as it is.
1652
+ def abnf-alias [cx alts]
1653
+ match (count alts)
1654
+ case 1
1655
+ let [seq (abnf-at alts 0)]
1656
+ match (count seq)
1657
+ case 1
1658
+ match (get :k (abnf-at seq 0))
1659
+ case :ref (abnf-empty (abnf-helper-kind cx (get :name (abnf-at seq 0))))
1660
+ case _ false
1661
+ case _ false
1662
+ case _ false
1663
+
1664
+ ; Whether the alternative's keys begin with the candidate alternative's,
1665
+ ; and what follows them ("\\u0000" where they do not).
1666
+ def abnf-prefix-tail [ks cs]
1667
+ match (abnf-less (count ks) (count cs))
1668
+ case true "\\u0000"
1669
+ case false
1670
+ match (abnf-same (string-join "\\u0001" (abnf-take (count cs) ks)) (string-join "\\u0001" cs))
1671
+ case true (string-join "\\u0001" (abnf-drop (count cs) ks))
1672
+ case false "\\u0000"
1673
+
1674
+ ; Whether the candidate's alternatives, each followed by one same tail,
1675
+ ; are the alternatives from position i on.
1676
+ def abnf-cand-matches [c ka i]
1677
+ let [k (count (get :keys c))]
1678
+ match (abnf-less (count ka) (abnf-plus i k))
1679
+ case true false
1680
+ case false
1681
+ let [first (abnf-prefix-tail (abnf-at ka i) (abnf-at (get :keys c) 0))]
1682
+ match first
1683
+ case "\\u0000" false
1684
+ case _ (abnf-none (filter (fn [j] (abnf-not (abnf-same (abnf-prefix-tail (abnf-at ka (abnf-plus i j)) (abnf-at (get :keys c) j)) first))) (indices (get :keys c))))
1685
+
1686
+ ; The candidate, other than the rule itself, whose alternatives stand at
1687
+ ; position i: where several do, the one with the most alternatives, and
1688
+ ; among those the one the spec defines first. The spec cannot tell \`a = b
1689
+ ; ";"\` with \`b = c "("\` from \`a = c "(" ";"\`, nor a reference from two
1690
+ ; rules that begin alike by chance; a grammar written from the top down
1691
+ ; defines the rule an author named before the ones it is made of.
1692
+ def abnf-cand-at [cands ka i self]
1693
+ let [hits (filter (fn [c] (match (abnf-same (get :name c) self) (case true false) (case false (abnf-cand-matches c ka i)))) cands)]
1694
+ let [most (filter (fn [c] (abnf-none (filter (fn [d] (abnf-less (count (get :keys c)) (count (get :keys d)))) hits))) hits)]
1695
+ match (count most)
1696
+ case 0 null
1697
+ case _ (abnf-at most 0)
1698
+
1699
+ ; A rule's alternatives with the references written back: each run a
1700
+ ; candidate covers, from the first position one stands at that no other
1701
+ ; run covers, written as the reference and the tail; the alternatives
1702
+ ; as they are where no run is found, and where writing one back would
1703
+ ; leave the rule one reference, which the compiler would not substitute.
1704
+ def abnf-unsub [cx cands self alts]
1705
+ match (count cands)
1706
+ case 0 alts
1707
+ case _
1708
+ let [ka (map (fn [seq] (abnf-seq-keys cx seq)) alts)]
1709
+ let [best (map (fn [i] (abnf-cand-at cands ka i self)) (indices alts))]
1710
+ let [covers (fn [j i] (match (kind (abnf-at best j)) (case :record (match (abnf-less j i) (case true (abnf-less i (abnf-plus j (count (get :keys (abnf-at best j)))))) (case false false))) (case _ false)))]
1711
+ let [accepted (map (fn [i] (match (kind (abnf-at best i)) (case :record (abnf-none (filter (fn [j] (covers j i)) (indices alts)))) (case _ false))) (indices alts))]
1712
+ let [out (abnf-flat (map (fn [i] (abnf-unsub-at cx alts best accepted covers i)) (indices alts)))]
1713
+ match (abnf-alias cx out)
1714
+ case true alts
1715
+ case false out
1716
+
1717
+ def abnf-unsub-at [cx alts best accepted covers i]
1718
+ match (abnf-at accepted i)
1719
+ case true
1720
+ let [c (abnf-at best i)]
1721
+ vector (abnf-cat [(abnf-ref-el (get :name c))] (abnf-drop (count (abnf-at (get :keys c) 0)) (abnf-at alts i)))
1722
+ case false
1723
+ match (abnf-some (filter (fn [j] (match (abnf-at accepted j) (case true (covers j i)) (case false false))) (indices alts)))
1724
+ case true []
1725
+ case false [(abnf-at alts i)]
1726
+
1727
+ ; ---- ABNF's terminals
1728
+
1729
+ ; A literal: a quoted string where it can hold the text (\`%s\` before it
1730
+ ; when the match is exact and the text holds a letter), and otherwise a
1731
+ ; numeric value, \`%x\` and each character's code point, which tabnas-abnf
1732
+ ; reads as a case-insensitive string where it holds a letter of ASCII,
1733
+ ; with the folding a case-insensitive pattern has, and as an exact one
1734
+ ; where it holds none. So a case-insensitive literal holding a character
1735
+ ; past ASCII, which may have cases, and no letter of ASCII is refused: its
1736
+ ; numeric value would match the one case it spells.
1737
+ def abnf-lit-text [text cs]
1738
+ match text
1739
+ case "" "\\"\\""
1740
+ case _
1741
+ match (chars-within [[32 33] [35 126]] text)
1742
+ case true
1743
+ match cs
1744
+ case true
1745
+ match (abnf-has-letter text)
1746
+ case true (string-join "" ["%s\\"" text "\\""])
1747
+ case false (string-join "" ["\\"" text "\\""])
1748
+ case false (string-join "" ["\\"" text "\\""])
1749
+ case false
1750
+ match cs
1751
+ case true
1752
+ match (abnf-has-letter text)
1753
+ case true (abnf-fail (string-join "" ["the case-sensitive literal " (quoted text) " holds a character a quoted string cannot hold, and a numeric value matches case-insensitively"]))
1754
+ case false (string-join "" ["%x" (string-join "." (abnf-codes text))])
1755
+ case false
1756
+ match (match (abnf-has-letter text) (case true true) (case false (chars-within [[0 127] [65536 1114111]] text)))
1757
+ case true (string-join "" ["%x" (string-join "." (abnf-codes text))])
1758
+ case false (abnf-fail (string-join "" ["the case-insensitive literal " (quoted text) " holds a character past ASCII that may have cases and no ASCII letter, and a numeric value without a letter matches exactly"]))
1759
+
1760
+ ; A code point of a class's pattern, \`\\uXXXX\` or \`\\u{X...}\`, as ABNF's
1761
+ ; hexadecimal digits.
1762
+ def abnf-escape-hex [e]
1763
+ match (abnf-starts "\\\\u" e)
1764
+ case false ""
1765
+ case true
1766
+ let [h (abnf-after "\\\\u" e)]
1767
+ match (abnf-starts "{" h)
1768
+ case true (abnf-hex-upper (abnf-before "}" (abnf-after "{" h)))
1769
+ case false
1770
+ match (abnf-starts "00" h)
1771
+ case true (abnf-hex-upper (abnf-after "00" h))
1772
+ case false (abnf-hex-upper h)
1773
+
1774
+ ; A class: one range as \`%x<lo>-<hi>\`, the only class ABNF writes; a
1775
+ ; class of several members, which another notation writes, as the
1776
+ ; alternation of its members, each range a range and each character a
1777
+ ; string that matches it exactly, or a range of one where a string cannot
1778
+ ; hold it; \`[\\s\\S]\` (GBNF's \`.\`) as the range of every code point. A
1779
+ ; negated class has no ABNF form.
1780
+ def abnf-class-text [pat flags]
1781
+ match pat
1782
+ case "[\\\\s\\\\S]" "%x0-10FFFF"
1783
+ case _ (abnf-range-text pat)
1784
+
1785
+ def abnf-range-text [pat]
1786
+ let [body (abnf-before "]" (abnf-after "[" pat))]
1787
+ match (abnf-starts "^" body)
1788
+ case true (abnf-fail (string-join "" ["the class " pat " is negated, which ABNF has no form for"]))
1789
+ case false
1790
+ let [members (abnf-class-members body)]
1791
+ match (abnf-none (filter (fn [m] (abnf-empty (get :lo m))) members))
1792
+ case false (abnf-fail (string-join "" ["the class " pat " is not a range ABNF writes"]))
1793
+ case true
1794
+ match (count members)
1795
+ case 0 (abnf-fail (string-join "" ["the class " pat " is empty"]))
1796
+ case 1 (abnf-member-text pat (abnf-at members 0))
1797
+ case _ (string-join "" ["( " (string-join " / " (map (fn [m] (abnf-member-text pat m)) members)) " )"])
1798
+
1799
+ ; A class's members, each \`\\uXXXX\` or \`\\u{X...}\` alone or the low end of a
1800
+ ; range: its digits and its high end's, ABNF's hexadecimal digits.
1801
+ def abnf-class-members [body]
1802
+ let [pieces (abnf-rest (split "\\\\u" body))]
1803
+ let [prev (abnf-cat [""] pieces)]
1804
+ map
1805
+ fn [i]
1806
+ let [piece (abnf-at pieces i)]
1807
+ match (abnf-ends "-" piece)
1808
+ case true
1809
+ record
1810
+ entry :lo (abnf-escape-hex (string-join "" ["\\\\u" (abnf-before "-" piece)]))
1811
+ entry :hi (abnf-escape-hex (string-join "" ["\\\\u" (abnf-str (abnf-at pieces (abnf-plus i 1)))]))
1812
+ case false
1813
+ record
1814
+ entry :lo (abnf-escape-hex (string-join "" ["\\\\u" piece]))
1815
+ entry :hi (abnf-escape-hex (string-join "" ["\\\\u" piece]))
1816
+ filter (fn [i] (abnf-not (abnf-ends "-" (abnf-at prev i)))) (indices pieces)
1817
+
1818
+ ; A member: a range as a range; a character as a string that matches it
1819
+ ; exactly where a string can hold it, and otherwise, below U+0080, as a
1820
+ ; range of one, which the compiler reads as that character. A character
1821
+ ; past ASCII that no string holds is refused, since a range of one is read
1822
+ ; without regard to case.
1823
+ def abnf-member-text [pat m]
1824
+ match (abnf-same (get :lo m) (get :hi m))
1825
+ case false (string-join "" ["%x" (get :lo m) "-" (get :hi m)])
1826
+ case true
1827
+ let [h (get :lo m)]
1828
+ let [h4 (string-join "" [(match (length h) (case 1 "000") (case 2 "00") (case 3 "0") (case _ "")) (abnf-hex-lower h)])]
1829
+ match (abnf-ascii-code h4)
1830
+ case false (abnf-fail (string-join "" ["the class " pat " holds U+" (abnf-hex-upper h4) " alone, which ABNF writes only as a numeric value, read without regard to case"]))
1831
+ case true
1832
+ let [c (unquoted (string-join "" ["\\"\\\\u" h4 "\\""]))]
1833
+ match (chars-within [[32 33] [35 126]] c)
1834
+ case true (abnf-lit-text c true)
1835
+ case false (string-join "" ["%x" h "-" h])
1836
+
1837
+ ; Whether four hexadecimal digits name an ASCII character.
1838
+ def abnf-ascii-code [h4]
1839
+ match (abnf-starts "00" h4)
1840
+ case false false
1841
+ case true (abnf-some (filter (fn [d] (abnf-starts d (abnf-after "00" h4))) ["0" "1" "2" "3" "4" "5" "6" "7"]))
1842
+
1843
+ ; ---- ABNF's elements
1844
+
1845
+ ; Alternatives' text without the space an empty first or last one leaves
1846
+ ; at either end (\`a = / "x"\`).
1847
+ def abnf-trim-ends [t]
1848
+ let [lead (match (abnf-starts " " t) (case true (abnf-after " " t)) (case false t))]
1849
+ match (abnf-ends " " lead)
1850
+ case true (abnf-before " " lead)
1851
+ case false lead
1852
+
1853
+ ; A rule name ABNF can spell: a letter, then letters, digits and hyphens.
1854
+ def abnf-legal-name [name]
1855
+ match name
1856
+ case "" false
1857
+ case _
1858
+ match (chars-within [[45 45] [48 57] [65 90] [97 122]] name)
1859
+ case false false
1860
+ case true
1861
+ match (abnf-starts "-" name)
1862
+ case true false
1863
+ case false (abnf-none (filter (fn [d] (abnf-starts d name)) ["0" "1" "2" "3" "4" "5" "6" "7" "8" "9"]))
1864
+
1865
+ def abnf-ref-text [name]
1866
+ match (abnf-legal-name name)
1867
+ case true name
1868
+ case false (abnf-fail (string-join "" ["the rule " (quoted name) " has a name ABNF cannot spell"]))
1869
+
1870
+ ; Whether a token is a rule the compiler lifted: a literal's token whose
1871
+ ; name is not the one the literal gives it, or that nothing references.
1872
+ def abnf-lifted [cx used t]
1873
+ let [info (abnf-token cx t)]
1874
+ match (get :k info)
1875
+ case :lit
1876
+ match (abnf-legal-name (abnf-bare t))
1877
+ case false false
1878
+ case true
1879
+ match (abnf-derived (abnf-bare t) (get :text info))
1880
+ case false true
1881
+ case true (abnf-not (abnf-some (abnf-rest (split (string-join "" [" " t " "]) used))))
1882
+ case _ false
1883
+
1884
+ def abnf-token-text [cx lifted t]
1885
+ match (abnf-among t lifted)
1886
+ case true (abnf-bare t)
1887
+ case false
1888
+ let [info (abnf-token cx t)]
1889
+ match (get :k info)
1890
+ case :lit (abnf-lit-text (get :text info) (get :cs info))
1891
+ case :class (abnf-class-text (get :pat info) (get :flags info))
1892
+ case :engine (get :name info)
1893
+
1894
+ def abnf-rep-text [self cx lifted name]
1895
+ let [parts (abnf-rep-parts cx name)]
1896
+ let [min (abnf-num (get :min parts))]
1897
+ let [count-text (match (get :max parts) (case "" (string-join "" [min "*"])) (case max (match (abnf-same min max) (case true min) (case false (string-join "" [(match min (case "0" "") (case _ min)) "*" max])))))]
1898
+ string-join "" [count-text (self self cx lifted :atom (get :item parts))]
1899
+
1900
+ ; The element a repetition applies to: a terminal, a rule, a group or an
1901
+ ; option; any other construct is put in a group of its own.
1902
+ def abnf-atom-text [self cx lifted el]
1903
+ match (get :k el)
1904
+ case :tok (abnf-token-text cx lifted (get :name el))
1905
+ case :grp (self self cx lifted :el el)
1906
+ case :ref
1907
+ match (abnf-helper-kind cx (get :name el))
1908
+ case "group" (self self cx lifted :el el)
1909
+ case "opt"
1910
+ match (abnf-opt-group cx (get :name el))
1911
+ case true (self self cx lifted :el el)
1912
+ case false (string-join "" ["( " (self self cx lifted :el el) " )"])
1913
+ case "" (self self cx lifted :el el)
1914
+ case _ (string-join "" ["( " (self self cx lifted :el el) " )"])
1915
+ case _ (string-join "" ["( " (self self cx lifted :el el) " )"])
1916
+
1917
+ def abnf-el-text [self cx lifted el]
1918
+ match (get :k el)
1919
+ case :tok (abnf-token-text cx lifted (get :name el))
1920
+ case :tail (string-join "" ["[ " (self self cx lifted :alts [(get :seq el)]) " ]"])
1921
+ case :grp (string-join "" ["( " (self self cx lifted :alts [(get :seq el)]) " )"])
1922
+ case :ref
1923
+ let [name (get :name el)]
1924
+ match (abnf-helper-kind cx name)
1925
+ case "" (abnf-ref-text name)
1926
+ case "star" (string-join "" ["*" (self self cx lifted :atom (abnf-loop-item cx name (abnf-rule cx name)))])
1927
+ case "plus"
1928
+ let [seq (abnf-at (abnf-alts cx name) 0)]
1929
+ string-join "" ["1*" (self self cx lifted :atom (abnf-at seq 0))]
1930
+ case "opt"
1931
+ let [inner (abnf-at (abnf-filled (abnf-alts cx name)) 0)]
1932
+ match (abnf-opt-group cx name)
1933
+ case true (string-join "" ["[ " (self self cx lifted :alts (abnf-alts cx (get :name inner))) " ]"])
1934
+ case false (string-join "" ["0*1" (self self cx lifted :atom inner)])
1935
+ case "rep" (abnf-rep-text self cx lifted name)
1936
+ case "group" (string-join "" ["( " (self self cx lifted :alts (abnf-alts cx name)) " )"])
1937
+ case kind (abnf-fail (string-join "" ["the rule " name " is a helper of a kind the render does not read (" kind ")"]))
1938
+
1939
+ def abnf-seq-text [self cx lifted seq]
1940
+ string-join " " (map (fn [el] (self self cx lifted :el el)) seq)
1941
+
1942
+ ; The text of a rule's or a group's alternatives (\`:alts\`, ABNF's \`/\`
1943
+ ; between them), of an element (\`:el\`) and of the element a repetition
1944
+ ; applies to (\`:atom\`): the one function the render recurses through, as
1945
+ ; \`self\`, a helper's alternatives a level deeper.
1946
+ def abnf-text [self cx lifted mode x]
1947
+ match mode
1948
+ case :alts (abnf-trim-ends (string-join " / " (map (fn [seq] (abnf-seq-text self cx lifted seq)) x)))
1949
+ case :el (abnf-el-text self cx lifted x)
1950
+ case :atom (abnf-atom-text self cx lifted x)
1951
+
1952
+ ; ---- core rules
1953
+
1954
+ ; The RFC 5234 core rules, in the order the compiler adds them: a pass
1955
+ ; over them in this order adds every one the grammar references, and
1956
+ ; another pass every one those reference, until none is missing. So the
1957
+ ; core rules a spec holds, in its order, rise through this list for the
1958
+ ; ones the grammar itself referenced, and fall back at the first the core
1959
+ ; rules referenced instead.
1960
+ def abnf-core-order ["ALPHA" "BIT" "CHAR" "CR" "LF" "CRLF" "CTL" "DIGIT" "DQUOTE" "HEXDIG" "HTAB" "OCTET" "SP" "VCHAR" "WSP" "LWSP"]
1961
+
1962
+ def abnf-core-index [name]
1963
+ let [found (filter (fn [i] (abnf-same (abnf-at abnf-core-order i) name)) (indices abnf-core-order))]
1964
+ match (count found)
1965
+ case 0 99
1966
+ case _ (abnf-at found 0)
1967
+
1968
+ ; The core rules the grammar referenced itself: the ones a written rule
1969
+ ; can name, which the compiler adds again.
1970
+ def abnf-direct-core [cx]
1971
+ let [core (filter (fn [n] (match (abnf-made cx n) (case true false) (case false (abnf-same (abnf-kind (abnf-rule cx n)) "core")))) (keys (get :rules cx)))]
1972
+ let [idx (map abnf-core-index core)]
1973
+ let [prev (abnf-cat [-1] idx)]
1974
+ let [falls (filter (fn [i] (abnf-less (abnf-at idx i) (abnf-at prev i))) (indices idx))]
1975
+ match (count falls)
1976
+ case 0 core
1977
+ case _ (abnf-take (abnf-at falls 0) core)
1978
+
1979
+ ; ---- the file
1980
+
1981
+ def abnf-production [cx cands lifted name]
1982
+ string-join "" [(abnf-ref-text name) " = " (abnf-text abnf-text cx lifted :alts (abnf-unsub cx cands name (abnf-alts cx name)))]
1983
+
1984
+ def abnf-lifted-production [cx t]
1985
+ let [info (abnf-token cx t)]
1986
+ string-join "" [(abnf-ref-text (abnf-bare t)) " = " (abnf-lit-text (get :text info) (get :cs info))]
1987
+
1988
+ ; A rule the compiler lifted to a token is written under the token's name,
1989
+ ; which no rule of the spec may hold already: two productions of one name
1990
+ ; are one rule.
1991
+ def abnf-check-lifted [cx lifted]
1992
+ map
1993
+ fn [t]
1994
+ match (abnf-has cx (abnf-bare t))
1995
+ case true (abnf-fail (string-join "" ["the token " t " is written as a rule named " (abnf-bare t) ", the name of another rule the spec holds"]))
1996
+ case false t
1997
+ lifted
1998
+
1999
+ ; The grammar's start rule: the one the start wrapper pushes, or the rule
2000
+ ; \`options.rule.start\` names where it is no wrapper.
2001
+ def abnf-start-rule [cx]
2002
+ let [r (abnf-rule cx (get :start cx))]
2003
+ match (abnf-wrapper r)
2004
+ case true (abnf-p (abnf-at (abnf-open r) 0))
2005
+ case false (get :start cx)
2006
+
2007
+ def abnf-file [spec]
2008
+ let [cx (abnf-context spec)]
2009
+ let [checked (abnf-check spec cx)]
2010
+ let [names (filter (fn [n] (match (abnf-made cx n) (case true false) (case false (abnf-same (abnf-kind (abnf-rule cx n)) "user")))) (keys (get :rules cx)))]
2011
+ let [start (abnf-start-rule cx)]
2012
+ let [ordered (abnf-cat [start] (filter (fn [n] (abnf-not (abnf-same n start))) names))]
2013
+ let [used (abnf-used cx)]
2014
+ let [tokens (abnf-cat (keys (get :fixed cx)) (keys (get :match cx)))]
2015
+ let [lifted (abnf-check-lifted cx (filter (fn [t] (abnf-lifted cx used t)) tokens))]
2016
+ let [cands (abnf-candidates cx (abnf-cat ordered (abnf-direct-core cx)))]
2017
+ string-join ""
2018
+ vector
2019
+ string-join "\\n" (abnf-cat (map (fn [n] (abnf-production cx cands lifted n)) ordered) (map (fn [t] (abnf-lifted-production cx t)) lifted))
2020
+ "\\n"
2021
+
2022
+ def abnf-render [input]
2023
+ concat-map abnf-file (select root input)
2024
+ ` })
2025
+ })
2026
+
2027
+ function translate (): TranslationParts | undefined {
2028
+ return TRANSLATION
2029
+ }
2030
+
2031
+ export {
2032
+ translate,
2033
+ }
2034
+
2035
+ export type {
2036
+ TranslationPart,
2037
+ TranslationParts,
2038
+ }