From d0fce362dbdc3f8c8952cd1c4bbda77e5c72ed50 Mon Sep 17 00:00:00 2001 From: Vivien Kraus Date: Tue, 2 Nov 2021 11:33:03 +0100 Subject: [WIP] Bootstrap an ABNF backtracking parser --- src/scm/webid-oidc/Makefile.am | 6 +- src/scm/webid-oidc/abnf-bootstrap.scm | 1067 +++++++++++++++++++++++++++++++++ 2 files changed, 1071 insertions(+), 2 deletions(-) create mode 100644 src/scm/webid-oidc/abnf-bootstrap.scm 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 . + +(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)))))) -- cgit v1.2.3