@tabnas/abnf 0.4.20 → 0.4.21

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