[WIP] Bootstrap an ABNF backtracking parserbetter-web-api

2 files changed, 1071 insertions, 2 deletions

diff --git a/src/scm/webid-oidc/Makefile.am b/src/scm/webid-oidc/Makefile.am
index bd167db..7f3b33f 100644
--- a/src/scm/webid-oidc/Makefile.am
+++ b/src/scm/webid-oidc/Makefile.am
@@ -44,7 +44,8 @@ dist_webidoidcmod_DATA += \
   %reldir%/simulation.scm \
   %reldir%/web-i18n.scm \
   %reldir%/serializable.scm \
-  %reldir%/abnf-types.scm
+  %reldir%/abnf-types.scm \
+  %reldir%/abnf-bootstrap.scm
 
 webidoidcgo_DATA += \
   %reldir%/errors.go \
@@ -76,7 +77,8 @@ webidoidcgo_DATA += \
   %reldir%/simulation.go \
   %reldir%/web-i18n.go \
   %reldir%/serializable.go \
-  %reldir%/abnf-types.go
+  %reldir%/abnf-types.go \
+  %reldir%/abnf-bootstrap.go
 
 EXTRA_DIST += %reldir%/ChangeLog
 
diff --git a/src/scm/webid-oidc/abnf-bootstrap.scm b/src/scm/webid-oidc/abnf-bootstrap.scm
new file mode 100644
index 0000000..6f5f7db
--- /dev/null
+++ b/src/scm/webid-oidc/abnf-bootstrap.scm
@@ -0,0 +1,1067 @@
+;; disfluid, implementation of the Solid specification
+;; Copyright (C) 2021  Vivien Kraus
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU Affero General Public License as
+;; published by the Free Software Foundation, either version 3 of the
+;; License, or (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU Affero General Public License for more details.
+
+;; You should have received a copy of the GNU Affero General Public License
+;; along with this program.  If not, see <https://www.gnu.org/licenses/>.
+
+(define-module (webid-oidc abnf-bootstrap)
+  #:use-module (oop goops)
+  #:use-module (ice-9 receive)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 binary-ports)
+  #:use-module (ice-9 textual-ports)
+  #:use-module (ice-9 exceptions)
+  #:use-module (webid-oidc web-i18n)
+  #:use-module (srfi srfi-26)
+  #:use-module (rnrs bytevectors)
+  #:duplicates (merge-generics)
+  #:declarative? #t
+  #:export
+  (
+   ))
+
+;; This is RFC 4234.
+
+(define-exception-type
+  &failed-to-parse
+  &external-error
+  make-failed-to-parse
+  failed-to-parse?
+  (index failed-to-parse-index))
+
+(define (parse-character-class produce)
+  (lambda (port)
+    (let ((cache (make-hash-table)))
+      (lambda ()
+        (let ((index (ftell port)))
+          (match (hash-ref cache index)
+            (#f ;; Not explored yet
+             (let* ((c (read-char port))
+                    (produced
+                     (with-exception-handler
+                         (lambda (error)
+                           (seek port -1 SEEK_CUR)
+                           `(error
+                             . ,(make-exception
+                                 (make-failed-to-parse index)
+                                 (make-exception-with-origin 'parse-character-class)
+                                 (make-exception-with-message
+                                  (format #f (G_ "the character ~a is not accepted") c))
+                                 error)))
+                       (lambda ()
+                         `(ok . ,(produce index c)))
+                       #:unwind? #t
+                       #:unwind-for-type &failed-to-parse)))
+               (hash-set! cache index produced)
+               (match produced
+                 (('ok . value) value)
+                 (('error . error)
+                  (raise-exception error)))))
+            (('ok . produced)
+             (begin
+               (seek port 1 SEEK_CUR)
+               produced))
+            (('error . error)
+             (raise-exception error))))))))
+
+(define (parse-ci produce)
+  (parse-character-class
+   (lambda (index c)
+     (if (and (char>= c #\A) (char<= c #\Z))
+         (integer->char
+          (+ (char->integer c)
+             (- (char->integer #\a) (char->integer #\A))))
+         c))))
+
+(define-exception-type
+  &failed-to-parse-concatenation
+  &failed-to-parse
+  make-failed-to-parse-concatenation
+  failed-to-parse-concatenation?
+  (element-index failed-to-parse-concatenation-element-index))
+
+(define (parse-concatenation produce elements)
+  (lambda (port)
+    (let ((cache (make-hash-table)))
+      (lambda ()
+        (let ((index (ftell port)))
+          (match (hash-ref cache index)
+            (#f ;; Not explored
+             (let explore-elements ((elements elements)
+                                    (i 0)
+                                    (values '()))
+               (match elements
+                 (()
+                  (let ((final-index (ftell port)))
+                    (let ((produced
+                           (with-exception-handler
+                               (lambda (error)
+                                 (seek port (- index final-index) SEEK_CUR)
+                                 `(error
+                                   . ,(make-exception
+                                       (make-failed-to-parse index)
+                                       (make-exception-with-origin 'parse-concatenation)
+                                       (make-exception-with-message
+                                        (format #f (G_ "the concatenation production failed")))
+                                       error)))
+                             (lambda ()
+                               `(ok . ,(apply produce index (reverse values))))
+                             #:unwind? #t
+                             #:unwind-for-type &error)))
+                      (hash-set! cache index
+                                 `(,produced . ,(- final-index index)))
+                      (match produced
+                        (('ok . value) value)
+                        (('error . error)
+                         (raise-exception error))))))
+                 ((next elements ...)
+                  (let ((current-index (ftell port)))
+                    (let ((next-value
+                           (with-exception-handler
+                               (lambda (error)
+                                 (seek port (- index current-index) SEEK_CUR)
+                                 (raise-exception
+                                  (make-exception
+                                   (make-failed-to-parse-concatenation current-index i)
+                                   (make-exception-with-origin 'parse-concatenation)
+                                   (make-exception-with-message
+                                    (format #f (G_ "failed to parse concatenation element ~a") i))
+                                   error)))
+                             (lambda ()
+                               (next)))))
+                      (explore-elements elements (+ i 1) `(,next-value ,@values))))))))
+            ((('ok . value) . length)
+             (begin
+               (seek port length SEEK_CUR)
+               value))
+            ((('error . error) . _)
+             (raise-exception error))))))))
+
+(define-exception-type
+  &failed-to-parse-alternatives
+  &failed-to-parse
+  make-failed-to-parse-alternatives
+  failed-to-parse-alternatives?)
+
+(define (parse-alternatives produce elements)
+  (lambda (port)
+    (let ((cache (make-hash-table)))
+      (lambda ()
+        (let ((index (ftell port)))
+          (match (hash-ref cache index)
+            (#f
+             (let explore-alternatives ((elements elements)
+                                        (past-errors '()))
+               (match elements
+                 (()
+                  (let ((final-exception
+                         (apply
+                          make-exception
+                          (make-failed-to-parse-alternatives index)
+                          (make-exception-with-origin 'parse-alternatives)
+                          (make-exception-with-message
+                           (format #f (G_ "failed to parse any alternative")))
+                          (reverse past-errors))))
+                    (hash-set! cache index `(error . ,final-exception))
+                    (raise-exception final-exception)))
+                 (((key . next) elements ...)
+                  (with-exception-handler
+                      (lambda (error)
+                        (explore-alternatives elements `(,error ,@past-errors)))
+                    (lambda ()
+                      (let ((produced (produce index key (next))))
+                        (hash-set! cache index `((ok . ,produced) . ,(- (ftell port) index)))
+                        produced))
+                    #:unwind? #t
+                    #:unwind-for-type &failed-to-parse)))))
+            ((('ok . value) . length)
+             (begin
+               (seek port length SEEK_CUR)
+               value))
+            (('error . exception)
+             (raise-exception exception))))))))
+
+(define-exception-type
+  &failed-to-parse-range
+  &failed-to-parse
+  make-failed-to-parse-range
+  failed-to-parse-range?
+  (minimum failed-to-parse-range-minimum)
+  (maximum failed-to-parse-range-maximum)
+  (value failed-to-parse-range-value))
+
+(define (parse-range produce minimum maximum)
+  (parse-character-class
+   (lambda (index c)
+     (unless (and (char>=? c minimum) (char<=? c maximum))
+       (raise-exception
+        (make-exception
+         (make-failed-to-parse-range index minimum maximum c)
+         (make-exception-with-origin 'parse-range)
+         (make-exception-with-message
+          (format #f (G_ "failed to parse ~s in range [~s-~s]") c minimum maximum)))))
+     c)))
+
+(define-exception-type
+  &failed-to-parse-repetition
+  &failed-to-parse
+  make-failed-to-parse-repetition
+  failed-to-parse-repetition?
+  (minimum failed-to-parse-repetition-minimum)
+  (times failed-to-parse-repetition-times))
+
+(define (parse-repetition produce minimum maximum element)
+  (lambda (port)
+    (let ((cache (make-hash-table)))
+      (lambda ()
+        (let ((index (ftell port)))
+          (match (hash-ref cache index)
+            (#f
+             (let explore-repetitions ((i 0)
+                                       (values '()))
+               (let ((current-index (ftell port)))
+                 (define (reject exception)
+                   (seek port (- index current-index) SEEK_CUR)
+                   (hash-set! cache index `(error . ,exception))
+                   (raise-exception exception))
+                 (define (accept reason)
+                   (let ((length (- current-index index)))
+                     ;; Maybe the production function will choke
+                     (with-exception-handler
+                         (lambda (production-error)
+                           (reject
+                            (make-exception
+                             (make-failed-to-parse index)
+                             (make-exception-with-origin 'parse-repetition)
+                             (make-exception-with-message
+                              (format #f (G_ "the repetition production failed to produce a value")))
+                             production-error)))
+                       (lambda ()
+                         (let ((produced
+                                (produce index (list->vector (reverse values)) reason)))
+                           (hash-set! cache index `((ok . ,produced) . ,length))
+                           produced))
+                       #:unwind? #t)))
+                 (if (and maximum (= i maximum))
+                     (accept #f)
+                     ;; else, try to read once more
+                     (with-exception-handler
+                         (lambda (error)
+                           (if (>= i minimum)
+                               ;; We can accept it, pass the breaking error though
+                               (accept error)
+                               ;; Else, we did not clear the minimum number of times -> fail
+                               (reject
+                                (make-exception
+                                 (make-failed-to-parse-repetition index minimum i)
+                                 (make-exception-with-origin 'parse-repetition)
+                                 (make-exception-with-message
+                                  (format #f (G_ "there are not enough repetitions: ~a, expected at least ~a")
+                                          i minimum))
+                                 error))))
+                       (lambda ()
+                         (explore-repetitions (+ i 1) `(,(element) ,@values)))
+                       #:unwind? #t)))))
+            ((('ok . value) . length)
+             (seek port length SEEK_CUR)
+             value)
+            (('error . exception)
+             (raise-exception exception))))))))
+
+(define-exception-type
+  &failed-to-parse-specific-repetition
+  &failed-to-parse
+  make-failed-to-parse-specific-repetition
+  failed-to-parse-specific-repetition?
+  (expected failed-to-parse-specific-repetition-expected)
+  (times failed-to-parse-specific-repetition-times))
+
+(define (parse-specific-repetition produce times element)
+  (let ((base (parse-repetition produce times times element)))
+    (lambda (port)
+      (let ((base (base port)))
+        (lambda ()
+          (with-exception-handler
+              (lambda (error)
+                (raise-exception
+                 (make-exception
+                  (failed-to-parse-specific-repetition
+                   (failed-to-parse-index error)
+                   times
+                   (failed-to-parse-repetition-times error)
+                   (make-exception-with-message
+                    (format #f (G_ "there are not enough repetitions: ~a, expected ~a")
+                            (failed-to-parse-repetition-times error) times))
+                   error))))
+            (lambda ()
+              (base))
+            #:unwind? #t
+            #:unwind-for-type &failed-to-parse-repetition))))))
+
+(define (parse-optional produce element)
+  (parse-repetition
+   (lambda (index values)
+     (produce index (vector->list values)))
+   0 1 element))
+
+(define-exception-type
+  &failed-to-parse-ALPHA
+  &failed-to-parse
+  make-failed-to-parse-ALPHA
+  failed-to-parse-ALPHA?)
+
+(define (parse-ALPHA produce)
+  (parse-character-class
+   (lambda (index c)
+     (cond
+      ((and (char>=? c #\a) (char<=? c #\z))
+       (let ((upper (integer->char
+                     (+ (char->integer c)
+                        (- (char->integer #\A)
+                           (char->integer #\a))))))
+         (produce index c 'lower c upper)))
+      ((and (char>=? c #\A) (char<=? c #\Z))
+       (let ((lower (integer->char
+                     (+ (char->integer c)
+                        (- (char->integer #\a)
+                           (char->integer #\A))))))
+         (produce index c 'upper lower c)))
+      (else
+       (raise-exception
+        (make-exception
+         (make-failed-to-parse-ALPHA index)
+         (make-exception-with-origin 'parse-ALPHA)
+         (make-exception-with-message
+          (format #f (G_ "expected an ASCII alphabetical character, got ~s") c)))))))))
+
+(define-exception-type
+  &failed-to-parse-BIT
+  &failed-to-parse
+  make-failed-to-parse-BIT
+  failed-to-parse-BIT?)
+
+(define (parse-BIT produce)
+  (parse-character-class
+   (lambda (index c)
+     (case c
+       ((#\0) (produce index c #f))
+       ((#\1) (produce index c #t))
+       (else
+        (raise-exception
+         (make-exception
+          (make-failed-to-parse-BIT index)
+          (make-exception-with-origin 'parse-BIT)
+          (make-exception-with-message
+           (format #f (G_ "expected a 0 or 1 digit, got ~s") c)))))))))
+
+(define-exception-type
+  &failed-to-parse-CHAR
+  &failed-to-parse
+  make-failed-to-parse-CHAR
+  failed-to-parse-CHAR?)
+
+(define (parse-CHAR produce)
+  (let ((base (parse-range produce #\x01 #\x7F)))
+    (lambda (port)
+      (let ((base (base port)))
+        (lambda ()
+          (with-exception-handler
+              (lambda (error)
+                (raise-exception
+                 (make-exception
+                  (make-failed-to-parse-CHAR (failed-to-parse-index error))
+                  (make-exception-with-origin 'parse-CHAR)
+                  (make-exception-with-message
+                   (format #f (G_ "expected a 7-bit ASCII character except NUL, got ~s")
+                           (failed-to-parse-range-value error)))
+                  error)))
+            (lambda ()
+              (base))
+            #:unwind? #t
+            #:unwind-for-type &failed-to-parse-range))))))
+
+(define-exception-type
+  &failed-to-parse-CR
+  &failed-to-parse
+  make-failed-to-parse-CR
+  failed-to-parse-CR?)
+
+(define (parse-CR produce)
+  (parse-character-class
+   (lambda (index value)
+     (unless (eqv? value #\x0D)
+       (raise-exception
+        (make-exception
+         (make-failed-to-parse-CR index)
+         (make-exception-with-origin 'parse-CR)
+         (make-exception-with-message
+          (format #f (G_ "expected a carriage return, got ~s") value))
+         error)))
+     (produce index))))
+
+(define-exception-type
+  &failed-to-parse-CRLF
+  &failed-to-parse
+  make-failed-to-parse-CRLF
+  failed-to-parse-CRLF?)
+
+(define (parse-CRLF produce)
+  (let ((base (parse-concatenation
+               (lambda (index cr lf)
+                 (produce index))
+               `(,(parse-CR (lambda (index) #t))
+                 ,(parse-LF (lambda (index) #t))))))
+    (lambda (port)
+      (let ((base (base port)))
+        (lambda ()
+          (with-exception-handler
+              (lambda (error)
+                (raise-exception
+                 (make-exception
+                  (make-failed-to-parse-CRLF (failed-to-parse-index error))
+                  (make-exception-with-origin 'parse-CRLF)
+                  (make-exception-with-message
+                   (format #f (G_ "expected a carriage return followed by a line feed")))
+                  error)))
+            (lambda ()
+              (base))
+            #:unwind? #t
+            #:unwind-for-type &failed-to-parse-concatenation))))))
+
+(define-exception-type
+  &failed-to-parse-CTL
+  &failed-to-parse
+  make-failed-to-parse-CTL
+  failed-to-parse-CTL?)
+
+(define (parse-CTL produce)
+  (parse-character-class
+   (lambda (index c)
+     (cond
+      ((or (char<=? c #\x1F)
+           (eqv? c #\x7F))
+       (produce index c))
+      (else
+       (raise-exception
+        (make-exception
+         (make-failed-to-parse-CTL index)
+         (make-exception-with-origin 'parse-CTL)
+         (make-exception-with-message
+          (format #f (G_ "expected a control character, got ~s") c)))))))))
+
+(define-exception-type
+  &failed-to-parse-DIGIT
+  &failed-to-parse
+  make-failed-to-parse-DIGIT
+  failed-to-parse-DIGIT?)
+
+(define (parse-DIGIT produce)
+  (let ((zero (call-with-input-string "0" read-char))
+        (nine (call-with-input-string "9" read-char)))
+    (parse-character-class
+     (lambda (index c)
+       (cond
+        ((and (char>=? c zero) (char<=? c nine))
+         (produce index c (- (char->integer c) (char->integer zero))))
+        (else
+         (raise-exception
+          (make-exception
+           (make-failed-to-parse-DIGIT index)
+           (make-exception-with-origin 'parse-DIGIT)
+           (make-exception-with-message
+            (format #f (G_ "expected a decimal digit, got ~s") c))))))))))
+
+(define-exception-type
+  &failed-to-parse-DQUOTE
+  &failed-to-parse
+  make-failed-to-parse-DQUOTE
+  failed-to-parse-DQUOTE?)
+
+(define (parse-DQUOTE produce)
+  (parse-character-class
+   (lambda (index c)
+     (if (eqv? c #\")
+         (produce index)
+         (raise-exception
+          (make-exception
+           (make-failed-to-parse-DQUOTE index)
+           (make-exception-with-origin 'parse-DQUOTE)
+           (make-exception-with-message
+            (format #f (G_ "expected a double quote, got ~s") c))))))))
+
+(define-exception-type
+  &failed-to-parse-HEXDIG
+  &failed-to-parse
+  make-failed-to-parse-HEXDIG
+  failed-to-parse-HEXDIG?)
+
+(define (parse-HEXDIG produce)
+  (let ((zero (call-with-input-string "0" read-char))
+        (nine (call-with-input-string "9" read-char)))
+    (parse-character-class
+     (lambda (index c)
+       (cond
+        ((and (char>=? c zero) (char<=? c nine))
+         (produce index c (- (char->integer c) (char->integer zero))))
+        (else
+         (case c
+           ((#\a #\A) (produce index c 10))
+           ((#\b #\B) (produce index c 11))
+           ((#\c #\C) (produce index c 12))
+           ((#\d #\D) (produce index c 13))
+           ((#\e #\E) (produce index c 14))
+           ((#\f #\F) (produce index c 15))
+           (else
+            (raise-exception
+             (make-exception
+              (make-failed-to-parse-HEXDIG index)
+              (make-exception-with-origin 'parse-HEXDIG)
+              (make-exception-with-message
+               (format #f (G_ "expected an hexadecimal digit, got ~s") c))))))))))))
+
+(define-exception-type
+  &failed-to-parse-HTAB
+  &failed-to-parse
+  make-failed-to-parse-HTAB
+  failed-to-parse-HTAB?)
+
+(define (parse-HTAB produce)
+  (parse-character-class
+   (lambda (index c)
+     (if (eqv? c #\x09)
+         (produce index)
+         (raise-exception
+          (make-exception
+           (make-failed-to-parse-HTAB index)
+           (make-exception-with-origin 'parse-HTAB)
+           (make-exception-with-message
+            (format #f (G_ "expected an horizontal tabulation, got ~s") c))))))))
+
+(define-exception-type
+  &failed-to-parse-LF
+  &failed-to-parse
+  make-failed-to-parse-LF
+  failed-to-parse-LF?)
+
+(define (parse-LF produce)
+  (parse-character-class
+   (lambda (index c)
+     (if (eqv? c #\x0A)
+         (produce index)
+         (raise-exception
+          (make-exception
+           (make-failed-to-parse-LF index)
+           (make-exception-with-origin 'parse-LF)
+           (make-exception-with-message
+            (format #f (G_ "expected a line feed, got ~s") c))))))))
+
+(define-exception-type
+  &failed-to-parse-LWSP
+  &failed-to-parse
+  make-failed-to-parse-LWSP
+  failed-to-parse-LWSP?)
+
+(define (parse-LWSP produce)
+  (let ((base
+         (let ((wsp (parse-WSP (lambda (index c) (list->string (list c))))))
+           ;; wsp parses some whitespace as a string
+           (parse-repetition
+            (lambda (index values reason-to-stop)
+              (produce index (string-append (vector->list values))
+                       reason-to-stop))
+            0 #f
+            (parse-alternatives
+             (lambda (index what value)
+               value)
+             `((wsp . ,wsp)
+               (wsp-on-new-line
+                . ,(parse-concatenation
+                    (lambda (index crlf c)
+                      (string-join "\r\n" c))
+                    `(,(parse-CRLF (lambda (index) #t))
+                      ,wsp)))))))))
+    (lambda (port)
+      (let ((base (base port)))
+        (lambda ()
+          (with-exception-handler
+              (lambda (error)
+                (raise-exception
+                 (make-exception
+                  (make-failed-to-parse-LSWP (failed-to-parse-index error))
+                  (make-exception-with-origin 'parse-LWSP)
+                  (make-exception-with-message
+                   (format #f (G_ "expected linear whitespace")))
+                  error)))
+            (lambda ()
+              (base))
+            #:unwind? #t
+            #:unwind-for-type &failed-to-parse-repetition))))))
+
+(define-exception-type
+  &failed-to-parse-OCTET
+  &failed-to-parse
+  make-failed-to-parse-OCTET
+  failed-to-parse-OCTET?)
+
+(define (parse-OCTET produce)
+  (let ((base (parse-range produce #\x00 #\xFF)))
+    (lambda (port)
+      (let ((base (base port)))
+        (lambda ()
+          (with-exception-handler
+              (lambda (error)
+                (raise-exception
+                 (make-exception
+                  (make-failed-to-parse-OCTET (failed-to-parse-index error))
+                  (make-exception-with-origin 'parse-OCTET)
+                  (make-exception-with-message
+                   (format #f (G_ "expected a 8-bit octet, got ~s")
+                           (failed-to-parse-range-value error)))
+                  error)))
+            (lambda ()
+              (base))
+            #:unwind? #t
+            #:unwind-for-type &failed-to-parse-range))))))
+
+(define-exception-type
+  &failed-to-parse-SP
+  &failed-to-parse
+  make-failed-to-parse-SP
+  failed-to-parse-SP?)
+
+(define (parse-SP produce)
+  (parse-character-class
+   (lambda (index c)
+     (if (eqv? c #\x20)
+         (produce index)
+         (raise-exception
+          (make-exception
+           (make-failed-to-parse-SP index)
+           (make-exception-with-origin 'parse-SP)
+           (make-exception-with-message
+            (format #f (G_ "expected a space, got ~s") c))))))))
+
+(define-exception-type
+  &failed-to-parse-VCHAR
+  &failed-to-parse
+  make-failed-to-parse-VCHAR
+  failed-to-parse-VCHAR?)
+
+(define (parse-VCHAR produce)
+  (let ((base (parse-range produce #\x21 #\x7E)))
+    (lambda (port)
+      (let ((base (base port)))
+        (lambda ()
+          (with-exception-handler
+              (lambda (error)
+                (raise-exception
+                 (make-exception
+                  (make-failed-to-parse-VCHAR (failed-to-parse-index error))
+                  (make-exception-with-origin 'parse-VCHAR)
+                  (make-exception-with-message
+                   (format #f (G_ "expected a printing character, got ~s")
+                           (failed-to-parse-range-value error)))
+                  error)))
+            (lambda ()
+              (base))
+            #:unwind? #t
+            #:unwind-for-type &failed-to-parse-range))))))
+
+(define-exception-type
+  &failed-to-parse-WSP
+  &failed-to-parse
+  make-failed-to-parse-WSP
+  failed-to-parse-WSP?)
+
+(define (parse-WSP produce)
+  (parse-character-class
+   (lambda (index c)
+     (if (or (eqv? c #\x20) (eqv? c #\x09))
+         (produce index c)
+         (raise-exception
+          (make-exception
+           (make-failed-to-parse-WSP index)
+           (make-exception-with-origin 'parse-WSP)
+           (make-exception-with-message
+            (format #f (G_ "expected a space or tab, got ~s") c))))))))
+
+;; Now, ABNF rules
+
+(define (parse-*c-wsp)
+  (parse-repetition
+   (lambda (index values reason-to-stop)
+     #t)
+   0 #f
+   (parse-c-wsp
+    (lambda (index comments)
+      #t))))
+
+(define-exception-type
+  &failed-to-parse-rulelist
+  &failed-to-parse
+  make-failed-to-parse-rulelist
+  failed-to-parse-rulelist?)
+
+(define* (parse-rulelist produce
+                         #:key
+                         produce-rule
+                         produce-alternation
+                         produce-concatenation
+                         produce-repetition
+                         produce-rulename
+                         produce-literal
+                         produce-prose)
+  (let ((base
+         (parse-repetition
+          (lambda (index values reason-to-stop)
+            (produce index (vector->list values) reason-to-stop))
+          1 #f
+          (parse-alternatives
+           (lambda (index what value)
+             `(,what . ,value))
+           `((rule . ,(parse-rule produce-rule
+                                  #:produce-alternation produce-alternation
+                                  #:produce-concatenation produce-concatenation
+                                  #:produce-repetition produce-repetition
+                                  #:produce-rulename produce-rulename
+                                  #:produce-literal produce-literal
+                                  #:produce-prose produce-prose))
+             (whitespace
+              . ,(parse-concatenation
+                  (lambda (index opt-whitespace newline)
+                    `(,@opt-whitespace ,@newline))
+                  `(,(parse-*c-wsp)
+                    ,(parse-c-nl)))))))))
+    (lambda (port)
+      (let ((base (base port)))
+        (lambda ()
+          (with-exception-handler
+              (lambda (error)
+                (raise-exception
+                 (make-exception
+                  (make-failed-to-parse-rulelist (failed-to-parse-index error))
+                  (make-exception-with-origin 'parse-rulelist)
+                  (make-exception-with-message
+                   (format #f (G_ "expected an ABNF rule list")))
+                  error)))
+            (lambda ()
+              (base))
+            #:unwind? #t
+            #:unwind-for-type &failed-to-parse-repetition))))))
+
+(define-exception-type
+  &failed-to-parse-rule
+  &failed-to-parse
+  make-failed-to-parse-rule
+  failed-to-parse-rule?)
+
+(define* (parse-rule produce-rule
+                     #:key
+                     produce-alternation
+                     produce-concatenation
+                     produce-repetition
+                     produce-rulename
+                     produce-literal
+                     produce-prose)
+  ;; Comments are not parsed for the bootstrap ABNF at least
+  (let ((base (parse-concatenation
+               (lambda (index rulename defined-as elements nl)
+                 (produce-rule index
+                               #:name rulename
+                               #:incremental? defined-as
+                               #:elements elements))
+               `(,(parse-rulename)
+                 ,(parse-defined-as)
+                 ,(parse-elements)
+                 ,(parse-c-nl)))))
+    (lambda (port)
+      (let ((base (base port)))
+        (lambda ()
+          (with-exception-handler
+              (lambda (error)
+                (raise-exception
+                 (make-exception
+                  (make-failed-to-parse-rule (failed-to-parse-index error))
+                  (make-exception-with-origin 'parse-rule)
+                  (make-exception-with-message
+                   (format #f (G_ "expected an ABNF rule")))
+                  error)))
+            (lambda ()
+              (base))
+            #:unwind? #t
+            #:unwind-for-type &failed-to-parse-concatenation))))))
+
+(define-exception-type
+  &failed-to-parse-rulename
+  &failed-to-parse
+  make-failed-to-parse-rulename
+  failed-to-parse-rulename?)
+
+(define (parse-rulename)
+  (let ((base (parse-concatenation
+               (lambda (index first-alpha other-characters)
+                 (string->symbol (list->string `(,first-alpha ,@other-characters))))
+               `(,(parse-ALPHA (lambda (index char case lower upper) lower))
+                 ,(parse-repetition
+                   (lambda (index values reason-to-stop)
+                     values)
+                   0 #f
+                   (parse-alternative
+                    (lambda (index what value)
+                      value)
+                    `((alpha . ,(parse-ALPHA (lambda (index char case lower upper) lower)))
+                      (digit . ,(parse-DIGIT (lambda (index char value) char)))
+                      (dash . ,(parse-character-class
+                                (lambda (index c)
+                                  (if (eqv? c #\-)
+                                      c
+                                      (raise-exception
+                                       (make-exception
+                                        (make-failed-to-parse index)
+                                        (make-exception-with-origin 'parse-rulename)
+                                        (make-exception-with-message
+                                         (format #f (G_ "rule name characters that aren’t alpha or digits must be a dash, not ~a")
+                                                 c)))))))))))))))
+    (lambda (port)
+      (let ((base (base port)))
+        (lambda ()
+          (with-exception-handler
+              (lambda (error)
+                (raise-exception
+                 (make-exception
+                  (make-failed-to-parse-rulename (failed-to-parse-index error))
+                  (make-exception-with-origin 'parse-rulename)
+                  (make-exception-with-message
+                   (format #f (G_ "expected a rule name")))
+                  error)))
+            (lambda ()
+              (base))
+            #:unwind? #t
+            #:unwind-for-type &failed-to-parse-concatenation))))))
+
+(define-exception-type
+  &failed-to-parse-defined-as
+  &failed-to-parse
+  make-failed-to-parse-defined-as
+  failed-to-parse-defined-as?)
+
+(define (parse-= produce)
+  (parse-character-class
+   (lambda (index c)
+     (if (eqv? c #\=)
+         (produce index)
+         (raise-exception
+          (make-exception
+           (make-failed-to-parse index)
+           (make-exception-with-origin 'parse-defined-as)
+           (make-exception-with-message
+            (format #f (G_ "expected '=', got ~s" c)))))))))
+
+(define (parse-/ produce)
+  (parse-character-class
+   (lambda (index c)
+     (if (eqv? c #\/)
+         (produce index)
+         (raise-exception
+          (make-exception
+           (make-failed-to-parse index)
+           (make-exception-with-origin 'parse-defined-as)
+           (make-exception-with-message
+            (format #f (G_ "expected '/', got ~s" c)))))))))
+
+(define (parse-=/ produce)
+  (parse-concatenation
+   (lambda (index = /)
+     (produce index))
+   `(,(parse-= (lambda (index) #t))
+     ,(parse-/ (lambda (index) #t)))))
+
+
+(define (parse-defined-as)
+  (let ((base
+         (parse-concatenation
+          (lambda (index comment-left incremental? comment-right)
+            incremental?)
+          `(,(parse-*c-wsp)
+            ,(parse-alternative
+              (lambda (index what value)
+                value)
+              `((not-incremental . ,(parse-= (lambda (index) #f)))
+                (incremental . ,(parse-=/ (lambda (index) #t)))))
+            ,(parse-*c-wsp)))))
+    (lambda (port)
+      (let ((base (base port)))
+        (lambda ()
+          (with-exception-handler
+              (lambda (error)
+                (raise-exception
+                 (make-exception
+                  (make-failed-to-parse-defined-as (failed-to-parse-index error))
+                  (make-exception-with-origin 'parse-defined-as)
+                  (make-exception-with-message
+                   (format #f (G_ "expected either = or =/")))
+                  error)))
+            (lambda ()
+              (base))
+            #:unwind? #t
+            #:unwind-for-type &failed-to-parse-concatenation))))))
+
+(define-exception-type
+  &failed-to-parse-elements
+  &failed-to-parse
+  make-failed-to-parse-elements
+  failed-to-parse-elements?)
+
+(define* (parse-elements
+          #:key
+          produce-alternation
+          produce-concatenation
+          produce-repetition
+          produce-rulename
+          produce-literal
+          produce-prose)
+  (let ((base (parse-concatenation
+               (lambda (index alternation wsp)
+                 alternation)
+               `(,(parse-alternation
+                   #:produce-alternation produce-alternation
+                   #:produce-concatenation produce-concatenation
+                   #:produce-repetition produce-repetition
+                   #:produce-rulename produce-rulename
+                   #:produce-literal produce-literal
+                   #:produce-prose produce-prose)
+                 ,(parse-*c-wsp)))))
+    (lambda (port)
+      (let ((base (base port)))
+        (lambda ()
+          (with-exception-handler
+              (lambda (error)
+                (raise-exception
+                 (make-exception
+                  (make-failed-to-parse-elements (failed-to-parse-index error))
+                  (make-exception-with-origin 'parse-elements)
+                  (make-exception-with-message
+                   (format #f (G_ "expected a list of elements")))
+                  error)))
+            (lambda () (base))
+            #:unwind? #t
+            #:unwind-for-type &failed-to-parse))))))
+
+(define-exception-type
+  &failed-to-parse-c-wsp
+  &failed-to-parse
+  &make-failed-to-parse-c-wsp
+  failed-to-parse-c-wsp?)
+
+(define* (parse-c-wsp produce)
+  (let ((base
+         (parse-alternatives
+          (lambda (index what value)
+            (produce index value))
+          `((no-comment . ,(parse-WSP (lambda (index c) '())))
+            (with-comments
+             . ,(parse-concatenation
+                 (lambda (index nl wsp)
+                   nl)
+                 `(,(parse-c-nl) ,(parse-WSP (lambda (index c) #t)))))))))
+    (lambda (port)
+      (let ((base (base port)))
+        (lambda ()
+          (with-exception-handler
+              (lambda (error)
+                (raise-exception
+                 (make-exception
+                  (make-failed-to-parse-c-wsp (failed-to-parse-index error))
+                  (make-exception-with-origin 'parse-c-wsp)
+                  (make-exception-with-message
+                   (format #f (G_ "expected whitespace, possibly across multiple lines")))
+                  error)))
+            (lambda () (base))
+            #:unwind? #t
+            #:unwind-for-type &failed-to-parse))))))
+
+(define-exception-type
+  &failed-to-parse-c-nl
+  &failed-to-parse
+  make-failed-to-parse-c-nl
+  failed-to-parse-c-nl?)
+
+(define* (parse-c-nl)
+  (let ((base
+         (parse-alternatives
+          (lambda (index what value)
+            (case what
+              ((comment) (list value))
+              ((crlf) '())))
+          `((comment . ,(parse-comment))
+            (crlf . ,(parse-CRLF))))))
+    (lambda (port)
+      (let ((base (base port)))
+        (lambda ()
+          (with-exception-handler
+              (lambda (error)
+                (raise-exception
+                 (make-exception
+                  (make-failed-to-parse-c-nl (failed-to-parse-index error))
+                  (make-exception-with-origin 'parse-c-nl)
+                  (make-exception-with-message
+                   (format #f (G_ "expected a comment or a newline")))
+                  error)))
+            (lambda () (base))
+            #:unwind? #t
+            #:unwind-for-type &failed-to-parse))))))
+
+(define-exception-type
+  &failed-to-parse-comment
+  &failed-to-parse
+  make-failed-to-parse-comment
+  failed-to-parse-comment?)
+
+(define* (parse-comment)
+  (let ((base
+         (parse-concatenation
+          (lambda (index semicolon comment crlf)
+            (list->string (vector->list comment)))
+          `(,(parse-character-class
+              (lambda (index c)
+                (or (eqv? c #\;)
+                    (raise-exception
+                     (make-exception
+                      (make-failed-to-parse index)
+                      (make-exception-with-origin 'parse-comment)
+                      (make-exception-with-message
+                       (format #f (G_ "expected a semicolon to start a comment"))))))))
+            ,(parse-repetition
+              (lambda (index values reason-to-stop)
+                values)
+              0 #f
+              (parse-alternatives
+               (lambda (what value) value)
+               `((wsp . ,(parse-WSP (lambda (index c) c)))
+                 (vchar . ,(parse-VCHAR (lambda (index c) c))))))
+            ,(parse-CRLF (lambda (index) #t))))))
+    (lambda (port)
+      (let ((base (base port)))
+        (lambda ()
+          (with-exception-handler
+              (lambda (error)
+                (raise-exception
+                 (make-exception
+                  (make-failed-to-parse-comment (failed-to-parse-index error))
+                  (make-exception-with-origin 'parse-comment)
+                  (make-exception-with-message
+                   (format #f (G_ "expected a comment")))
+                  error)))
+            (lambda () (base))
+            #:unwind? #t
+            #:unwind-for-type &failed-to-parse))))))