@tabnas/abnf 0.4.19 → 0.4.21

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,1632 @@
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, 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
+ "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, 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 character past U+FFFF), 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."
65
+ ]
66
+ }
67
+ }
68
+ `,
69
+ render: Object.freeze({ entry: "abnf-render", source: `; ABNF's render: a grammar-spec tree, the GrammarSpec the tabnas BNF
70
+ ; compiler (tabnas-bnf) emits for a grammar, written back as RFC 5234
71
+ ; ABNF. This is a library of definitions, each named \`abnf-...\`, which a
72
+ ; host links with its own program (alchemy's \`compile_sources\`); its entry
73
+ ; point is \`abnf-render\`, and nothing else here is the host's to call.
74
+ ;
75
+ ; A host reads an ABNF document by compiling it: the grammar-spec tree is
76
+ ; the pure-data GrammarSpec that \`abnfCompile(src, {recognition: false,
77
+ ; strict: true})\` writes (\`abnf_compile\` in Rust, \`AbnfCompile\` in Go;
78
+ ; the same text in all three runtimes, which tabnas-bnf's oracle tests
79
+ ; hold byte for byte), parsed as JSON. Its schema is \`grammar-spec\`,
80
+ ; shared with EBNF and GBNF, whose compilers emit the same shape; the
81
+ ; contract is the round trip: the text written here compiles back to the
82
+ ; spec it was written from.
83
+ ;
84
+ ; The spec is a compiled grammar, not the grammar's text, so the render
85
+ ; reads the compiler's shapes back into the notation:
86
+ ;
87
+ ; - A rule the author wrote is a rule of the spec that the spec's
88
+ ; \`meta.provenance\` does not name; every rule it names is the
89
+ ; compiler's: a repetition's, an option's or a group's helper
90
+ ; (\`_gen<n>_star_...\`, \`_plus_\`, \`_opt_\`, \`_rep_\`, \`_group\`), a
91
+ ; sequence's chain steps (\`$alt<i>\`, \`$step<j>\`), a left-factored tail
92
+ ; (\`$fact<k>\`) and the start wrapper. A helper is written where it is
93
+ ; referenced, as the construct it compiles: a repeat loop (the replace
94
+ ; loop every \`*A\` compiles to, its entry \`{c: {n.rep: 0}, r: <self>}\`)
95
+ ; as \`*A\`, a plus as \`1*A\`, an option over a group as \`[ ... ]\` and over
96
+ ; anything else as \`0*1A\`, a counted repetition as \`m*nA\` (its nested
97
+ ; optionals counted), a group as \`( ... )\`. A factored tail is expanded
98
+ ; back into the alternatives it was factored from, which the compiler
99
+ ; factors again, and alternatives that were each a group, which the
100
+ ; compiler factored into the first, are read back as the groups they
101
+ ; were.
102
+ ; - An alternative of a rule is read from the alternates the compiler
103
+ ; emitted for it: a chain of steps, one per segment of terminals and a
104
+ ; reference; a dispatcher's \`$alt<i>\` rules, the gap in their numbers
105
+ ; the empty alternative; or, for a rule whose every alternative is one
106
+ ; segment, its open alternates, each read as the tokens it consumes
107
+ ; (its \`s\` less the \`b\` it gives back) and the rule it pushes, the
108
+ ; lookahead copies the dispatch made of one alternative read as one,
109
+ ; the empty alternative first (the compiler puts it last wherever it
110
+ ; stood), and those that push a helper in the order of the helpers'
111
+ ; numbers, which the compiler gives them before it reorders the
112
+ ; alternatives to tell them apart.
113
+ ; - A leading reference the compiler substituted by the referenced rule's
114
+ ; alternatives is written back where those alternatives, each followed
115
+ ; by one same tail, still stand together.
116
+ ; - A token is written as the terminal it matches: a fixed token as a
117
+ ; quoted string, \`%s"..."\` where it holds a letter, a case-folding
118
+ ; match token as a quoted string, a range as \`%x<lo>-<hi>\` (a token set
119
+ ; the compiler laid over a contested range read back from its name),
120
+ ; and the engine's \`#TX\`, \`#NR\`, \`#ST\` and \`#VL\` by their names. A
121
+ ; string a quoted string cannot hold is written as a numeric value,
122
+ ; \`%x<hex>.<hex>\`. A token named for a rule the compiler lifted to it
123
+ ; (\`CR = %x0D\` becomes the token \`#CR\`) is written as that rule, after
124
+ ; the others, and referenced by name.
125
+ ; - An RFC 5234 core rule (ALPHA, DIGIT, ...) in the spec is not written,
126
+ ; since the compiler adds it again wherever it is referenced, and a
127
+ ; leading reference to one is written back as any other is.
128
+ ;
129
+ ; What a rule cannot be read back to is refused with
130
+ ; TARGET_VALUE_UNREPRESENTABLE, naming the rule: an action other than the
131
+ ; tree builders every compiled grammar carries (a value annotation's
132
+ ; builders, a user action, the probe dispatcher's), a condition or a
133
+ ; counter other than a repeat loop's, an error generator or an alternate
134
+ ; modifier (\`e\`, \`h\`), a function reference where a rule or a count is
135
+ ; due, a set of tokens at one place, the form that edits a rule already
136
+ ; installed (\`{alts, inject}\`), a removal, and a token no ABNF terminal
137
+ ; matches (a negated class, a class holding a character past ASCII alone,
138
+ ; a class whose flags change what it matches, a pattern that is neither
139
+ ; one class nor an escaped literal). A spec serialized by Go, which writes
140
+ ; its rules in name order and its match tokens' order as a list of its
141
+ ; own (\`options.match.tokenOrder\`), is refused when that list holds two
142
+ ; tokens or more: the rules' order, which ranks the tokens (the order the
143
+ ; lexer tries two tokens a place expects), is lost.
144
+ ;
145
+ ; A spec compiled from another notation is written as far as ABNF can say
146
+ ; it: a class of several members (GBNF's and EBNF's \`[a-zA-Z_]\`) as the
147
+ ; alternation of its members, each range a range and each character a
148
+ ; string that matches it exactly, and an engine token by its name.
149
+ ;
150
+ ; The whole spec is materialized before a line is written: a rule's
151
+ ; alternatives are spread over its chain rules and helpers, which the
152
+ ; spec keeps elsewhere in its \`rule\` object.
153
+
154
+ ; ---- text and vectors
155
+
156
+ def abnf-at [v i]
157
+ get-path (as-path [i]) v
158
+
159
+ def abnf-num [n]
160
+ scalar-text csv-options n
161
+
162
+ def abnf-empty [s]
163
+ match s
164
+ case "" true
165
+ case _ false
166
+
167
+ def abnf-full [s]
168
+ match s
169
+ case "" false
170
+ case _ true
171
+
172
+ ; Whether the strings a and b are the same: a string cut by itself is two
173
+ ; empty strings, and by any other string it is not.
174
+ def abnf-same [a b]
175
+ match b
176
+ case "" (abnf-empty a)
177
+ case _
178
+ match (split b a)
179
+ case ["" ""] true
180
+ case _ false
181
+
182
+ def abnf-not [x]
183
+ match x
184
+ case true false
185
+ case false true
186
+
187
+ def abnf-less [a b]
188
+ match (compare a b)
189
+ case :less true
190
+ case _ false
191
+
192
+ def abnf-some [v]
193
+ match (count v)
194
+ case 0 false
195
+ case _ true
196
+
197
+ def abnf-none [v]
198
+ match (count v)
199
+ case 0 true
200
+ case _ false
201
+
202
+ def abnf-rest [v]
203
+ map (fn [i] (abnf-at v i)) (filter (fn [i] (match i (case 0 false) (case _ true))) (indices v))
204
+
205
+ def abnf-take [n v]
206
+ map (fn [i] (abnf-at v i)) (filter (fn [i] (abnf-less i n)) (indices v))
207
+
208
+ def abnf-drop [n v]
209
+ map (fn [i] (abnf-at v i)) (filter (fn [i] (abnf-not (abnf-less i n))) (indices v))
210
+
211
+ ; Whether s begins with the non-empty p, ends with it; s after its first
212
+ ; p, before its last.
213
+ def abnf-starts [p s]
214
+ match s
215
+ case "" false
216
+ case _ (abnf-empty (abnf-at (split p s) 0))
217
+
218
+ def abnf-ends [p s]
219
+ match s
220
+ case "" false
221
+ case _ (abnf-empty (top (split p s)))
222
+
223
+ def abnf-after [p s]
224
+ string-join p (abnf-rest (split p s))
225
+
226
+ def abnf-before [p s]
227
+ string-join p (pop (split p s))
228
+
229
+ def abnf-digits [s]
230
+ match s
231
+ case "" false
232
+ case _ (chars-within [[48 57]] s)
233
+
234
+ ; The items of two vectors, and of a vector of vectors, in order: each
235
+ ; item is named by its place, the places joined as text and read back.
236
+ def abnf-cat [a b]
237
+ abnf-flat [a b]
238
+
239
+ def abnf-flat [vv]
240
+ map
241
+ fn [t]
242
+ let [p (split "." t)]
243
+ get-path (as-path [(number (abnf-at p 0)) (number (abnf-at p 1))]) vv
244
+ filter abnf-full
245
+ split ","
246
+ string-join ","
247
+ map
248
+ fn [j]
249
+ string-join "," (map (fn [i] (string-join "." [(abnf-num j) (abnf-num i)])) (indices (abnf-at vv j)))
250
+ indices vv
251
+
252
+ ; Whether the string s is among the strings of v.
253
+ def abnf-among [s v]
254
+ abnf-some (filter (fn [x] (abnf-same x s)) v)
255
+
256
+ ; The items of v whose key is the first of its kind, in order.
257
+ def abnf-unique [keyf v]
258
+ let [ks (map keyf v)]
259
+ let [prev (abnf-cat ["\\u0000"] (pop (abnf-cat ks ["\\u0000"])))]
260
+ let [runs (filter (fn [i] (abnf-not (abnf-same (abnf-at ks i) (abnf-at prev i)))) (indices ks))]
261
+ map
262
+ fn [i] (abnf-at v i)
263
+ filter
264
+ fn [i]
265
+ 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)
266
+ runs
267
+
268
+ def abnf-plus [a b]
269
+ length (string-join "" [(repeat a "x") (repeat b "x")])
270
+
271
+ def abnf-ones [n]
272
+ pop (split "x" (repeat n "x"))
273
+
274
+ def abnf-even [j]
275
+ abnf-some (filter (fn [d] (abnf-ends d (abnf-num j))) ["0" "2" "4" "6" "8"])
276
+
277
+ def abnf-fail [what]
278
+ fail :unrepresentable (string-join "" ["the grammar spec cannot be written as ABNF: " what])
279
+
280
+ ; ---- the spec
281
+
282
+ def abnf-rec [v]
283
+ match (kind v)
284
+ case :record v
285
+ case _ (record)
286
+
287
+ def abnf-vec [v]
288
+ match (kind v)
289
+ case :vector (as-vector v)
290
+ case _ []
291
+
292
+ def abnf-str [v]
293
+ match (kind v)
294
+ case :string v
295
+ case _ ""
296
+
297
+ def abnf-context [spec]
298
+ let [o (abnf-rec (get "options" spec))]
299
+ record
300
+ entry :rules (abnf-rec (get "rule" spec))
301
+ entry :fixed (abnf-rec (get-path (as-path ["fixed" "token"]) o))
302
+ entry :match (abnf-rec (get-path (as-path ["match" "token"]) o))
303
+ entry :sets (abnf-rec (get "tokenSet" o))
304
+ entry :prov (get-path (as-path ["meta" "provenance"]) spec)
305
+ entry :start (abnf-str (get-path (as-path ["rule" "start"]) o))
306
+
307
+ def abnf-rule [cx name]
308
+ get-path (as-path [name]) (get :rules cx)
309
+
310
+ def abnf-has [cx name]
311
+ match (kind (abnf-rule cx name))
312
+ case :record true
313
+ case _ false
314
+
315
+ ; A rule's alternates in one phase, the falsy placeholders the engine
316
+ ; skips left out.
317
+ def abnf-open [r]
318
+ filter (fn [alt] (match (kind alt) (case :record true) (case _ false))) (abnf-vec (get "open" r))
319
+
320
+ def abnf-close [r]
321
+ filter (fn [alt] (match (kind alt) (case :record true) (case _ false))) (abnf-vec (get "close" r))
322
+
323
+ ; The tokens an alternate matches: its \`s\`, a string of token names
324
+ ; between spaces or a list of them.
325
+ def abnf-s [alt]
326
+ let [s (get "s" alt)]
327
+ match (kind s)
328
+ case :string (filter abnf-full (split " " s))
329
+ case :vector (map abnf-str (as-vector s))
330
+ case _ []
331
+
332
+ def abnf-b [alt]
333
+ match (kind (get "b" alt))
334
+ case :number (get "b" alt)
335
+ case _ 0
336
+
337
+ def abnf-p [alt]
338
+ abnf-str (get "p" alt)
339
+
340
+ def abnf-r [alt]
341
+ abnf-str (get "r" alt)
342
+
343
+ def abnf-a [alt]
344
+ match (kind (get "a" alt))
345
+ case :string (get "a" alt)
346
+ case :missing ""
347
+ case :null ""
348
+ case _ "?"
349
+
350
+ ; Whether the compiler made the rule: provenance names every rule it
351
+ ; synthesized, and a spec without provenance is read by the names it
352
+ ; gives them.
353
+ def abnf-made [cx name]
354
+ match (kind (get :prov cx))
355
+ case :record
356
+ match (kind (get-path (as-path [name]) (get :prov cx)))
357
+ case :string true
358
+ case _ false
359
+ case _
360
+ match (abnf-starts "_gen" name)
361
+ case true true
362
+ case false (abnf-some (abnf-rest (split "$" name)))
363
+
364
+ ; The kind the tree builders give a rule the author wrote: "user", or
365
+ ; "core" for an RFC 5234 core rule the compiler added.
366
+ def abnf-kind [r]
367
+ let [o (abnf-open r)]
368
+ match (count o)
369
+ case 0 "user"
370
+ case _
371
+ match (abnf-str (get-path (as-path ["k" "node$" "kind"]) (abnf-at o 0)))
372
+ case "core" "core"
373
+ case _ "user"
374
+
375
+ ; ---- what the spec may hold
376
+
377
+ ; Every alternate is one the compiler's tree-building grammars are made
378
+ ; of: the tokens it matches and gives back (\`s\`, \`b\`), the rule it pushes
379
+ ; or replaces itself with (\`p\`, \`r\`), the tree builders (\`a\`, \`k\`), group
380
+ ; tags, marks and per-rule scratch (\`g\`, \`m\`, \`u\`), and, in a repeat loop
381
+ ; alone, the loop's guard and counter (\`c\`, \`n\`). Anything more is a
382
+ ; construct the notation does not write: an error generator (\`e\`), an
383
+ ; alternate modifier (\`h\`), a function in place of a rule or a count, an
384
+ ; action other than the tree builders, another condition or counter.
385
+ def abnf-alt-keys ["s" "b" "p" "r" "a" "c" "n" "k" "g" "m" "u"]
386
+
387
+ def abnf-key-text [key]
388
+ match key
389
+ case "e" "e (an error generator)"
390
+ case "h" "h (an alternate modifier)"
391
+ case _ key
392
+
393
+ def abnf-check-alt [cx name alt]
394
+ let [extra (filter (fn [key] (match (abnf-among key abnf-alt-keys) (case true false) (case false (abnf-given (get key alt))))) (keys alt))]
395
+ match (count extra)
396
+ case 0 (abnf-check-parts cx name alt)
397
+ case _ (abnf-fail (string-join "" ["rule " name " has an alternate carrying " (string-join ", " (map abnf-key-text extra)) ", which is not written"]))
398
+
399
+ def abnf-check-parts [cx name alt]
400
+ let [a (abnf-a alt)]
401
+ match (abnf-among a ["" "@node$" "@capture$" "@bubble$" "@fold$"])
402
+ case false
403
+ match (abnf-starts "@probe" (abnf-action-text alt))
404
+ 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"]))
405
+ case false (abnf-fail (string-join "" ["rule " name " carries an action (" (abnf-action-text alt) "), which is not written"]))
406
+ case true
407
+ let [tokens (abnf-check-s name (get "s" alt))]
408
+ let [next (count (map (fn [key] (abnf-check-next name key (get key alt))) ["p" "r"]))]
409
+ let [back (abnf-check-back name (get "b" alt))]
410
+ abnf-check-loop cx name alt
411
+
412
+ ; The tokens: a string of names between spaces, or a list of names, one
413
+ ; place each; a place holding a set of tokens (names between spaces, or a
414
+ ; list) chooses among them, which the render does not read back.
415
+ def abnf-check-s [name s]
416
+ match (kind s)
417
+ case :missing true
418
+ case :null true
419
+ case :string true
420
+ case :vector
421
+ match (abnf-none (filter (fn [t] (match (kind t) (case :string (abnf-some (abnf-rest (split " " t)))) (case _ true))) (as-vector s)))
422
+ case true true
423
+ 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"]))
424
+ case _ (abnf-fail (string-join "" ["rule " name " has an alternate whose s is not tokens, which is not written"]))
425
+
426
+ ; The rule an alternate pushes or replaces itself with: a name, or none;
427
+ ; a function reference (\`@name\`) chooses at run time and is not written.
428
+ def abnf-check-next [name key v]
429
+ match (kind v)
430
+ case :missing true
431
+ case :null true
432
+ 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"]))))
433
+ case :string
434
+ match (abnf-starts "@" v)
435
+ case true (abnf-fail (string-join "" ["rule " name " has an alternate whose " key " is the function reference " v ", which is not written"]))
436
+ case false true
437
+ case _ (abnf-fail (string-join "" ["rule " name " has an alternate whose " key " is not a rule, which is not written"]))
438
+
439
+ def abnf-check-back [name v]
440
+ match (kind v)
441
+ case :missing true
442
+ case :null true
443
+ case :number true
444
+ 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"]))))
445
+ case _ (abnf-fail (string-join "" ["rule " name " has an alternate whose b is not a count (" (abnf-str v) "), which is not written"]))
446
+
447
+ ; A repeat loop's guard (\`c: {n.rep: 0}\`) and counter (\`n: {rep: 0}\` or
448
+ ; \`{rep: 1}\`), in the loop the compiler makes for a repetition and the
449
+ ; steps of its item, and nowhere else.
450
+ def abnf-loop-rule [cx name]
451
+ abnf-same (abnf-helper-kind cx (abnf-at (split "$" name) 0)) "star"
452
+
453
+ def abnf-check-loop [cx name alt]
454
+ let [c (get "c" alt)]
455
+ let [n (get "n" alt)]
456
+ match (match (abnf-given c) (case true true) (case false (abnf-given n)))
457
+ case false true
458
+ case true
459
+ match (abnf-loop-rule cx name)
460
+ case false (abnf-fail (string-join "" ["rule " name " carries a condition or a counter outside a repetition's loop, which is not written"]))
461
+ case true
462
+ match (match (abnf-given c) (case false true) (case true (match (kind c) (case :record (abnf-loop-value c "n.rep" [0])) (case _ false))))
463
+ case false (abnf-fail (string-join "" ["rule " name " carries a condition other than its loop's, which is not written"]))
464
+ case true
465
+ match (match (abnf-given n) (case false true) (case true (match (kind n) (case :record (abnf-loop-value n "rep" [0 1])) (case _ false))))
466
+ case false (abnf-fail (string-join "" ["rule " name " carries a counter other than its loop's, which is not written"]))
467
+ case true true
468
+
469
+ ; Whether an alternate gives a field: the engine reads a field that is
470
+ ; missing, null or false as one it does not give.
471
+ def abnf-given [v]
472
+ match (kind v)
473
+ case :missing false
474
+ case :null false
475
+ case :boolean (match v (case false false) (case _ true))
476
+ case _ true
477
+
478
+ def abnf-loop-value [rec key allowed]
479
+ match (keys rec)
480
+ case [only]
481
+ match (abnf-same only key)
482
+ case false false
483
+ case true
484
+ let [v (get-path (as-path [key]) rec)]
485
+ abnf-some (filter (fn [x] (match (compare v x) (case :equal true) (case _ false))) allowed)
486
+ case _ false
487
+
488
+ def abnf-action-text [alt]
489
+ match (kind (get "a" alt))
490
+ case :string (get "a" alt)
491
+ case :vector (string-join " " (map abnf-str (as-vector (get "a" alt))))
492
+ case _ "a function"
493
+
494
+ ; A rule's phases: a list of alternates each, or none; the form that edits
495
+ ; a rule already installed (\`{alts, inject}\`) is not written.
496
+ def abnf-check-phase [name phase v]
497
+ match (kind v)
498
+ case :missing true
499
+ case :null true
500
+ case :vector true
501
+ 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"]))
502
+ case _ (abnf-fail (string-join "" ["rule " name " gives its " phase " alternates in a form that is not a list, which is not written"]))
503
+
504
+ def abnf-check-rule [cx name]
505
+ let [r (abnf-rule cx name)]
506
+ match (kind r)
507
+ case :record
508
+ let [phases (count (map (fn [phase] (abnf-check-phase name phase (get phase r))) ["open" "close"]))]
509
+ count (map (fn [alt] (abnf-check-alt cx name alt)) (abnf-cat (abnf-open r) (abnf-close r)))
510
+ case :null (abnf-fail (string-join "" ["rule " name " is removed, which is not written"]))
511
+ case _ (abnf-fail (string-join "" ["rule " name " is not a rule's alternates, which is not written"]))
512
+
513
+ ; A spec serialized by Go writes its keys in name order and its match
514
+ ; tokens' order in a list of its own (\`options.match.tokenOrder\`): the
515
+ ; rules' order, which decides the order the compiler gives the tokens
516
+ ; again, is lost, and with it which of two tokens that both match wins.
517
+ def abnf-check-order [spec]
518
+ let [order (get-path (as-path ["options" "match" "tokenOrder"]) spec)]
519
+ match (kind order)
520
+ case :vector
521
+ match (abnf-less (count (as-vector order)) 2)
522
+ case true true
523
+ 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")
524
+ case _ true
525
+
526
+ def abnf-check [spec cx]
527
+ match (get "clear" spec)
528
+ case true (abnf-fail "it clears the grammar it is installed on, which is not written")
529
+ case _
530
+ let [order (abnf-check-order spec)]
531
+ count (map (fn [name] (abnf-check-rule cx name)) (keys (get :rules cx)))
532
+
533
+ ; ---- tokens
534
+
535
+ def abnf-bare [t]
536
+ abnf-after "#" t
537
+
538
+ def abnf-lit [text cs]
539
+ record
540
+ entry :k :lit
541
+ entry :text text
542
+ entry :cs cs
543
+
544
+ def abnf-class [pat flags]
545
+ record
546
+ entry :k :class
547
+ entry :pat pat
548
+ entry :flags flags
549
+
550
+ ; A pattern's escapes taken back off: an escaped backslash is a pair, any
551
+ ; other escape one backslash before the character it escapes.
552
+ def abnf-unescape [s]
553
+ string-join "\\\\" (map (fn [piece] (string-join "" (split "\\\\" piece))) (split "\\\\\\\\" s))
554
+
555
+ ; A match token's source, \`@~/^.../flags\`: a class, or a case-folding
556
+ ; literal.
557
+ def abnf-match-token [t m]
558
+ let [parts (split "/" m)]
559
+ let [flags (top parts)]
560
+ let [src (string-join "/" (pop (abnf-rest parts)))]
561
+ match (abnf-starts "^" src)
562
+ case false (abnf-fail (string-join "" ["the token " t " is the pattern " m ", which no ABNF terminal matches"]))
563
+ case true
564
+ let [body (abnf-after "^" src)]
565
+ match (abnf-starts "[" body)
566
+ case true
567
+ match (abnf-class-pattern body)
568
+ 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"]))
569
+ case true
570
+ match (abnf-among flags ["" "u"])
571
+ case true (abnf-class body flags)
572
+ case false (abnf-fail (string-join "" ["the token " t " is the class " m ", whose flags (" flags ") change what it matches, and no ABNF terminal matches it"]))
573
+ case false
574
+ match flags
575
+ case "i"
576
+ match (abnf-escaped-literal body)
577
+ case true (abnf-lit (abnf-unescape body) false)
578
+ 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"]))
579
+ case _ (abnf-fail (string-join "" ["the token " t " is the pattern " m ", which no ABNF terminal matches"]))
580
+
581
+ ; Whether a pattern's body is one class as the compiler writes one:
582
+ ; \`[\`, an optional \`^\`, members each a \`\\uXXXX\` or \`\\u{X...}\` escape, alone
583
+ ; or the low end of a range, and \`]\` ending it; or \`[\\s\\S]\`, which
584
+ ; another notation's \`.\` compiles to.
585
+ def abnf-class-pattern [body]
586
+ match body
587
+ case "[\\\\s\\\\S]" true
588
+ case _
589
+ match (abnf-ends "]" body)
590
+ case false false
591
+ case true
592
+ let [inner (abnf-before "]" (abnf-after "[" body))]
593
+ match (abnf-some (filter (fn [c] (abnf-some (abnf-rest (split c inner)))) ["[" "]"]))
594
+ case true false
595
+ case false
596
+ let [pieces (split "\\\\u" (match (abnf-starts "^" inner) (case true (abnf-after "^" inner)) (case false inner)))]
597
+ match (abnf-empty (abnf-at pieces 0))
598
+ case false false
599
+ case true
600
+ let [members (abnf-rest pieces)]
601
+ match (count members)
602
+ case 0 false
603
+ case _
604
+ match (abnf-ends "-" (top members))
605
+ case true false
606
+ case false (abnf-none (filter (fn [m] (abnf-not (abnf-member-piece m))) members))
607
+
608
+ def abnf-member-piece [piece]
609
+ let [core (match (abnf-ends "-" piece) (case true (abnf-before "-" piece)) (case false piece))]
610
+ match (abnf-starts "{" core)
611
+ case true
612
+ match (abnf-ends "}" core)
613
+ case false false
614
+ case true
615
+ let [h (abnf-before "}" (abnf-after "{" core))]
616
+ match (abnf-among (abnf-num (length h)) ["1" "2" "3" "4" "5" "6"])
617
+ case false false
618
+ case true (abnf-hex-only h)
619
+ case false
620
+ match (length core)
621
+ case 4 (abnf-hex-only core)
622
+ case _ false
623
+
624
+ def abnf-hex-only [h]
625
+ match h
626
+ case "" false
627
+ case _ (chars-within [[48 57] [65 70] [97 102]] h)
628
+
629
+ ; Whether a pattern's body is a literal as the compiler escapes one: every
630
+ ; character a pattern reads otherwise (\`\\ ^ $ . * + ? ( ) [ ] { } |\`)
631
+ ; after a backslash, and a backslash before nothing else.
632
+ def abnf-meta-chars ["^" "$" "." "*" "+" "?" "(" ")" "[" "]" "{" "}" "|"]
633
+
634
+ def abnf-escaped-literal [body]
635
+ let [rest (abnf-strip-escapes abnf-strip-escapes abnf-meta-chars (string-join "" (split "\\\\\\\\" body)))]
636
+ match (abnf-some (abnf-rest (split "\\\\" rest)))
637
+ case true false
638
+ case false (abnf-none (filter (fn [c] (abnf-some (abnf-rest (split c rest)))) abnf-meta-chars))
639
+
640
+ def abnf-strip-escapes [self cs s]
641
+ match (count cs)
642
+ case 0 s
643
+ case _ (self self (pop cs) (string-join "" (split (string-join "" ["\\\\" (top cs)]) s)))
644
+
645
+ ; A token set's class, read back from its name, which the compiler gives
646
+ ; the class it lays over the atoms (\`rx_\` and the pattern, each character
647
+ ; that is not a letter or a digit an underscore, in capitals). Each member
648
+ ; of the pattern is a \`\\u\` escape, \`\\uXXXX\` or \`\\u{X...}\`, alone or the
649
+ ; low end of a range; the name keeps their digits and order.
650
+ def abnf-hex-lower [h]
651
+ 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)))))))))))
652
+
653
+ def abnf-hex-upper [h]
654
+ 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)))))))))))
655
+
656
+ def abnf-set-member [piece]
657
+ let [parts (split "_" piece)]
658
+ match (abnf-empty (abnf-at parts 0))
659
+ case true
660
+ record
661
+ entry :text (string-join "" ["\\\\u{" (abnf-hex-lower (abnf-at parts 1)) "}"])
662
+ entry :braced true
663
+ entry :range (match (count parts) (case 4 true) (case _ false))
664
+ case false
665
+ record
666
+ entry :text (string-join "" ["\\\\u" (abnf-hex-lower (abnf-at parts 0))])
667
+ entry :braced false
668
+ entry :range (match (count parts) (case 2 true) (case _ false))
669
+
670
+ def abnf-set-token [t]
671
+ let [rest (abnf-after "RX_" (abnf-bare t))]
672
+ match rest
673
+ case "__S_S" (abnf-class "[\\\\s\\\\S]" "u")
674
+ case _
675
+ let [pieces (split "_U" rest)]
676
+ let [members (map abnf-set-member (abnf-rest pieces))]
677
+ let [negated (abnf-same (abnf-at pieces 0) "__")]
678
+ let [body (string-join "" (map (fn [m] (string-join "" [(get :text m) (match (get :range m) (case true "-") (case false ""))])) members))]
679
+ let [pat (string-join "" ["[" (match negated (case true "^") (case false "")) body "]"])]
680
+ match (abnf-same (abnf-class-name pat) (abnf-bare t))
681
+ case false (abnf-fail (string-join "" ["the token set " t " names no class the render can read back"]))
682
+ case true
683
+ match negated
684
+ case true (abnf-class pat "u")
685
+ case false (abnf-class pat (match (abnf-some (filter (fn [m] (get :braced m)) members)) (case true "u") (case false "")))
686
+
687
+ ; The name the compiler gives a class's token: \`rx_\` and its pattern, every
688
+ ; character but a letter or a digit an underscore, in capitals, with the
689
+ ; underscores at the end taken off.
690
+ def abnf-class-name [pat]
691
+ let [u (abnf-hex-upper (string-join "U" (split "u" (string-join "S" (split "s" pat)))))]
692
+ let [n (string-join "_" (split "[" (string-join "_" (split "]" (string-join "_" (split "^" (string-join "_" (split "-" (string-join "_" (split "\\\\" (string-join "_" (split "{" (string-join "_" (split "}" u))))))))))))))]
693
+ abnf-trim-end (string-join "" ["RX_" n])
694
+
695
+ def abnf-trim-end [s]
696
+ match (abnf-ends "_" s)
697
+ case true (abnf-trim-end-once (abnf-before "_" s))
698
+ case false s
699
+
700
+ def abnf-trim-end-once [s]
701
+ match (abnf-ends "_" s)
702
+ case true (abnf-before "_" s)
703
+ case false s
704
+
705
+ def abnf-engine-token [t]
706
+ match t
707
+ case "#TX" (record (entry :k :engine) (entry :name "TX"))
708
+ case "#NR" (record (entry :k :engine) (entry :name "NR"))
709
+ case "#ST" (record (entry :k :engine) (entry :name "ST"))
710
+ case "#VL" (record (entry :k :engine) (entry :name "VL"))
711
+ case _ (abnf-fail (string-join "" ["the token " t " is defined nowhere in the spec"]))
712
+
713
+ def abnf-token [cx t]
714
+ let [f (get-path (as-path [t]) (get :fixed cx))]
715
+ match (kind f)
716
+ case :string (abnf-lit f true)
717
+ case _
718
+ let [m (get-path (as-path [t]) (get :match cx))]
719
+ match (kind m)
720
+ case :string (abnf-match-token t m)
721
+ case _
722
+ match (kind (get-path (as-path [(abnf-bare t)]) (get :sets cx)))
723
+ case :vector (abnf-set-token t)
724
+ case _ (abnf-engine-token t)
725
+
726
+ ; ---- reading a rule's alternatives
727
+
728
+ ; An element of an alternative as the spec holds it: a token, or a
729
+ ; reference to a rule (the compiler's helpers among them).
730
+ def abnf-tok-el [t]
731
+ record
732
+ entry :k :tok
733
+ entry :name t
734
+
735
+ def abnf-ref-el [n]
736
+ record
737
+ entry :k :ref
738
+ entry :name n
739
+
740
+ ; The tokens an alternate consumes, and the rule it hands over to.
741
+ def abnf-consumed [alt]
742
+ let [s (abnf-s alt)]
743
+ let [b (abnf-b alt)]
744
+ abnf-take (count (filter (fn [j] (abnf-not (abnf-less j b))) (indices s))) s
745
+
746
+ def abnf-target [alt]
747
+ match (abnf-p alt)
748
+ case "" (abnf-r alt)
749
+ case p p
750
+
751
+ def abnf-entry-els [alt]
752
+ let [toks (map abnf-tok-el (abnf-consumed alt))]
753
+ match (abnf-target alt)
754
+ case "" toks
755
+ case to (push (abnf-ref-el to) toks)
756
+
757
+ def abnf-entry-key [alt]
758
+ string-join "" [(string-join " " (abnf-consumed alt)) "|" (abnf-target alt)]
759
+
760
+ ; A rule whose alternatives are each one segment: its open alternates,
761
+ ; each read as what it consumes and pushes, a dispatch's lookahead copies
762
+ ; of one alternative read as one; the empty alternative first, which the
763
+ ; compiler puts last wherever it stood, so that either place compiles
764
+ ; back the same. An alternate that consumes nothing and pushes nothing is
765
+ ; the empty alternative, or a guard that ends it on what may follow; two
766
+ ; or more bare ones (\`a ::= | \`) are as many empty alternatives.
767
+ def abnf-simple-alts [r]
768
+ let [alts (map abnf-entry-els (abnf-unique abnf-entry-key (abnf-open r)))]
769
+ let [bare (count (filter abnf-bare-empty (abnf-open r)))]
770
+ 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)))))))]
771
+ abnf-cat empties (abnf-number-order (filter abnf-some alts))
772
+
773
+ def abnf-bare-empty [alt]
774
+ match (abnf-some (abnf-s alt))
775
+ case true false
776
+ case false (abnf-empty (abnf-target alt))
777
+
778
+ ; The compiler reorders a rule's alternatives to tell them apart (a
779
+ ; longer lookahead first, a keyword ahead of a class that takes it), and
780
+ ; numbers the helpers it makes for them, in the order the alternatives
781
+ ; were written, before it does. So the alternatives that push a helper
782
+ ; are put back in the order of the helpers' numbers, among their own
783
+ ; places; the others keep theirs.
784
+ def abnf-alt-number [alt]
785
+ match (count alt)
786
+ case 0 -1
787
+ case _
788
+ let [last (top alt)]
789
+ match (get :k last)
790
+ case :ref
791
+ match (abnf-starts "_gen" (get :name last))
792
+ case true
793
+ let [d (abnf-at (split "_" (abnf-after "_gen" (get :name last))) 0)]
794
+ match (abnf-digits d)
795
+ case true (number d)
796
+ case false -1
797
+ case false -1
798
+ case _ -1
799
+
800
+ def abnf-number-order [alts]
801
+ let [nums (map abnf-alt-number alts)]
802
+ let [slots (filter (fn [i] (abnf-not (abnf-less (abnf-at nums i) 0))) (indices alts))]
803
+ 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)))]
804
+ let [ranks (map rank slots)]
805
+ map (fn [i] (abnf-number-at alts nums slots ranks i)) (indices alts)
806
+
807
+ def abnf-number-at [alts nums slots ranks i]
808
+ match (abnf-less (abnf-at nums i) 0)
809
+ case true (abnf-at alts i)
810
+ case false
811
+ let [k (count (filter (fn [j] (abnf-less j i)) slots))]
812
+ 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))
813
+
814
+ ; The first alternative that is not empty: an option's.
815
+ def abnf-filled [alts]
816
+ abnf-at (filter abnf-some alts) 0
817
+
818
+ ; The steps of a chain, each a segment: the tokens its open alternate
819
+ ; consumes and the rule it pushes, the next step named in its close.
820
+ def abnf-chain-walk [self cx name depth acc]
821
+ let [r (abnf-rule cx name)]
822
+ let [els (abnf-cat acc (abnf-entry-els (abnf-at (abnf-open r) 0)))]
823
+ match (count (abnf-close r))
824
+ case 0 els
825
+ case _
826
+ match (abnf-r (abnf-at (abnf-close r) 0))
827
+ case "" els
828
+ case next
829
+ match (abnf-less (count depth) 200)
830
+ case false (abnf-fail (string-join "" ["rule " name " is a sequence of more than 200 segments, which the render does not follow"]))
831
+ case true (self self cx next (push 1 depth) els)
832
+
833
+ def abnf-chain [cx name]
834
+ abnf-chain-walk abnf-chain-walk cx name [] []
835
+
836
+ ; A dispatcher's alternatives: one rule per alternative, \`<rule>$alt<i>\`,
837
+ ; and the empty one where a number is missing, or last.
838
+ def abnf-head-name [name i]
839
+ string-join "" [name "$alt" (abnf-num i)]
840
+
841
+ def abnf-dispatch-alts [cx name r]
842
+ let [nums (indices (push 0 (abnf-open r)))]
843
+ let [present (filter (fn [i] (abnf-has cx (abnf-head-name name i))) nums)]
844
+ let [last (top present)]
845
+ 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)]
846
+ let [empty (abnf-some (filter (fn [alt] (abnf-empty (abnf-target alt))) (abnf-open r)))]
847
+ match (count gaps)
848
+ case 0
849
+ abnf-cat (map (fn [i] (abnf-chain cx (abnf-head-name name i))) present) (match empty (case true [[]]) (case false []))
850
+ case 1
851
+ map
852
+ fn [i]
853
+ match (abnf-has cx (abnf-head-name name i))
854
+ case true (abnf-chain cx (abnf-head-name name i))
855
+ case false []
856
+ filter (fn [i] (abnf-not (abnf-less last i))) nums
857
+ case _ (abnf-fail (string-join "" ["rule " name " dispatches to alternatives the render cannot place"]))
858
+
859
+ ; Whether the rule dispatches to \`$alt\` rules of its own.
860
+ def abnf-dispatches [cx name r]
861
+ abnf-some (filter (fn [alt] (abnf-starts (string-join "" [name "$alt"]) (abnf-target alt))) (abnf-open r))
862
+
863
+ ; A loop's item: what its continue alternate takes, a token it consumes,
864
+ ; or the rule its iteration (\`<loop>$alt0\`) pushes.
865
+ def abnf-loop-item [cx name r]
866
+ let [conts (filter (fn [alt] (abnf-full (abnf-r alt))) (abnf-rest (abnf-open r)))]
867
+ match (count conts)
868
+ case 0 (abnf-fail (string-join "" ["the repetition " name " repeats nothing"]))
869
+ case _
870
+ let [c (abnf-at conts 0)]
871
+ match (abnf-same (abnf-r c) name)
872
+ case true
873
+ match (abnf-consumed c)
874
+ case [t] (abnf-tok-el t)
875
+ case _ (abnf-fail (string-join "" ["the repetition " name " repeats more than one token"]))
876
+ case false
877
+ match (abnf-p (abnf-at (abnf-open (abnf-rule cx (abnf-r c))) 0))
878
+ case "" (abnf-fail (string-join "" ["the repetition " name " repeats nothing"]))
879
+ case item (abnf-ref-el item)
880
+
881
+ ; A tail repeat, \`X = prefix [ sep X ]\`, which the compiler makes a loop
882
+ ; in the rule's close: the separator matched and the rule replaced.
883
+ def abnf-is-tail [name r]
884
+ match (count (abnf-close r))
885
+ case 2
886
+ let [c (abnf-at (abnf-close r) 0)]
887
+ match (abnf-a c)
888
+ case "@fold$" (abnf-same (abnf-r c) name)
889
+ case _ false
890
+ case _ false
891
+
892
+ ; The alternatives of a rule as the spec holds them, each a vector of
893
+ ; elements; a tail repeat as its prefix and the option around its
894
+ ; separator and itself.
895
+ def abnf-raw-alts [cx name]
896
+ let [r (abnf-rule cx name)]
897
+ match (abnf-is-tail name r)
898
+ case true
899
+ let [prefix (map abnf-tok-el (abnf-consumed (abnf-at (abnf-open r) 0)))]
900
+ let [sep (map abnf-tok-el (abnf-consumed (abnf-at (abnf-close r) 0)))]
901
+ vector
902
+ push
903
+ record
904
+ entry :k :tail
905
+ entry :seq (push (abnf-ref-el name) sep)
906
+ prefix
907
+ case false
908
+ match (abnf-dispatches cx name r)
909
+ case true (abnf-dispatch-alts cx name r)
910
+ case false
911
+ match (count (abnf-close r))
912
+ case 0 (abnf-simple-alts r)
913
+ case _
914
+ match (abnf-r (abnf-at (abnf-close r) 0))
915
+ case "" (abnf-simple-alts r)
916
+ case _ (vector (abnf-chain cx name))
917
+
918
+ ; ---- the compiler's helpers, read back
919
+
920
+ ; The kind of a helper the compiler named: \`_gen<n>_<kind>...\`.
921
+ def abnf-helper-kind [cx name]
922
+ match (abnf-made cx name)
923
+ case false ""
924
+ case true
925
+ match (abnf-starts "_gen" name)
926
+ case true
927
+ let [parts (split "_" (abnf-after "_gen" name))]
928
+ match (abnf-digits (abnf-at parts 0))
929
+ case true (abnf-at parts 1)
930
+ case false ""
931
+ case false
932
+ match (abnf-among "fact" (map (fn [p] (abnf-before-digits p)) (abnf-rest (split "$" name))))
933
+ case true "fact"
934
+ case false ""
935
+
936
+ def abnf-before-digits [p]
937
+ match (abnf-starts "fact" p)
938
+ case true (match (abnf-digits (abnf-after "fact" p)) (case true "fact") (case false p))
939
+ case false p
940
+
941
+ ; An alternative with its factored tails expanded back: one whose last
942
+ ; element is a left-factored tail (\`<rule>$fact<k>\`) is the prefix before
943
+ ; it followed by each of the tail's alternatives in turn.
944
+ def abnf-expand [self cx alt]
945
+ match (count alt)
946
+ case 0 [alt]
947
+ case _
948
+ let [last (top alt)]
949
+ match (get :k last)
950
+ case :ref
951
+ match (abnf-helper-kind cx (get :name last))
952
+ case "fact"
953
+ let [prefix (pop alt)]
954
+ abnf-flat (map (fn [tail] (self self cx (abnf-cat prefix tail))) (abnf-raw-alts cx (get :name last)))
955
+ case _ [alt]
956
+ case _ [alt]
957
+
958
+ def abnf-alts [cx name]
959
+ 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))))
960
+
961
+ ; The compiler factors a rule's alternatives that are each one group
962
+ ; (\`( A x ) | ( A y )\`) into the first group, whose sequence then ends in
963
+ ; the rule's own factored tail (\`<rule>$fact<k>\`); such an alternative is
964
+ ; read back as the groups it was, one alternative each.
965
+ def abnf-split-group [cx name alt]
966
+ match (count alt)
967
+ case 1
968
+ let [el (abnf-at alt 0)]
969
+ match (get :k el)
970
+ case :ref
971
+ match (abnf-helper-kind cx (get :name el))
972
+ case "group"
973
+ let [inner (abnf-raw-alts cx (get :name el))]
974
+ match (count inner)
975
+ case 1
976
+ let [seq (abnf-at inner 0)]
977
+ match (abnf-owned-fact cx name seq)
978
+ case true (map (fn [one] [(abnf-grp-el one)]) (abnf-expand abnf-expand cx seq))
979
+ case false [alt]
980
+ case _ [alt]
981
+ case _ [alt]
982
+ case _ [alt]
983
+ case _ [alt]
984
+
985
+ def abnf-owned-fact [cx name seq]
986
+ match (count seq)
987
+ case 0 false
988
+ case _
989
+ let [last (top seq)]
990
+ match (get :k last)
991
+ case :ref
992
+ match (abnf-helper-kind cx (get :name last))
993
+ case "fact" (abnf-starts (string-join "" [name "$fact"]) (get :name last))
994
+ case _ false
995
+ case _ false
996
+
997
+ ; A group read back from a factored alternative: an element of its own,
998
+ ; written as a group is.
999
+ def abnf-grp-el [seq]
1000
+ record
1001
+ entry :k :grp
1002
+ entry :seq seq
1003
+
1004
+ ; The parts a repetition counts: the item, how many at least, how many
1005
+ ; at most ("" for no bound). A bounded one ends in nested options, each
1006
+ ; over a group of the item and the next option, the innermost over the
1007
+ ; item alone: \`[ A [ A [ A ] ] ]\`. The compiler numbers them as it makes
1008
+ ; them, the innermost group first, under the number it gave the
1009
+ ; repetition: group n, option n+1 over it, group n+2, ..., so the
1010
+ ; outermost option's number says how deep they go.
1011
+ def abnf-gen-number [name]
1012
+ number (abnf-at (split "_" (abnf-after "_gen" name)) 0)
1013
+
1014
+ def abnf-rep-chain [cx rep opt]
1015
+ let [n (abnf-gen-number rep)]
1016
+ let [inner-name (string-join "" ["_gen" (abnf-num n) "_group"])]
1017
+ match (abnf-has cx inner-name)
1018
+ case false (abnf-fail (string-join "" ["the repetition " rep " is not numbered as the compiler numbers one"]))
1019
+ case true
1020
+ let [inner (abnf-raw-alts cx inner-name)]
1021
+ match (count (abnf-at inner 0))
1022
+ case 1
1023
+ let [span (count (filter (fn [j] (abnf-not (abnf-less j n))) (indices (abnf-ones (abnf-plus (abnf-gen-number opt) 1)))))]
1024
+ record
1025
+ entry :item (abnf-at (abnf-at inner 0) 0)
1026
+ entry :depth (count (filter abnf-even (indices (abnf-ones span))))
1027
+ case _ (abnf-fail (string-join "" ["the repetition " rep " is not numbered as the compiler numbers one"]))
1028
+
1029
+ def abnf-rep-parts [cx name]
1030
+ let [seq (abnf-at (abnf-raw-alts cx name) 0)]
1031
+ 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)))]
1032
+ let [lead (pop seq)]
1033
+ match (abnf-helper-kind cx (abnf-str (get :name last)))
1034
+ case "star"
1035
+ record
1036
+ entry :item (abnf-loop-item cx (get :name last) (abnf-rule cx (get :name last)))
1037
+ entry :min (count lead)
1038
+ entry :max ""
1039
+ case "opt"
1040
+ let [chain (abnf-rep-chain cx name (get :name last))]
1041
+ record
1042
+ entry :item (get :item chain)
1043
+ entry :min (count lead)
1044
+ entry :max (abnf-num (abnf-plus (count lead) (get :depth chain)))
1045
+ case _
1046
+ record
1047
+ entry :item (abnf-at seq 0)
1048
+ entry :min (count seq)
1049
+ entry :max (abnf-num (count seq))
1050
+
1051
+ ; Whether an option is over a group.
1052
+ def abnf-opt-group [cx name]
1053
+ let [alts (abnf-raw-alts cx name)]
1054
+ let [inner (abnf-at (abnf-filled alts) 0)]
1055
+ match (get :k inner)
1056
+ case :ref (abnf-same (abnf-helper-kind cx (get :name inner)) "group")
1057
+ case _ false
1058
+
1059
+ ; An element's structure as one string, a helper by what it compiles (a
1060
+ ; counted repetition by its item and counts, not by the nested options
1061
+ ; it compiles to, which are as deep as its count).
1062
+ def abnf-key [self cx el]
1063
+ match (get :k el)
1064
+ case :tok (get :name el)
1065
+ case :tail "[tail]"
1066
+ case :grp (string-join "" ["group(" (abnf-key-seq self cx (get :seq el)) ")"])
1067
+ case :ref
1068
+ let [name (get :name el)]
1069
+ match (abnf-helper-kind cx name)
1070
+ case "" (string-join "" ["@" name])
1071
+ case "star" (string-join "" ["*(" (self self cx (abnf-loop-item cx name (abnf-rule cx name))) ")"])
1072
+ case "rep"
1073
+ let [parts (abnf-rep-parts cx name)]
1074
+ string-join "" ["rep(" (abnf-num (get :min parts)) "," (get :max parts) "," (self self cx (get :item parts)) ")"]
1075
+ case kind (string-join "" [kind "(" (string-join "|" (map (fn [seq] (abnf-key-seq self cx seq)) (abnf-alts cx name))) ")"])
1076
+
1077
+ def abnf-key-seq [self cx seq]
1078
+ string-join " " (map (fn [e] (self self cx e)) seq)
1079
+
1080
+ def abnf-seq-keys [cx seq]
1081
+ map (fn [el] (abnf-key abnf-key cx el)) seq
1082
+
1083
+ ; ---- characters
1084
+
1085
+ ; A literal's characters as their code points, which a notation writes
1086
+ ; where a quoted string cannot hold a character, and the names the
1087
+ ; compiler derives from a literal's text.
1088
+
1089
+ ; The ASCII characters, each with its two hexadecimal digits.
1090
+ 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"]]
1091
+
1092
+ ; A piece of a literal's text: a run of its characters (\`:raw\`), or one
1093
+ ; character as its code point (\`:cp\`). A run is cut at each place it
1094
+ ; holds a character, which is put back as its code point between the
1095
+ ; pieces, and the empty runs are left out.
1096
+ def abnf-raw-seg [s]
1097
+ record
1098
+ entry :raw s
1099
+
1100
+ def abnf-cp-seg [h]
1101
+ record
1102
+ entry :cp h
1103
+
1104
+ def abnf-cut-seg [c h seg]
1105
+ match (kind (get :raw seg))
1106
+ case :string
1107
+ let [pieces (split c (get :raw seg))]
1108
+ 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))
1109
+ case _ [seg]
1110
+
1111
+ ; A string's pieces with each of the characters given cut out as its code
1112
+ ; point, in turn.
1113
+ def abnf-code-walk [self chars segs]
1114
+ match (count chars)
1115
+ case 0 segs
1116
+ case _
1117
+ let [ch (top chars)]
1118
+ 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)))
1119
+
1120
+ def abnf-kept-seg [seg]
1121
+ match (get :raw seg)
1122
+ case "" false
1123
+ case _ true
1124
+
1125
+ ; A literal's characters as their code points, in order: its ASCII
1126
+ ; characters cut out first, then each run of other characters taken
1127
+ ; apart.
1128
+ def abnf-codes [text]
1129
+ let [present (filter (fn [ch] (abnf-some (abnf-rest (split (abnf-at ch 0) text)))) abnf-ascii)]
1130
+ let [segs (abnf-code-walk abnf-code-walk present [(abnf-raw-seg text)])]
1131
+ abnf-flat (map (fn [seg] (abnf-wide-codes text seg)) segs)
1132
+
1133
+ ; The sixteen hexadecimal digits, and the 256 pairs of them.
1134
+ def abnf-hex-digits ["0" "1" "2" "3" "4" "5" "6" "7" "8" "9" "A" "B" "C" "D" "E" "F"]
1135
+
1136
+ def abnf-hex-pairs
1137
+ abnf-flat (map (fn [a] (map (fn [b] (string-join "" [a b])) abnf-hex-digits)) abnf-hex-digits)
1138
+
1139
+ ; The start of each block of 256 code points in the Basic Multilingual
1140
+ ; Plane, by which a character past ASCII is found.
1141
+ 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]
1142
+
1143
+ ; A piece of a literal that holds no ASCII character: characters of the
1144
+ ; Basic Multilingual Plane, each as its code point, in order. The run is
1145
+ ; cut at each character it holds, found a block of 256 at a time: the
1146
+ ; block of its least character is the last whose start that character is
1147
+ ; not below, the characters of that block the run holds are the escapes
1148
+ ; there it holds, and the rest of the run is taken the same way.
1149
+ def abnf-wide-codes [text seg]
1150
+ match (kind (get :raw seg))
1151
+ case :string
1152
+ let [raw (get :raw seg)]
1153
+ match (chars-within [[128 55295] [57344 65535]] raw)
1154
+ 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"]))
1155
+ case true
1156
+ let [found (abnf-wide-chars abnf-wide-chars text raw [])]
1157
+ map (fn [piece] (get :cp piece)) (abnf-code-walk abnf-code-walk found [(abnf-raw-seg raw)])
1158
+ case _ [(get :cp seg)]
1159
+
1160
+ def abnf-wide-chars [self text run acc]
1161
+ match run
1162
+ case "" acc
1163
+ case _
1164
+ let [b (top (filter (fn [i] (chars-within [[(abnf-at abnf-blocks i) 65535]] run)) (indices abnf-blocks)))]
1165
+ let [hh (abnf-at abnf-hex-pairs b)]
1166
+ 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))]
1167
+ match (count found)
1168
+ case 0 (abnf-fail (string-join "" ["the literal " (quoted text) " holds a character the render cannot spell"]))
1169
+ case _ (self self text (abnf-strip-chars abnf-strip-chars found run) (abnf-cat acc found))
1170
+
1171
+ ; A code point's digits as ABNF writes them, without leading zeros.
1172
+ def abnf-point-hex [hh l]
1173
+ match hh
1174
+ case "00" l
1175
+ case _
1176
+ match (abnf-starts "0" hh)
1177
+ case true (string-join "" [(abnf-after "0" hh) l])
1178
+ case false (string-join "" [hh l])
1179
+
1180
+ def abnf-strip-chars [self chars s]
1181
+ match (count chars)
1182
+ case 0 s
1183
+ case _ (self self (pop chars) (string-join "" (split (abnf-at (top chars) 0) s)))
1184
+
1185
+ def abnf-has-letter [text]
1186
+ abnf-not (chars-within [[0 64] [91 96] [123 1114111]] text)
1187
+
1188
+ ; ---- token names
1189
+
1190
+ ; The name the compiler derives for a literal's token: the text in
1191
+ ; capitals, each character that is not a letter or a digit an underscore,
1192
+ ; the underscores at either end taken off, \`T\` when nothing is left, and a
1193
+ ; number after it when the name is taken. A token with any other name is a
1194
+ ; rule the compiler lifted to a token.
1195
+ 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"]]
1196
+
1197
+ def abnf-swap-walk [self pairs s]
1198
+ match (count pairs)
1199
+ case 0 s
1200
+ case _
1201
+ let [pair (top pairs)]
1202
+ self self (pop pairs) (string-join (abnf-at pair 1) (split (abnf-at pair 0) s))
1203
+
1204
+ def abnf-word-chars [[48 57] [65 90] [97 122]]
1205
+
1206
+ def abnf-base-name [text]
1207
+ let [up (abnf-swap-walk abnf-swap-walk abnf-upper-pairs text)]
1208
+ let [others (filter (fn [ch] (abnf-not (chars-within abnf-word-chars (abnf-at ch 0)))) abnf-ascii)]
1209
+ let [under (abnf-swap-walk abnf-swap-walk (map (fn [ch] [(abnf-at ch 0) "_"]) others) up)]
1210
+ let [pieces (split "_" under)]
1211
+ let [full (filter (fn [i] (abnf-full (abnf-at pieces i))) (indices pieces))]
1212
+ match (count full)
1213
+ case 0 "T"
1214
+ case _
1215
+ let [lo (abnf-at full 0)]
1216
+ let [hi (top full)]
1217
+ 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)))
1218
+
1219
+ def abnf-derived [bare text]
1220
+ match (chars-within [[48 57] [65 90] [95 95]] bare)
1221
+ case false false
1222
+ case true
1223
+ match (chars-within [[0 127]] text)
1224
+ case false true
1225
+ case true
1226
+ let [base (abnf-base-name text)]
1227
+ match (abnf-same bare base)
1228
+ case true true
1229
+ case false
1230
+ match (abnf-starts base bare)
1231
+ case true (abnf-digits (abnf-after base bare))
1232
+ case false false
1233
+
1234
+ ; Every token name the alternates match, one string.
1235
+ def abnf-used [cx]
1236
+ let [rules (get :rules cx)]
1237
+ string-join ""
1238
+ vector
1239
+ " "
1240
+ string-join " "
1241
+ map
1242
+ fn [name]
1243
+ let [r (get-path (as-path [name]) rules)]
1244
+ string-join " " (abnf-flat (map abnf-s (abnf-cat (abnf-open r) (abnf-close r))))
1245
+ keys rules
1246
+ " "
1247
+
1248
+ ; ---- references written back
1249
+
1250
+ ; The compiler substitutes a reference that leads an alternative by the
1251
+ ; referenced rule's alternatives, each followed by what followed the
1252
+ ; reference (\`a = b "x"\`, \`b = "y" / "z"\` compiles \`a\` as \`"y" "x" / "z"
1253
+ ; "x"\`), and compiles the reference back to the same alternatives. So
1254
+ ; where a run of a rule's alternatives is another rule's alternatives,
1255
+ ; each followed by one same tail, the reference is written back in their
1256
+ ; place. A candidate is a rule the written file can name, with its
1257
+ ; alternatives' keys; a rule that is one reference (\`a = b\`) is none,
1258
+ ; since the compiler leaves such a rule a reference rather than
1259
+ ; substituting it.
1260
+ def abnf-candidates [cx names]
1261
+ filter
1262
+ fn [c] (abnf-not (abnf-alias-keys (get :keys c)))
1263
+ map (fn [n] (record (entry :name n) (entry :keys (map (fn [seq] (abnf-seq-keys cx seq)) (abnf-alts cx n))))) names
1264
+
1265
+ def abnf-alias-keys [ks]
1266
+ match (count ks)
1267
+ case 1
1268
+ match (count (abnf-at ks 0))
1269
+ case 1 (abnf-starts "@" (abnf-at (abnf-at ks 0) 0))
1270
+ case _ false
1271
+ case _ false
1272
+
1273
+ ; Whether alternatives are one alternative of one reference to a rule:
1274
+ ; a rule the compiler leaves as it is.
1275
+ def abnf-alias [cx alts]
1276
+ match (count alts)
1277
+ case 1
1278
+ let [seq (abnf-at alts 0)]
1279
+ match (count seq)
1280
+ case 1
1281
+ match (get :k (abnf-at seq 0))
1282
+ case :ref (abnf-empty (abnf-helper-kind cx (get :name (abnf-at seq 0))))
1283
+ case _ false
1284
+ case _ false
1285
+ case _ false
1286
+
1287
+ ; Whether the alternative's keys begin with the candidate alternative's,
1288
+ ; and what follows them ("\\u0000" where they do not).
1289
+ def abnf-prefix-tail [ks cs]
1290
+ match (abnf-less (count ks) (count cs))
1291
+ case true "\\u0000"
1292
+ case false
1293
+ match (abnf-same (string-join "\\u0001" (abnf-take (count cs) ks)) (string-join "\\u0001" cs))
1294
+ case true (string-join "\\u0001" (abnf-drop (count cs) ks))
1295
+ case false "\\u0000"
1296
+
1297
+ ; Whether the candidate's alternatives, each followed by one same tail,
1298
+ ; are the alternatives from position i on.
1299
+ def abnf-cand-matches [c ka i]
1300
+ let [k (count (get :keys c))]
1301
+ match (abnf-less (count ka) (abnf-plus i k))
1302
+ case true false
1303
+ case false
1304
+ let [first (abnf-prefix-tail (abnf-at ka i) (abnf-at (get :keys c) 0))]
1305
+ match first
1306
+ case "\\u0000" false
1307
+ 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))))
1308
+
1309
+ ; The candidate, other than the rule itself, whose alternatives stand at
1310
+ ; position i: where several do, the one with the most alternatives, and
1311
+ ; among those the one the spec defines first. The spec cannot tell \`a = b
1312
+ ; ";"\` with \`b = c "("\` from \`a = c "(" ";"\`, nor a reference from two
1313
+ ; rules that begin alike by chance; a grammar written from the top down
1314
+ ; defines the rule an author named before the ones it is made of.
1315
+ def abnf-cand-at [cands ka i self]
1316
+ let [hits (filter (fn [c] (match (abnf-same (get :name c) self) (case true false) (case false (abnf-cand-matches c ka i)))) cands)]
1317
+ let [most (filter (fn [c] (abnf-none (filter (fn [d] (abnf-less (count (get :keys c)) (count (get :keys d)))) hits))) hits)]
1318
+ match (count most)
1319
+ case 0 null
1320
+ case _ (abnf-at most 0)
1321
+
1322
+ ; A rule's alternatives with the references written back: each run a
1323
+ ; candidate covers, from the first position one stands at that no other
1324
+ ; run covers, written as the reference and the tail; the alternatives
1325
+ ; as they are where no run is found, and where writing one back would
1326
+ ; leave the rule one reference, which the compiler would not substitute.
1327
+ def abnf-unsub [cx cands self alts]
1328
+ match (count cands)
1329
+ case 0 alts
1330
+ case _
1331
+ let [ka (map (fn [seq] (abnf-seq-keys cx seq)) alts)]
1332
+ let [best (map (fn [i] (abnf-cand-at cands ka i self)) (indices alts))]
1333
+ 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)))]
1334
+ 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))]
1335
+ let [out (abnf-flat (map (fn [i] (abnf-unsub-at cx alts best accepted covers i)) (indices alts)))]
1336
+ match (abnf-alias cx out)
1337
+ case true alts
1338
+ case false out
1339
+
1340
+ def abnf-unsub-at [cx alts best accepted covers i]
1341
+ match (abnf-at accepted i)
1342
+ case true
1343
+ let [c (abnf-at best i)]
1344
+ vector (abnf-cat [(abnf-ref-el (get :name c))] (abnf-drop (count (abnf-at (get :keys c) 0)) (abnf-at alts i)))
1345
+ case false
1346
+ match (abnf-some (filter (fn [j] (match (abnf-at accepted j) (case true (covers j i)) (case false false))) (indices alts)))
1347
+ case true []
1348
+ case false [(abnf-at alts i)]
1349
+
1350
+ ; ---- ABNF's terminals
1351
+
1352
+ ; A literal: a quoted string where it can hold the text (\`%s\` before it
1353
+ ; when the match is exact and the text holds a letter), and otherwise a
1354
+ ; numeric value, \`%x\` and each character's code point, which ABNF reads
1355
+ ; as a case-insensitive string.
1356
+ def abnf-lit-text [text cs]
1357
+ match text
1358
+ case "" "\\"\\""
1359
+ case _
1360
+ match (chars-within [[32 33] [35 126]] text)
1361
+ case true
1362
+ match cs
1363
+ case true
1364
+ match (abnf-has-letter text)
1365
+ case true (string-join "" ["%s\\"" text "\\""])
1366
+ case false (string-join "" ["\\"" text "\\""])
1367
+ case false (string-join "" ["\\"" text "\\""])
1368
+ case false
1369
+ match cs
1370
+ case true
1371
+ match (abnf-has-letter text)
1372
+ 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"]))
1373
+ case false (string-join "" ["%x" (string-join "." (abnf-codes text))])
1374
+ case false (string-join "" ["%x" (string-join "." (abnf-codes text))])
1375
+
1376
+ ; A code point of a class's pattern, \`\\uXXXX\` or \`\\u{X...}\`, as ABNF's
1377
+ ; hexadecimal digits.
1378
+ def abnf-escape-hex [e]
1379
+ match (abnf-starts "\\\\u" e)
1380
+ case false ""
1381
+ case true
1382
+ let [h (abnf-after "\\\\u" e)]
1383
+ match (abnf-starts "{" h)
1384
+ case true (abnf-hex-upper (abnf-before "}" (abnf-after "{" h)))
1385
+ case false
1386
+ match (abnf-starts "00" h)
1387
+ case true (abnf-hex-upper (abnf-after "00" h))
1388
+ case false (abnf-hex-upper h)
1389
+
1390
+ ; A class: one range as \`%x<lo>-<hi>\`, the only class ABNF writes; a
1391
+ ; class of several members, which another notation writes, as the
1392
+ ; alternation of its members, each range a range and each character a
1393
+ ; string that matches it exactly, or a range of one where a string cannot
1394
+ ; hold it. A negated class has no ABNF form.
1395
+ def abnf-class-text [pat flags]
1396
+ let [body (abnf-before "]" (abnf-after "[" pat))]
1397
+ match (abnf-starts "^" body)
1398
+ case true (abnf-fail (string-join "" ["the class " pat " is negated, which ABNF has no form for"]))
1399
+ case false
1400
+ let [members (abnf-class-members body)]
1401
+ match (abnf-none (filter (fn [m] (abnf-empty (get :lo m))) members))
1402
+ case false (abnf-fail (string-join "" ["the class " pat " is not a range ABNF writes"]))
1403
+ case true
1404
+ match (count members)
1405
+ case 0 (abnf-fail (string-join "" ["the class " pat " is empty"]))
1406
+ case 1 (abnf-member-text pat (abnf-at members 0))
1407
+ case _ (string-join "" ["( " (string-join " / " (map (fn [m] (abnf-member-text pat m)) members)) " )"])
1408
+
1409
+ ; A class's members, each \`\\uXXXX\` or \`\\u{X...}\` alone or the low end of a
1410
+ ; range: its digits and its high end's, ABNF's hexadecimal digits.
1411
+ def abnf-class-members [body]
1412
+ let [pieces (abnf-rest (split "\\\\u" body))]
1413
+ let [prev (abnf-cat [""] pieces)]
1414
+ map
1415
+ fn [i]
1416
+ let [piece (abnf-at pieces i)]
1417
+ match (abnf-ends "-" piece)
1418
+ case true
1419
+ record
1420
+ entry :lo (abnf-escape-hex (string-join "" ["\\\\u" (abnf-before "-" piece)]))
1421
+ entry :hi (abnf-escape-hex (string-join "" ["\\\\u" (abnf-str (abnf-at pieces (abnf-plus i 1)))]))
1422
+ case false
1423
+ record
1424
+ entry :lo (abnf-escape-hex (string-join "" ["\\\\u" piece]))
1425
+ entry :hi (abnf-escape-hex (string-join "" ["\\\\u" piece]))
1426
+ filter (fn [i] (abnf-not (abnf-ends "-" (abnf-at prev i)))) (indices pieces)
1427
+
1428
+ ; A member: a range as a range; a character as a string that matches it
1429
+ ; exactly where a string can hold it, and otherwise, below U+0080, as a
1430
+ ; range of one, which the compiler reads as that character. A character
1431
+ ; past ASCII that no string holds is refused, since a range of one is read
1432
+ ; without regard to case.
1433
+ def abnf-member-text [pat m]
1434
+ match (abnf-same (get :lo m) (get :hi m))
1435
+ case false (string-join "" ["%x" (get :lo m) "-" (get :hi m)])
1436
+ case true
1437
+ let [h (get :lo m)]
1438
+ let [h4 (string-join "" [(match (length h) (case 1 "000") (case 2 "00") (case 3 "0") (case _ "")) (abnf-hex-lower h)])]
1439
+ match (abnf-ascii-code h4)
1440
+ 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"]))
1441
+ case true
1442
+ let [c (unquoted (string-join "" ["\\"\\\\u" h4 "\\""]))]
1443
+ match (chars-within [[32 33] [35 126]] c)
1444
+ case true (abnf-lit-text c true)
1445
+ case false (string-join "" ["%x" h "-" h])
1446
+
1447
+ ; Whether four hexadecimal digits name an ASCII character.
1448
+ def abnf-ascii-code [h4]
1449
+ match (abnf-starts "00" h4)
1450
+ case false false
1451
+ case true (abnf-some (filter (fn [d] (abnf-starts d (abnf-after "00" h4))) ["0" "1" "2" "3" "4" "5" "6" "7"]))
1452
+
1453
+ ; ---- ABNF's elements
1454
+
1455
+ ; Alternatives' text without the space an empty first or last one leaves
1456
+ ; at either end (\`a = / "x"\`).
1457
+ def abnf-trim-ends [t]
1458
+ let [lead (match (abnf-starts " " t) (case true (abnf-after " " t)) (case false t))]
1459
+ match (abnf-ends " " lead)
1460
+ case true (abnf-before " " lead)
1461
+ case false lead
1462
+
1463
+ ; A rule name ABNF can spell: a letter, then letters, digits and hyphens.
1464
+ def abnf-legal-name [name]
1465
+ match name
1466
+ case "" false
1467
+ case _
1468
+ match (chars-within [[45 45] [48 57] [65 90] [97 122]] name)
1469
+ case false false
1470
+ case true
1471
+ match (abnf-starts "-" name)
1472
+ case true false
1473
+ case false (abnf-none (filter (fn [d] (abnf-starts d name)) ["0" "1" "2" "3" "4" "5" "6" "7" "8" "9"]))
1474
+
1475
+ def abnf-ref-text [name]
1476
+ match (abnf-legal-name name)
1477
+ case true name
1478
+ case false (abnf-fail (string-join "" ["the rule " (quoted name) " has a name ABNF cannot spell"]))
1479
+
1480
+ ; Whether a token is a rule the compiler lifted: a literal's token whose
1481
+ ; name is not the one the literal gives it, or that nothing references.
1482
+ def abnf-lifted [cx used t]
1483
+ let [info (abnf-token cx t)]
1484
+ match (get :k info)
1485
+ case :lit
1486
+ match (abnf-legal-name (abnf-bare t))
1487
+ case false false
1488
+ case true
1489
+ match (abnf-derived (abnf-bare t) (get :text info))
1490
+ case false true
1491
+ case true (abnf-not (abnf-some (abnf-rest (split (string-join "" [" " t " "]) used))))
1492
+ case _ false
1493
+
1494
+ def abnf-token-text [cx lifted t]
1495
+ match (abnf-among t lifted)
1496
+ case true (abnf-bare t)
1497
+ case false
1498
+ let [info (abnf-token cx t)]
1499
+ match (get :k info)
1500
+ case :lit (abnf-lit-text (get :text info) (get :cs info))
1501
+ case :class (abnf-class-text (get :pat info) (get :flags info))
1502
+ case :engine (get :name info)
1503
+
1504
+ def abnf-rep-text [self cx lifted name]
1505
+ let [parts (abnf-rep-parts cx name)]
1506
+ let [min (abnf-num (get :min parts))]
1507
+ 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])))))]
1508
+ string-join "" [count-text (self self cx lifted :atom (get :item parts))]
1509
+
1510
+ ; The element a repetition applies to: a terminal, a rule, a group or an
1511
+ ; option; any other construct is put in a group of its own.
1512
+ def abnf-atom-text [self cx lifted el]
1513
+ match (get :k el)
1514
+ case :tok (abnf-token-text cx lifted (get :name el))
1515
+ case :grp (self self cx lifted :el el)
1516
+ case :ref
1517
+ match (abnf-helper-kind cx (get :name el))
1518
+ case "group" (self self cx lifted :el el)
1519
+ case "opt"
1520
+ match (abnf-opt-group cx (get :name el))
1521
+ case true (self self cx lifted :el el)
1522
+ case false (string-join "" ["( " (self self cx lifted :el el) " )"])
1523
+ case "" (self self cx lifted :el el)
1524
+ case _ (string-join "" ["( " (self self cx lifted :el el) " )"])
1525
+ case _ (string-join "" ["( " (self self cx lifted :el el) " )"])
1526
+
1527
+ def abnf-el-text [self cx lifted el]
1528
+ match (get :k el)
1529
+ case :tok (abnf-token-text cx lifted (get :name el))
1530
+ case :tail (string-join "" ["[ " (self self cx lifted :alts [(get :seq el)]) " ]"])
1531
+ case :grp (string-join "" ["( " (self self cx lifted :alts [(get :seq el)]) " )"])
1532
+ case :ref
1533
+ let [name (get :name el)]
1534
+ match (abnf-helper-kind cx name)
1535
+ case "" (abnf-ref-text name)
1536
+ case "star" (string-join "" ["*" (self self cx lifted :atom (abnf-loop-item cx name (abnf-rule cx name)))])
1537
+ case "plus"
1538
+ let [seq (abnf-at (abnf-alts cx name) 0)]
1539
+ string-join "" ["1*" (self self cx lifted :atom (abnf-at seq 0))]
1540
+ case "opt"
1541
+ let [inner (abnf-at (abnf-filled (abnf-alts cx name)) 0)]
1542
+ match (abnf-opt-group cx name)
1543
+ case true (string-join "" ["[ " (self self cx lifted :alts (abnf-alts cx (get :name inner))) " ]"])
1544
+ case false (string-join "" ["0*1" (self self cx lifted :atom inner)])
1545
+ case "rep" (abnf-rep-text self cx lifted name)
1546
+ case "group" (string-join "" ["( " (self self cx lifted :alts (abnf-alts cx name)) " )"])
1547
+ case kind (abnf-fail (string-join "" ["the rule " name " is a helper of a kind the render does not read (" kind ")"]))
1548
+
1549
+ def abnf-seq-text [self cx lifted seq]
1550
+ string-join " " (map (fn [el] (self self cx lifted :el el)) seq)
1551
+
1552
+ ; The text of a rule's or a group's alternatives (\`:alts\`, ABNF's \`/\`
1553
+ ; between them), of an element (\`:el\`) and of the element a repetition
1554
+ ; applies to (\`:atom\`): the one function the render recurses through, as
1555
+ ; \`self\`, a helper's alternatives a level deeper.
1556
+ def abnf-text [self cx lifted mode x]
1557
+ match mode
1558
+ case :alts (abnf-trim-ends (string-join " / " (map (fn [seq] (abnf-seq-text self cx lifted seq)) x)))
1559
+ case :el (abnf-el-text self cx lifted x)
1560
+ case :atom (abnf-atom-text self cx lifted x)
1561
+
1562
+ ; ---- core rules
1563
+
1564
+ ; The RFC 5234 core rules, in the order the compiler adds them: a pass
1565
+ ; over them in this order adds every one the grammar references, and
1566
+ ; another pass every one those reference, until none is missing. So the
1567
+ ; core rules a spec holds, in its order, rise through this list for the
1568
+ ; ones the grammar itself referenced, and fall back at the first the core
1569
+ ; rules referenced instead.
1570
+ def abnf-core-order ["ALPHA" "BIT" "CHAR" "CR" "LF" "CRLF" "CTL" "DIGIT" "DQUOTE" "HEXDIG" "HTAB" "OCTET" "SP" "VCHAR" "WSP" "LWSP"]
1571
+
1572
+ def abnf-core-index [name]
1573
+ let [found (filter (fn [i] (abnf-same (abnf-at abnf-core-order i) name)) (indices abnf-core-order))]
1574
+ match (count found)
1575
+ case 0 99
1576
+ case _ (abnf-at found 0)
1577
+
1578
+ ; The core rules the grammar referenced itself: the ones a written rule
1579
+ ; can name, which the compiler adds again.
1580
+ def abnf-direct-core [cx]
1581
+ 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)))]
1582
+ let [idx (map abnf-core-index core)]
1583
+ let [prev (abnf-cat [-1] idx)]
1584
+ let [falls (filter (fn [i] (abnf-less (abnf-at idx i) (abnf-at prev i))) (indices idx))]
1585
+ match (count falls)
1586
+ case 0 core
1587
+ case _ (abnf-take (abnf-at falls 0) core)
1588
+
1589
+ ; ---- the file
1590
+
1591
+ def abnf-production [cx cands lifted name]
1592
+ string-join "" [(abnf-ref-text name) " = " (abnf-text abnf-text cx lifted :alts (abnf-unsub cx cands name (abnf-alts cx name)))]
1593
+
1594
+ def abnf-lifted-production [cx t]
1595
+ let [info (abnf-token cx t)]
1596
+ string-join "" [(abnf-ref-text (abnf-bare t)) " = " (abnf-lit-text (get :text info) (get :cs info))]
1597
+
1598
+ def abnf-start-rule [cx]
1599
+ abnf-p (abnf-at (abnf-open (abnf-rule cx (get :start cx))) 0)
1600
+
1601
+ def abnf-file [spec]
1602
+ let [cx (abnf-context spec)]
1603
+ let [checked (abnf-check spec cx)]
1604
+ 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)))]
1605
+ let [start (abnf-start-rule cx)]
1606
+ let [ordered (abnf-cat [start] (filter (fn [n] (abnf-not (abnf-same n start))) names))]
1607
+ let [used (abnf-used cx)]
1608
+ let [tokens (abnf-cat (keys (get :fixed cx)) (keys (get :match cx)))]
1609
+ let [lifted (filter (fn [t] (abnf-lifted cx used t)) tokens)]
1610
+ let [cands (abnf-candidates cx (abnf-cat ordered (abnf-direct-core cx)))]
1611
+ string-join ""
1612
+ vector
1613
+ string-join "\\n" (abnf-cat (map (fn [n] (abnf-production cx cands lifted n)) ordered) (map (fn [t] (abnf-lifted-production cx t)) lifted))
1614
+ "\\n"
1615
+
1616
+ def abnf-render [input]
1617
+ concat-map abnf-file (select root input)
1618
+ ` })
1619
+ })
1620
+
1621
+ function translate (): TranslationParts | undefined {
1622
+ return TRANSLATION
1623
+ }
1624
+
1625
+ export {
1626
+ translate,
1627
+ }
1628
+
1629
+ export type {
1630
+ TranslationPart,
1631
+ TranslationParts,
1632
+ }