source: project/release/4/abnf/tags/7.0/abnf.scm @ 30863

Last change on this file since 30863 was 30863, checked in by Ivan Raikov, 6 years ago

abnf release 7.0

File size: 7.9 KB
Line 
1;;
2;;  Parser for the grammar defined in RFC4234, "Augmented BNF for
3;;  Syntax Specifications: ABNF".
4;;
5;;
6;;   Copyright 2009-2014 Ivan Raikov and the Okinawa Institute of Science
7;;   and Technology.
8;;
9;;
10;;   This program is free software: you can redistribute it and/or
11;;   modify it under the terms of the GNU General Public License as
12;;   published by the Free Software Foundation, either version 3 of
13;;   the License, or (at your option) any later version.
14;;
15;;   This program is distributed in the hope that it will be useful,
16;;   but WITHOUT ANY WARRANTY; without even the implied warranty of
17;;   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
18;;   General Public License for more details.
19;;
20;;   A full copy of the GPL license can be found at
21;;   <http://www.gnu.org/licenses/>.
22
23
24(module abnf 
25
26        (
27         (concatenation lex:seq) (alternatives lex:bar) 
28         variable-repetition repetition repetition1 repetition-n
29         optional-sequence 
30
31         pass drop-consumed bind bind*
32
33         ( :: lex:seq) :?  :!  :*  :+ 
34
35         <Input> make-<Input>         
36         <Token> <CharLex> Input->Token Token->CharLex 
37         <CoreABNF> CharLex->CoreABNF 
38
39         )
40
41   (import scheme chicken data-structures extras srfi-69)
42
43   (require-extension utf8 utf8-srfi-14 typeclass input-classes suffix-tree)
44
45   (require-library lexgen)
46   (import (only srfi-1 fold list-tabulate)
47           (prefix lexgen lex:))
48
49;; the following is necessary because type classes are currently not
50;; aware of module system prefixes
51   (import (only lexgen <Token> <CharLex> Input->Token Token->CharLex ))
52
53
54(define-class <CoreABNF> (<CharLex> L) 
55  range set set-from-string char lit alpha 
56  binary decimal hexadecimal ascii-char cr lf crlf ctl 
57  dquote htab lwsp octet sp vchar unicode-vchar wsp 
58  alternatives/prefix
59  :s :c )
60
61
62(define pass lex:pass)
63(define drop-consumed lex:drop)
64
65(define bind lex:bind)
66(define bind* lex:bind*)
67
68
69;;;; ABNF operators
70
71;; Concatenation (RFC 4234, Section 3.1)
72(define-syntax concatenation
73  (syntax-rules () 
74    ((_)     lex:pass)
75    ((_ a)    a)
76    ((_ a b)  (lex:seq a b))
77    ((concatenation a b ...) 
78     (lex:seq a (concatenation b ...)))
79    ))
80   
81;; Alternatives (RFC 4234, Section 3.2)
82(define-syntax alternatives
83  (syntax-rules () 
84    ((_)      lex:pass)
85    ((_ a)    a)
86    ((_ a b)  (lex:bar a b))
87    ((alternatives a b ...) 
88     (lex:bar a (alternatives b ...)))
89    ))
90
91;; Value range alternatives (RFC 4234, Section 3.4)
92;; (part of the CoreABNF typeclass)
93;;(define range lex:range)
94
95
96;;  Specific repetition (RFC 4234, Section 3.7)
97(define (repetition-n n p)
98  (let ((ps (list-tabulate n (lambda (i) p))))
99    (lex:lst ps)))
100
101;; Variable repetition (RFC 4234, Section 3.6)
102
103;; * repetition
104(define (repetition p)  (lex:star p))
105
106;; 1* repetition
107(define repetition1 lex:pos)
108
109(define (variable-repetition min max p)
110  (if (< max min) (variable-repetition max min p)
111      (let loop ((i (- max 1)) (k (+ min 1)) (r (if (positive? min) (repetition-n min p) lex:pass)))
112        (cond ((>= i min)  (loop (- i 1) (+ k 1) (lex:bar (repetition-n k p) r)))
113              (else r)))))
114
115               
116(define optional-sequence lex:opt)
117
118
119;;;; Terminal values (RFC 4234, Section 2.3)
120
121;; Matches a literal string (case-insensitive)
122
123(define=> (lit <CharLex>)
124  (lambda (s)
125    (let* ((f  (lambda (t) (tok t (lex:try char-ci=?))))
126           (ps (map f (if (string? s) (string->list s) s))))
127      (lex:lst ps))))
128
129;;;; Core Rules (RFC 4234, Appendix B)
130
131;; Match any character of the alphabet.
132(define=> (alpha <CharLex>)
133  (set char-set:letter))
134
135;; Match [0..1]
136(define=> (binary <CharLex>)
137  (range #\0 #\1))
138
139;; Match [0..9]
140(define=> (decimal <CharLex>)
141  (range #\0 #\9))
142
143;; Match [0..9] and [A..F,a..f]
144(define=> (hexadecimal <CharLex>)
145  (set char-set:hex-digit))
146
147;; Match any 7-bit US-ASCII character except for NUL (ASCII value 0, that is).
148
149(define=> (ascii-char <CharLex>)
150  (set (ucs-range->char-set 1 127)))
151
152;; Match the carriage return character \r.
153
154(define=> (cr <CharLex>) (char (integer->char 13)))
155
156;; Match the linefeed character \n.
157
158(define=> (lf <CharLex>) (char (integer->char 10)))
159
160;; Match the Internet newline \r\n.
161
162;; cr lf
163
164;; Match any US-ASCII control character. That is any character with a
165;; decimal value in the range of [0..31,127].
166
167(define=> (ctl <CharLex>) (set char-set:iso-control))
168
169;; Match the double quote character "
170
171(define=> (dquote <CharLex>) (char #\"))
172
173;; Match the tab \t character
174
175(define=> (htab <CharLex>) (char (integer->char 9)))
176
177;; Match either 'sp' or 'htab'.
178
179(define=> (wsp <CharLex>) (set (char-set #\space #\tab)))
180
181;; Match linear white space: *(WSP / CRLF WSP)
182
183;; (define=> (lwsp <CharLex>) (lex:star (lex:bar wsp (lex:seq (lex:drop crlf) wsp))))
184
185
186;; Match /any/ character.
187(define=> (octet <CharLex>)  (set char-set:full))
188
189;; Match the space character
190
191(define=> (sp <CharLex>) (char #\space))
192
193;; Match any printable ASCII character. (The "v" stands for
194;; "visible".) That is any character in the decimal range of
195;; [33..126].
196
197(define=> (vchar <CharLex>)  (set char-set:graphic))
198
199;; As vchar, but include Unicode characters
200(define=> (unicode-vchar <CharLex>)
201  (set (char-set-union 
202        char-set:graphic
203        (char-set-difference
204         char-set:full 
205         char-set:ascii))))
206                 
207;;;; Additional convenience procedures and parser combinators
208
209;; match any character from a set defined as a string
210(define=>  (set-from-string <CharLex>)
211  (lambda (s)
212    (set (string->char-set s))))
213
214;;
215;; A variant of alternatives optimized for parsing grammars with a
216;; large number of alternatives that are each prefixed by a constant
217;; string, e.g. email headers:
218;;
219;;  From: <mailbox parser>
220;;  To: <mailbox parser>
221;;  Subject: <text parser>
222;;  ...
223;;
224
225(define=> (alternatives/prefix <CharLex>)
226  (lambda (prefixes #!key 
227                    (default (lambda (sk fk strm) (fk strm))) 
228                    (char-bind #f)
229                    (join cons))
230
231    (let ((bind-proc (lambda (path eol) 
232                       (lex:bind (lambda (x) 
233                                   (join (char-bind path) (reverse x))) eol)))
234
235          (tr (fold (lambda (x t) (suffix-tree-insert (car x) (cdr x) t))
236                    (make-suffix-tree char<=? string->list)
237                    prefixes)))
238
239      (let recur ((branches (suffix-tree-branches tr)) 
240                  (p default)
241                  (path '()) )
242
243        (if (null? branches) p
244            (let ((branch (car branches)))
245              (let ((eol (suffix-tree-branch-eol branch))
246                    (label (suffix-tree-branch-label branch)))
247                (recur (cdr branches)
248                       (lex:bar (lex:seq (drop-consumed (char label))
249                                         (or (and eol (if char-bind (bind-proc (cons label path) eol) eol))
250                                             (recur
251                                              (suffix-tree-branch-children branch)
252                                              (lambda (sk fk strm) (fk strm))
253                                              (cons label path))
254                                             ))
255                                p)
256                       path
257                       ))
258              ))
259        ))
260    ))
261
262;;;; Type class constructor
263
264(define (CharLex->CoreABNF L)
265  (let* ((lit         (lit L))
266         (char        ((lambda=> (<CharLex>) char) L))
267         (range       ((lambda=> (<CharLex>) range) L))
268         (set         ((lambda=> (<CharLex>) set) L))
269         (alpha       (alpha L))
270         (binary      (binary L))
271         (decimal     (decimal L))
272         (hexadecimal (hexadecimal L))
273         (ascii-char  (ascii-char L))
274         (cr          (cr L))
275         (lf          (lf L))
276         (crlf        (lex:seq cr lf))
277         (ctl         (ctl L))
278         (dquote      (dquote L))
279         (htab        (htab L))
280         (wsp         (wsp L))
281         (lwsp        (lex:star (lex:bar wsp (lex:seq (lex:drop crlf) wsp))))
282         (octet       (octet L))
283         (sp          (sp L))
284         (vchar       (vchar L))
285         (unicode-vchar (unicode-vchar L))
286         (set-from-string  (set-from-string L))
287         (alternatives/prefix (alternatives/prefix L))
288         (:c          char)
289         (:s          lit)
290         )
291   
292
293  (make-<CoreABNF> L
294                   range set set-from-string char lit alpha 
295                   binary decimal hexadecimal ascii-char cr lf crlf ctl 
296                   dquote htab lwsp octet sp vchar unicode-vchar wsp 
297                   alternatives/prefix
298                   :s :c )
299  ))
300
301
302;;;; Syntactic abbreviations
303;;;; Based on a proposal by Moritz Heidkamp
304
305(define :? optional-sequence)
306(define :! drop-consumed)
307(define :* repetition)
308(define :+ repetition1)
309
310(define-syntax ::
311  (syntax-rules () ((_ e1 e2 ...) (concatenation e1 e2 ...))))
312
313)
Note: See TracBrowser for help on using the repository browser.