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