edward

  1;; parse.scm -- Parser Combinators
  2;; Copyright (c) 2013 Alex Shinn.  All rights reserved.
  3;; BSD-style license: http://synthcode.com/license.txt
  4
  5;;>| Parse Streams
  6;;>
  7;;> Parse streams are an abstraction to treat ports as proper streams
  8;;> so that we can backtrack from previous states.  A single
  9;;> Parse-Stream record represents a single buffered chunk of text.
 10
 11(define-record-type Parse-Stream
 12  (%make-parse-stream
 13   filename port buffer cache offset prev-char line column tail fk)
 14  parse-stream?
 15  ;; The file the data came from, for debugging and error reporting.
 16  (filename parse-stream-filename)
 17  ;; The underlying port.
 18  (port parse-stream-port)
 19  ;; A vector of characters read from the port.  We use a vector
 20  ;; rather than a string for guaranteed O(1) access.
 21  (buffer parse-stream-buffer)
 22  ;; A vector of caches corresponding to parser successes or failures
 23  ;; starting from the corresponding char.  Currently each cache is
 24  ;; just an alist, optimized under the assumption that the number of
 25  ;; possible memoized parsers is relatively small.  Note that
 26  ;; memoization is only enabled explicitly.
 27  (cache parse-stream-cache)
 28  ;; The current offset of filled characters in the buffer.
 29  ;; If offset is non-zero, (vector-ref buffer (- offset 1)) is
 30  ;; valid.
 31  (offset parse-stream-offset parse-stream-offset-set!)
 32  ;; The previous char before the beginning of this Parse-Stream.
 33  ;; Used for line/word-boundary checks.
 34  (prev-char parse-stream-prev-char)
 35  ;; The debug info for the start line and column of this chunk.
 36  (line parse-stream-line)
 37  (column parse-stream-column)
 38  ;; The successor Parse-Stream chunk, created on demand and filled
 39  ;; from the same port.
 40  (tail %parse-stream-tail %parse-stream-tail-set!)
 41  ;; Initial fk as passed to call-with-parse. Retained as part of
 42  ;; the Parse-Stream for the parse-commit procedure.
 43  (fk parse-stream-fk parse-stream-fk-set!))
 44
 45;; We want to balance avoiding reallocating buffers with avoiding
 46;; holding many memoized values in memory.
 47(define default-buffer-size 256)
 48
 49;;> Create a parse stream open on the given `filename`, with a
 50;;> possibly already opened `port`.
 51
 52(define (make-parse-stream filename . o)
 53  (let ((port (if (pair? o) (car o) (open-input-file filename)))
 54        (len (if (and (pair? o) (pair? (cdr o))) (cadr o) default-buffer-size)))
 55    (%make-parse-stream
 56     filename port (make-vector len #f) (make-vector len '()) 0 #f 0 0 #f #f)))
 57
 58;;> Open `filename` and create a parse stream on it.
 59
 60(define (file->parse-stream filename)
 61  (make-parse-stream filename (open-input-file filename)))
 62
 63;;> Create a parse stream on a string `str`.
 64
 65(define (string->parse-stream str)
 66  (make-parse-stream #f (open-input-string str)))
 67
 68;;> Access the next buffered chunk of a parse stream.
 69
 70(define (parse-stream-tail source)
 71  (or (%parse-stream-tail source)
 72      (let* ((len (vector-length (parse-stream-buffer source)))
 73             (line-info (parse-stream-count-lines source))
 74             (line (+ (parse-stream-line source) (car line-info)))
 75             (col (if (zero? (car line-info))
 76                      (+ (parse-stream-column source) (cadr line-info))
 77                      (cadr line-info)))
 78             (tail (%make-parse-stream (parse-stream-filename source)
 79                                       (parse-stream-port source)
 80                                       (make-vector len #f)
 81                                       (make-vector len '())
 82                                       0
 83                                       (parse-stream-last-char source)
 84                                       line
 85                                       col
 86                                       #f
 87                                       (parse-stream-fk source))))
 88        (%parse-stream-tail-set! source tail)
 89        tail)))
 90
 91(define (parse-stream-fill! source i)
 92  (let ((off (parse-stream-offset source))
 93        (buf (parse-stream-buffer source))
 94        (src (parse-stream-port source)))
 95    (if (<= off i)
 96      (do ((off off (+ off 1)))
 97          ((> off i) (parse-stream-offset-set! source off))
 98        (let ((ch (if (port? src) (read-char src) (file-read-char src))))
 99          (if ch
100            (vector-set! buf off ch)
101            ;; When EOF was encountered, add one eof-object to
102            ;; the buffer, then read past the EOF through recursion.
103            (begin
104              (vector-set! buf off (eof-object))
105              (parse-stream-offset-set! source (inc off))
106              (parse-stream-fill! source i)))))
107      #f)))
108
109;;> Returns true iff `i` is the first character position in the
110;;> parse stream `source`.
111
112(define (parse-stream-start? source i)
113  (and (zero? i) (not (parse-stream-prev-char source))))
114
115;;> Returns true iff `i` is the last character position in the
116;;> parse stream `source`.
117
118(define (parse-stream-end? source i)
119  (eof-object? (parse-stream-ref source i)))
120
121;;> Returns the character in parse stream `source` indexed by
122;;> `i`.
123
124(define (parse-stream-ref source i)
125  (parse-stream-fill! source i)
126  (vector-ref (parse-stream-buffer source) i))
127
128(define (parse-stream-last-char source)
129  (let ((buf (parse-stream-buffer source)))
130    (let lp ((i (min (- (vector-length buf) 1) (parse-stream-offset source))))
131      (if (negative? i)
132          (parse-stream-prev-char source)
133          (let ((ch (vector-ref buf i)))
134            (if (eof-object? ch)
135                (lp (- i 1))
136                ch))))))
137
138(define (parse-stream-char-before source i)
139  (if (> i (parse-stream-offset source))
140      (parse-stream-ref source (- i 1))
141      (parse-stream-prev-char source)))
142
143(define (parse-stream-max-char source)
144  (let ((buf (parse-stream-buffer source)))
145    (let lp ((i (min (- (vector-length buf) 1)
146                     (parse-stream-offset source))))
147      (if (or (negative? i)
148              (char? (vector-ref buf i)))
149          i
150          (lp (- i 1))))))
151
152(define (parse-stream-count-lines source . o)
153  (let* ((buf (parse-stream-buffer source))
154         (end (if (pair? o) (car o) (vector-length buf))))
155    (let lp ((i 0) (from 0) (lines 0))
156      (if (>= i end)
157          (list lines (- i from) from)
158          (let ((ch (vector-ref buf i)))
159            (cond
160             ((not (char? ch))
161              (list lines (- i from) from))
162             ((eqv? ch #\newline)
163              (lp (+ i 1) i (+ lines 1)))
164             (else
165              (lp (+ i 1) from lines))))))))
166
167(define (parse-stream-end-of-line source i)
168  (let* ((buf (parse-stream-buffer source))
169         (end (vector-length buf)))
170    (let lp ((i i))
171      (if (>= i end)
172          i
173          (let ((ch (vector-ref buf i)))
174            (if (or (not (char? ch)) (eqv? ch #\newline))
175                i
176                (lp (+ i 1))))))))
177
178(define (parse-stream-debug-info s i)
179  ;; i is the failed parse index, but we want the furthest reached
180  ;; location
181  (if (%parse-stream-tail s)
182      (parse-stream-debug-info (%parse-stream-tail s) i)
183      (let ((max-char (parse-stream-max-char s)))
184        (if (< max-char 0)
185            (list 0 0 "")
186            (let* ((line-info
187                    (parse-stream-count-lines s max-char))
188                   (line (+ (parse-stream-line s) (car line-info)))
189                   (col (if (zero? (car line-info))
190                            (+ (parse-stream-column s) (cadr line-info))
191                            (cadr line-info)))
192                   (from (car (cddr line-info)))
193                   (to (parse-stream-end-of-line s (+ from 1)))
194                   (str (parse-stream-substring s from s to)))
195              (list line col str))))))
196
197(define (parse-stream-next-source source i)
198  (if (>= (+ i 1) (vector-length (parse-stream-buffer source)))
199      (parse-stream-tail source)
200      source))
201
202(define (parse-stream-next-index source i)
203  (if (>= (+ i 1) (vector-length (parse-stream-buffer source)))
204      0
205      (+ i 1)))
206
207(define (parse-stream-close source)
208  (let ((src (parse-stream-port source)))
209    (if (port? src)
210      (close-input-port (parse-stream-port source))
211      (file-close src))))
212
213(define (vector-substring vec start . o)
214  (let* ((end (if (pair? o) (car o) (vector-length vec)))
215         (res (make-string (- end start))))
216    (do ((i start (+ i 1)))
217        ((= i end) res)
218      (string-set! res (- i start) (vector-ref vec i)))))
219
220(define (parse-stream-in-tail? s0 s1)
221  (let ((s0^ (%parse-stream-tail s0)))
222    (or (eq? s0^ s1)
223        (and s0^ (parse-stream-in-tail? s0^ s1)))))
224
225(define (parse-stream< s0 i0 s1 i1)
226  (if (eq? s0 s1)
227      (< i0 i1)
228      (parse-stream-in-tail? s0 s1)))
229
230;;> Returns a string composed of the characters starting at parse
231;;> stream `s0` index `i0` (inclusive), and ending at `s1`
232;;> index `i1` (exclusive).
233
234(define (parse-stream-substring s0 i0 s1 i1)
235  (cond
236   ((eq? s0 s1)
237    (parse-stream-fill! s0 i1)
238    (vector-substring (parse-stream-buffer s0) i0 i1))
239   (else
240    (let lp ((s (parse-stream-tail s0))
241             (res (list (vector-substring (parse-stream-buffer s0) i0))))
242      (let ((buf (parse-stream-buffer s)))
243        (cond
244         ((eq? s s1)
245          (apply string-append
246                 (reverse (cons (vector-substring buf 0 i1) res))))
247         (else
248          (lp (parse-stream-tail s)
249              (cons (vector-substring buf 0) res)))))))))
250
251(define (parse-stream-cache-cell s i f)
252  (assv f (vector-ref (parse-stream-cache s) i)))
253
254(define (parse-stream-cache-set! s i f x)
255  (let ((cache (vector-ref (parse-stream-cache s) i)))
256    (cond
257     ((assv f cache)
258      => (lambda (cell)
259           ;; prefer longer matches
260           (if (and (pair? (cdr cell))
261                    (parse-stream< (car (cddr cell)) (cadr (cddr cell)) s i))
262               (set-cdr! cell x))))
263     (else
264      (vector-set! (parse-stream-cache s) i (cons (cons f x) cache))))))
265
266;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
267
268;;>| Parser Interface
269;;>
270;;> Procedures for operating on a created parse stream.
271
272;;> Combinator to indicate failure.
273
274(define (parse-failure s i reason)
275  (let ((line+col (parse-stream-debug-info s i)))
276    (error "incomplete parse at" (append line+col (list reason)))))
277
278;;> Call the parser combinator `f` on the parse stream
279;;> `source`, starting at index `index`, passing the result to
280;;> the given success continuation `sk`, which should be a
281;;> procedure of the form `(result source index fail)`.  The
282;;> optional failure continuation should be a procedure of the form
283;;> `(source index reason)`, and defaults to just returning
284;;> `#f`.
285
286(define (call-with-parse f source index sk . o)
287  (let ((s (if (string? source) (string->parse-stream source) source))
288        (fk (if (pair? o) (car o) (lambda (s i reason) #f))))
289    (parse-stream-fk-set! s fk)
290    (f s index sk fk)))
291
292;;> Call the parser combinator `f` on the parse stream
293;;> `source`, at index `index`, and return the result, or
294;;> `#f` if parsing fails.
295
296(define (parse f source . o)
297  (let ((index (if (pair? o) (car o) 0)))
298    (call-with-parse f source index (lambda (r s i fk) r))))
299
300;;> Call the parser combinator `f` on the parse stream
301;;> `source`, at index `index`.  If the entire source is not
302;;> parsed, raises an error, otherwise returns the result.
303
304(define (parse-fully f source . o)
305  (let ((s (if (string? source) (string->parse-stream source) source))
306        (index (if (pair? o) (car o) 0)))
307    (call-with-parse
308     f s index
309     (lambda (r s i fk)
310       (if (parse-stream-end? s i) r (fk s i "incomplete parse")))
311     parse-failure)))
312
313;;> The fundamental parse iterator.  Repeatedly applies the parser
314;;> combinator `f` to `source`, starting at `index`, as
315;;> long as a valid parse is found.  On each successful parse applies
316;;> the procedure `kons` to the parse result and the previous
317;;> `kons` result, beginning with `knil`.  If no parses
318;;> succeed returns `knil`.
319
320(define (parse-fold f kons knil source . o)
321  (let lp ((p (if (string? source) (string->parse-stream source) source))
322           (index (if (pair? o) (car o) 0))
323           (acc knil))
324    (f p index (lambda (r s i fk) (lp s i (kons r acc))) (lambda (s i r) acc))))
325
326;;> Parse as many of the parser combinator `f` from the parse
327;;> stream `source`, starting at `index`, as possible, and
328;;> return the result as a list.
329
330(define (parse->list f source . o)
331  (let ((index (if (pair? o) (car o) 0)))
332    (reverse (parse-fold f cons '() source index))))
333
334;;> As `parse->list` but requires the entire source be parsed
335;;> with no left over characters, signalling an error otherwise.
336
337(define (parse-fully->list f source . o)
338  (let lp ((s (if (string? source) (string->parse-stream source) source))
339           (index (if (pair? o) (car o) 0))
340           (acc '()))
341    (f s index
342       (lambda (r s i fk)
343         (if (eof-object? r) (reverse acc) (lp s i (cons r acc))))
344       (lambda (s i reason) (error "incomplete parse")))))
345
346;;> Return a new parser combinator with the same behavior as `f`,
347;;> but on failure replaces the reason with `reason`.  This can be
348;;> useful to provide more descriptive parse failure reasons when
349;;> chaining combinators.  For example, `parse-string` just
350;;> expects to parse a single fixed string.  If it were defined in
351;;> terms of `parse-char`, failure would indicate some char
352;;> failed to match, but it's more useful to describe the whole string
353;;> we were expecting to see.
354
355(define (parse-with-failure-reason f reason)
356  (lambda (r s i fk)
357    (f r s i (lambda (s i r) (fk s i reason)))))
358
359;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
360
361;;>| Basic Parsing Combinators
362;;>
363;;> Combinators to construct new parsers.
364
365;;> Parse nothing successfully.
366
367(define parse-epsilon
368  (lambda (source index sk fk)
369    (sk #t source index fk)))
370
371;;> Parse any single character successfully.  Fails at end of input.
372
373(define parse-anything
374  (lambda (source index sk fk)
375    (if (parse-stream-end? source index)
376        (fk source index "end of input")
377        (sk (parse-stream-ref source index)
378            (parse-stream-next-source source index)
379            (parse-stream-next-index source index)
380            fk))))
381
382;;> Always fail to parse.
383
384(define parse-nothing
385  (lambda (source index sk fk)
386    (fk source index "nothing")))
387
388;;> The disjunction combinator.  Returns the first combinator that
389;;> succeeds parsing from the same source and index.
390
391(define (parse-or f . o)
392  (if (null? o)
393      f
394      (let ((g (apply parse-or o)))
395        (lambda (source index sk fk)
396          (let ((fk2 (lambda (s i r)
397                       (g source index sk fk
398                          ;; (lambda (s2 i2 r2)
399                          ;;   (fk s2 i2 `(or ,r ,r2)))
400                          ))))
401            (f source index sk fk2))))))
402
403;;> The conjunction combinator.  If both `f` and `g` parse
404;;> successfully starting at the same source and index, returns the
405;;> result of `g`.  Otherwise fails.
406
407(define (parse-and f g)
408  (lambda (source index sk fk)
409    (f source index (lambda (r s i fk) (g source index sk fk)) fk)))
410
411;;> The negation combinator.  If `f` succeeds, fails, otherwise
412;;> succeeds with `#t`.
413
414(define (parse-not f)
415  (lambda (source index sk fk)
416    (f source index (lambda (r s i fk) (fk s i "not"))
417       (lambda (s i r) (sk #t source index fk)))))
418
419(define (parse-seq-list o)
420  (cond
421   ((null? o)
422    parse-epsilon)
423   ((null? (cdr o))
424    (let ((f (car o)))
425      (lambda (s i sk fk)
426        (f s i (lambda (r s i fk)
427                 (sk (if (eq? r ignored-value) '() (list r)) s i fk))
428           fk))))
429   (else
430    (let* ((f (car o))
431           (o (cdr o))
432           (g (car o))
433           (o (cdr o))
434           (g (if (pair? o)
435                  (apply parse-seq g o)
436                  (lambda (s i sk fk)
437                    (g s i (lambda (r s i fk)
438                             (sk (if (eq? r ignored-value) '() (list r))
439                                 s i fk))
440                       fk)))))
441      (lambda (source index sk fk)
442        (f source
443           index
444           (lambda (r s i fk)
445             (g s i (lambda (r2 s i fk)
446                      (let ((r2 (if (eq? r ignored-value) r2 (cons r r2))))
447                        (sk r2 s i fk)))
448                fk))
449           fk))))))
450
451;;> The sequence combinator.  Each combinator is applied in turn just
452;;> past the position of the previous.  If all succeed, returns a list
453;;> of the results in order, skipping any ignored values.
454
455(define (parse-seq . o)
456  (parse-seq-list o))
457
458;;> Convert the list of parser combinators `ls` to a
459;;> `parse-seq` sequence.
460
461(define (list->parse-seq ls)
462  (if (null? (cdr ls)) (car ls) (parse-seq-list ls)))
463
464;;> The optional combinator.  Parse the combinator `f` (in
465;;> sequence with any additional combinator args `o`), and return
466;;> the result, or parse nothing successully on failure.
467
468(define (parse-optional f . o)
469  (if (pair? o)
470      (parse-optional (apply parse-seq f o))
471      (lambda (source index sk fk)
472        (f source index sk (lambda (s i r) (sk #f source index fk))))))
473
474(define ignored-value (list 'ignore))
475
476;;> The repetition combinator.  Parse `f` repeatedly and return a
477;;> list of the results.  `lo` is the minimum number of parses
478;;> (deafult 0) to be considered a successful parse, and `hi` is
479;;> the maximum number (default infinite) before stopping.
480
481(define (parse-repeat f . o)
482  (let ((lo (if (pair? o) (car o) 0))
483        (hi (and (pair? o) (pair? (cdr o)) (cadr o))))
484    (lambda (source0 index0 sk fk)
485      (let repeat ((source source0) (index index0) (fk fk) (j 0) (res '()))
486        (let ((fk (if (>= j lo)
487                      (lambda (s i r) (sk (reverse res) source index fk))
488                      fk)))
489          (if (and hi (= j hi))
490              (sk (reverse res) source index fk)
491              (f source
492                 index
493                 (lambda (r s i fk) (repeat s i fk (+ j 1) (cons r res)))
494                 fk)))))))
495
496;;> Parse `f` one or more times.
497
498(define (parse-repeat+ f)
499  (parse-repeat f 1))
500
501;;> Parse `f` and apply the procedure `proc` to the result on success.
502
503(define (parse-map f proc)
504  (lambda (source index sk fk)
505    (f source index (lambda (res s i fk) (sk (proc res) s i fk)) fk)))
506
507;;> Parse `f` and apply the procedure `proc` to the substring
508;;> of the parsed data.  `proc` defaults to the identity.
509
510(define (parse-map-substring f . o)
511  (let ((proc (if (pair? o) (car o) (lambda (res) res))))
512    (lambda (source index sk fk)
513      (f source
514         index
515         (lambda (res s i fk)
516           (sk (proc (parse-stream-substring source index s i)) s i fk))
517         fk))))
518
519;;> Parses the same streams as `f` but ignores the result on
520;;> success.  Inside a `parse-seq` the result will not be
521;;> included in the list of results.  Useful for discarding
522;;> boiler-plate without the need for post-processing results.
523
524(define (parse-ignore f)
525  (parse-map f (lambda (res) ignored-value)))
526
527;;> Parse with `f` and further require `check?` to return true
528;;> when applied to the result.
529
530(define (parse-assert f check?)
531  (lambda (source index sk fk)
532    (f source
533       index
534       (lambda (res s i fk)
535         (if (check? res) (sk res s i fk) (fk s i "assertion failed")))
536       fk)))
537
538;;> Parse with `f` once and keep the first result, not allowing
539;;> further backtracking within `f`.
540
541(define (parse-atomic f)
542  (lambda (source index sk fk)
543    (f source index (lambda (res s i fk2) (sk res s i fk)) fk)))
544
545;;> Parse with `f` once, keep the first result, and commit to the
546;;> current parse path, discarding any prior backtracking options.
547;;> Can optionally be passed a failure reason with which all resulting
548;;> failure messages will be prefixed.
549
550(define (parse-commit f . o)
551  (let ((prefix (if (pair? o) (string-append (car o) ": ") "")))
552    (lambda (source index sk fk)
553      (let ((commit-fk (parse-stream-fk source)))
554        (f
555          source
556          index
557          (lambda (res s i fk)
558            (sk res s i (lambda (s i r)
559                          (commit-fk s i (string-append prefix r)))))
560          fk)))))
561
562;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
563
564;;>| Boundary Checks
565;;>
566;;> Procedures for performing boundary checks within a parser combinator.
567
568;;> Returns true iff `index` is the first index of the first parse
569;;> stream `source`.
570
571(define parse-beginning
572  (lambda (source index sk fk)
573    (if (parse-stream-start? source index)
574        (sk #t source index fk)
575        (fk source index "expected beginning"))))
576
577;;> Returns true iff `index` is the last index of the last parse
578;;> stream `source`.
579
580(define parse-end
581  (lambda (source index sk fk)
582    (if (parse-stream-end? source index)
583        (begin
584          (sk #t
585              (parse-stream-next-source source index)
586              (parse-stream-next-index source index)
587              fk))
588      (fk source index "expected end"))))
589
590;;> Returns true iff `source`, `index` indicate the beginning
591;;> of a line (or the entire stream).
592
593(define parse-beginning-of-line
594  (lambda (source index sk fk)
595    (let ((before (parse-stream-char-before source index)))
596      (if (or (not before) (eqv? #\newline before))
597          (sk #t source index fk)
598          (fk source index "expected beginning of line")))))
599
600;;> Returns true iff `source`, `index` indicate the end of a
601;;> line (or the entire stream).
602
603(define parse-end-of-line
604  (lambda (source index sk fk)
605    (if (or (parse-stream-end? source index)
606            (eqv? #\newline (parse-stream-ref source index)))
607        (sk #t source index fk)
608        (fk source index "expected end of line"))))
609
610;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
611
612;;>| Constant Parsers
613;;>
614;;> Underlying combinators which parse a constant input and, contrary to
615;;> the parsers documented above, cannot be passed parser combinators as
616;;> procedure arguments.
617
618(define (parse-char-pred pred)
619  (lambda (source index sk fk)
620    (let ((ch (parse-stream-ref source index)))
621      (if (and (char? ch) (pred ch))
622          (sk ch
623              (parse-stream-next-source source index)
624              (parse-stream-next-index source index)
625              fk)
626          (fk source index "failed char pred")))))
627
628(define (x->char-predicate x)
629  (cond
630   ((char? x)
631    (lambda (ch) (eqv? ch x)))
632   ((char-set? x)
633    (lambda (ch) (and (char? ch) (char-set-contains? x ch))))
634   ((procedure? x)
635    (lambda (ch) (and (char? ch) (x ch))))
636   (else
637    (error "don't know how to handle char predicate" x))))
638
639;;> Parse a single char which matches `x`, which can be a
640;;> character, character set, or arbitrary procedure.
641
642(define (parse-char x)
643  (parse-char-pred (x->char-predicate x)))
644
645;;> Parse a single char which does not match `x`, which can be a
646;;> character, character set, or arbitrary procedure.
647
648(define (parse-not-char x)
649  (let ((pred (x->char-predicate x)))
650    (parse-char-pred (lambda (ch) (not (pred ch))))))
651
652;;> Parse the exact string `str`.
653
654(define (parse-string str)
655  (parse-map (parse-with-failure-reason
656              (parse-seq-list (map parse-char (string->list str)))
657              (string-append "expected '" str "'"))
658             list->string))
659
660;;> Parse a sequence of characters matching `x` as with
661;;> `parse-char`, and return the resulting substring.
662
663(define (parse-token x)
664  ;; (parse-map (parse-repeat+ (parse-char x)) list->string)
665  ;; Tokens are atomic - we don't want to split them at any point in
666  ;; the middle - so the implementation is slightly more complex than
667  ;; the above.  With a sane grammar the result would be the same
668  ;; either way, but this provides a useful optimization.
669  (let ((f (parse-char x)))
670    (lambda (source0 index0 sk fk)
671      (let lp ((source source0) (index index0))
672        (f source
673           index
674           (lambda (r s i fk) (lp s i))
675           (lambda (s i r)
676             (if (and (eq? source source0) (eqv? index index0))
677                 (fk s i r)
678                 (sk (parse-stream-substring source0 index0 source index)
679                     source index fk))))))))
680
681;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
682
683;;>| Laziness and Memoization
684;;>
685;;> [Lazy evaluation][wikipedia lazy] of parser combinators and [memoization][wikipedia memoization].
686;;>
687;;> [wikipedia lazy]: https://en.wikipedia.org/wiki/Lazy_evaluation
688;;> [wikipedia memoization]: https://en.wikipedia.org/wiki/Memoization
689
690;;> A delayed combinator.  This is equivalent to the parser combinator
691;;> `f`, but is delayed so it can be more efficient if never used
692;;> and `f` is expensive to compute.  Moreover, it can allow
693;;> self-referentiality as in:
694;;>
695;;>    (letrec* ((f (parse-lazy (parse-or (parse-seq g f) h))))
696;;>      ...)
697
698(define-syntax parse-lazy
699  (syntax-rules ()
700    ((parse-lazy f)
701     (let ((g (delay f)))
702       (lambda (source index sk fk)
703         ((force g) source index sk fk))))))
704
705;; Utility definitions for memoization.
706
707;; debugging
708(define *procedures* '())
709(define (procedure-name f)
710  (cond ((assq f *procedures*) => cdr) (else #f)))
711(define (procedure-name-set! f name)
712  (set! *procedures* (cons (cons f name) *procedures*)))
713
714(define memoized-failure (list 'failure))
715
716;;> Parse the same strings as `f`, but memoize the result at each
717;;> source and index to avoid exponential backtracking.  `name` is
718;;> provided for debugging only.
719
720(define (parse-memoize name f)
721  ;;(if (not (procedure-name f)) (procedure-name-set! f name))
722  (lambda (source index sk fk)
723    (cond
724     ((parse-stream-cache-cell source index f)
725      => (lambda (cell)
726           (if (and (pair? (cdr cell)) (eq? memoized-failure (cadr cell)))
727               (fk source index (cddr cell))
728               (apply sk (append (cdr cell) (list fk))))))
729     (else
730      (f source
731         index
732         (lambda (res s i fk)
733           (parse-stream-cache-set! source index f (list res s i))
734           (sk res s i fk))
735         (lambda (s i r)
736           (if (not (pair? (parse-stream-cache-cell source index f)))
737               (parse-stream-cache-set!
738                source index f (cons memoized-failure r)))
739           (fk s i r)))))))