summaryrefslogtreecommitdiff
path: root/module/ice-9/peg/string-peg.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/ice-9/peg/string-peg.scm')
-rw-r--r--module/ice-9/peg/string-peg.scm273
1 files changed, 273 insertions, 0 deletions
diff --git a/module/ice-9/peg/string-peg.scm b/module/ice-9/peg/string-peg.scm
new file mode 100644
index 000000000..45ed14bb1
--- /dev/null
+++ b/module/ice-9/peg/string-peg.scm
@@ -0,0 +1,273 @@
+;;;; string-peg.scm --- representing PEG grammars as strings
+;;;;
+;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library 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
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;;
+
+(define-module (ice-9 peg string-peg)
+ #:export (peg-as-peg
+ define-peg-string-patterns
+ peg-grammar)
+ #:use-module (ice-9 peg using-parsers)
+ #:use-module (ice-9 peg codegen)
+ #:use-module (ice-9 peg simplify-tree))
+
+;; Gets the left-hand depth of a list.
+(define (depth lst)
+ (if (or (not (list? lst)) (null? lst))
+ 0
+ (+ 1 (depth (car lst)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;; Parse string PEGs using sexp PEGs.
+;; See the variable PEG-AS-PEG for an easier-to-read syntax.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; Grammar for PEGs in PEG grammar.
+(define peg-as-peg
+"grammar <-- (nonterminal ('<--' / '<-' / '<') sp pattern)+
+pattern <-- alternative (SLASH sp alternative)*
+alternative <-- ([!&]? sp suffix)+
+suffix <-- primary ([*+?] sp)*
+primary <-- '(' sp pattern ')' sp / '.' sp / literal / charclass / nonterminal !'<'
+literal <-- ['] (!['] .)* ['] sp
+charclass <-- LB (!']' (CCrange / CCsingle))* RB sp
+CCrange <-- . '-' .
+CCsingle <-- .
+nonterminal <-- [a-zA-Z0-9-]+ sp
+sp < [ \t\n]*
+SLASH < '/'
+LB < '['
+RB < ']'
+")
+
+(define-syntax define-sexp-parser
+ (lambda (x)
+ (syntax-case x ()
+ ((_ sym accum pat)
+ (let* ((matchf (compile-peg-pattern #'pat (syntax->datum #'accum)))
+ (accumsym (syntax->datum #'accum))
+ (syn (wrap-parser-for-users x matchf accumsym #'sym)))
+ #`(define sym #,syn))))))
+
+(define-sexp-parser peg-grammar all
+ (+ (and peg-nonterminal (or "<--" "<-" "<") peg-sp peg-pattern)))
+(define-sexp-parser peg-pattern all
+ (and peg-alternative
+ (* (and (ignore "/") peg-sp peg-alternative))))
+(define-sexp-parser peg-alternative all
+ (+ (and (? (or "!" "&")) peg-sp peg-suffix)))
+(define-sexp-parser peg-suffix all
+ (and peg-primary (* (and (or "*" "+" "?") peg-sp))))
+(define-sexp-parser peg-primary all
+ (or (and "(" peg-sp peg-pattern ")" peg-sp)
+ (and "." peg-sp)
+ peg-literal
+ peg-charclass
+ (and peg-nonterminal (not-followed-by "<"))))
+(define-sexp-parser peg-literal all
+ (and "'" (* (and (not-followed-by "'") peg-any)) "'" peg-sp))
+(define-sexp-parser peg-charclass all
+ (and (ignore "[")
+ (* (and (not-followed-by "]")
+ (or charclass-range charclass-single)))
+ (ignore "]")
+ peg-sp))
+(define-sexp-parser charclass-range all (and peg-any "-" peg-any))
+(define-sexp-parser charclass-single all peg-any)
+(define-sexp-parser peg-nonterminal all
+ (and (+ (or (range #\a #\z) (range #\A #\Z) (range #\0 #\9) "-")) peg-sp))
+(define-sexp-parser peg-sp none
+ (* (or " " "\t" "\n")))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;; PARSE STRING PEGS
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; Takes a string representing a PEG grammar and returns syntax that
+;; will define all of the nonterminals in the grammar with equivalent
+;; PEG s-expressions.
+(define (peg-parser str for-syntax)
+ (let ((parsed (match-pattern peg-grammar str)))
+ (if (not parsed)
+ (begin
+ ;; (display "Invalid PEG grammar!\n")
+ #f)
+ (let ((lst (peg:tree parsed)))
+ (cond
+ ((or (not (list? lst)) (null? lst))
+ lst)
+ ((eq? (car lst) 'peg-grammar)
+ #`(begin
+ #,@(map (lambda (x) (peg-nonterm->defn x for-syntax))
+ (context-flatten (lambda (lst) (<= (depth lst) 2))
+ (cdr lst))))))))))
+
+;; Macro wrapper for PEG-PARSER. Parses PEG grammars expressed as strings and
+;; defines all the appropriate nonterminals.
+(define-syntax define-peg-string-patterns
+ (lambda (x)
+ (syntax-case x ()
+ ((_ str)
+ (peg-parser (syntax->datum #'str) x)))))
+
+;; lst has format (nonterm grabber pattern), where
+;; nonterm is a symbol (the name of the nonterminal),
+;; grabber is a string (either "<", "<-" or "<--"), and
+;; pattern is the parse of a PEG pattern expressed as as string.
+(define (peg-nonterm->defn lst for-syntax)
+ (let* ((nonterm (car lst))
+ (grabber (cadr lst))
+ (pattern (caddr lst))
+ (nonterm-name (datum->syntax for-syntax
+ (string->symbol (cadr nonterm)))))
+ #`(define-peg-pattern #,nonterm-name
+ #,(cond
+ ((string=? grabber "<--") (datum->syntax for-syntax 'all))
+ ((string=? grabber "<-") (datum->syntax for-syntax 'body))
+ (else (datum->syntax for-syntax 'none)))
+ #,(compressor (peg-pattern->defn pattern for-syntax) for-syntax))))
+
+;; lst has format ('peg-pattern ...).
+;; After the context-flatten, (cdr lst) has format
+;; (('peg-alternative ...) ...), where the outer list is a collection
+;; of elements from a '/' alternative.
+(define (peg-pattern->defn lst for-syntax)
+ #`(or #,@(map (lambda (x) (peg-alternative->defn x for-syntax))
+ (context-flatten (lambda (x) (eq? (car x) 'peg-alternative))
+ (cdr lst)))))
+
+;; lst has format ('peg-alternative ...).
+;; After the context-flatten, (cdr lst) has the format
+;; (item ...), where each item has format either ("!" ...), ("&" ...),
+;; or ('peg-suffix ...).
+(define (peg-alternative->defn lst for-syntax)
+ #`(and #,@(map (lambda (x) (peg-body->defn x for-syntax))
+ (context-flatten (lambda (x) (or (string? (car x))
+ (eq? (car x) 'peg-suffix)))
+ (cdr lst)))))
+
+;; lst has the format either
+;; ("!" ('peg-suffix ...)), ("&" ('peg-suffix ...)), or
+;; ('peg-suffix ...).
+(define (peg-body->defn lst for-syntax)
+ (cond
+ ((equal? (car lst) "&")
+ #`(followed-by #,(peg-suffix->defn (cadr lst) for-syntax)))
+ ((equal? (car lst) "!")
+ #`(not-followed-by #,(peg-suffix->defn (cadr lst) for-syntax)))
+ ((eq? (car lst) 'peg-suffix)
+ (peg-suffix->defn lst for-syntax))
+ (else `(peg-parse-body-fail ,lst))))
+
+;; lst has format ('peg-suffix <peg-primary> (? (/ "*" "?" "+")))
+(define (peg-suffix->defn lst for-syntax)
+ (let ((inner-defn (peg-primary->defn (cadr lst) for-syntax)))
+ (cond
+ ((null? (cddr lst))
+ inner-defn)
+ ((equal? (caddr lst) "*")
+ #`(* #,inner-defn))
+ ((equal? (caddr lst) "?")
+ #`(? #,inner-defn))
+ ((equal? (caddr lst) "+")
+ #`(+ #,inner-defn)))))
+
+;; Parse a primary.
+(define (peg-primary->defn lst for-syntax)
+ (let ((el (cadr lst)))
+ (cond
+ ((list? el)
+ (cond
+ ((eq? (car el) 'peg-literal)
+ (peg-literal->defn el for-syntax))
+ ((eq? (car el) 'peg-charclass)
+ (peg-charclass->defn el for-syntax))
+ ((eq? (car el) 'peg-nonterminal)
+ (datum->syntax for-syntax (string->symbol (cadr el))))))
+ ((string? el)
+ (cond
+ ((equal? el "(")
+ (peg-pattern->defn (caddr lst) for-syntax))
+ ((equal? el ".")
+ (datum->syntax for-syntax 'peg-any))
+ (else (datum->syntax for-syntax
+ `(peg-parse-any unknown-string ,lst)))))
+ (else (datum->syntax for-syntax
+ `(peg-parse-any unknown-el ,lst))))))
+
+;; Trims characters off the front and end of STR.
+;; (trim-1chars "'ab'") -> "ab"
+(define (trim-1chars str) (substring str 1 (- (string-length str) 1)))
+
+;; Parses a literal.
+(define (peg-literal->defn lst for-syntax)
+ (datum->syntax for-syntax (trim-1chars (cadr lst))))
+
+;; Parses a charclass.
+(define (peg-charclass->defn lst for-syntax)
+ #`(or
+ #,@(map
+ (lambda (cc)
+ (cond
+ ((eq? (car cc) 'charclass-range)
+ #`(range #,(datum->syntax
+ for-syntax
+ (string-ref (cadr cc) 0))
+ #,(datum->syntax
+ for-syntax
+ (string-ref (cadr cc) 2))))
+ ((eq? (car cc) 'charclass-single)
+ (datum->syntax for-syntax (cadr cc)))))
+ (context-flatten
+ (lambda (x) (or (eq? (car x) 'charclass-range)
+ (eq? (car x) 'charclass-single)))
+ (cdr lst)))))
+
+;; Compresses a list to save the optimizer work.
+;; e.g. (or (and a)) -> a
+(define (compressor-core lst)
+ (if (or (not (list? lst)) (null? lst))
+ lst
+ (cond
+ ((and (or (eq? (car lst) 'or) (eq? (car lst) 'and))
+ (null? (cddr lst)))
+ (compressor-core (cadr lst)))
+ ((and (eq? (car lst) 'body)
+ (eq? (cadr lst) 'lit)
+ (eq? (cadddr lst) 1))
+ (compressor-core (caddr lst)))
+ (else (map compressor-core lst)))))
+
+(define (compressor syn for-syntax)
+ (datum->syntax for-syntax
+ (compressor-core (syntax->datum syn))))
+
+;; Builds a lambda-expressions for the pattern STR using accum.
+(define (peg-string-compile args accum)
+ (syntax-case args ()
+ ((str-stx) (string? (syntax->datum #'str-stx))
+ (let ((string (syntax->datum #'str-stx)))
+ (compile-peg-pattern
+ (compressor
+ (peg-pattern->defn
+ (peg:tree (match-pattern peg-pattern string)) #'str-stx)
+ #'str-stx)
+ (if (eq? accum 'all) 'body accum))))
+ (else (error "Bad embedded PEG string" args))))
+
+(add-peg-compiler! 'peg peg-string-compile)
+