diff options
| -rw-r--r-- | README | 46 | ||||
| -rw-r--r-- | parser-combinators.scm | 182 | ||||
| -rw-r--r-- | tests.scm | 56 |
3 files changed, 284 insertions, 0 deletions
@@ -0,0 +1,46 @@ +-*- org -*- + +Guile Parser Combinators + +* About + + A simple, SRFI-41 stream-based, monadic parser combinator library + for Guile Scheme. + +* Example + + #+BEGIN_SRC scheme + (define stream->string (compose list->string stream->list)) + + (define (parse-string str) + (lambda (stream) + (let ((input (stream->string (stream-take (string-length str) stream)))) + (if (string=? str input) + (parse-result str (stream-drop (string-length str) stream)) + %parse-failure)))) + + (define article + (parse-any (parse-string "the ") (parse-string "a "))) + + (define noun + (parse-any (parse-string "student ") (parse-string "professor "))) + + (define verb + (parse-any (parse-string "studies ") (parse-string "lectures "))) + + (define noun-phrase + (parse-each article noun)) + + (define verb-phrase + (parse-each verb noun-phrase)) + + (define sentence + (parse-each noun-phrase verb-phrase)) + + (parse noun-phrase "the professor ") + (parse sentence "the professor lectures the student ") + #+END_SRC + +* License + + GNU LGPL3+ diff --git a/parser-combinators.scm b/parser-combinators.scm new file mode 100644 index 0000000..3c4958e --- /dev/null +++ b/parser-combinators.scm @@ -0,0 +1,182 @@ +;;; Guile Parser Combinators +;;; Copyright © 2015 David Thompson <davet@gnu.org> +;;; +;;; This module 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 module 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 module. If not, see +;;; <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Monadic parser combinators. +;; +;;; Code: + +(define-module (parser-combinators) + #:use-module (ice-9 match) + #:use-module (ice-9 q) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-41) + #:export (parse-result + parse-result? + parse-result-value + parse-result-index + parse-failure? + parse-success? + %parse-failure + parse-fail + parse-end + parse-bind + parse-return + parse-lift + parse-map + parse-any + parse-each + parse-zero-or-more + parse-one-or-more + parse-maybe + parse)) + +(define-record-type <parse-result> + (parse-result value stream) + parse-result? + (value parse-result-value) + (stream parse-result-stream)) + +(define (parse-failure? result) + "Return #t if RESULT represents a failed parse." + (not (parse-result-stream result))) + +(define (parse-success? result) + "Return #t if RESULT represents a successful parse." + (stream? (parse-result-stream result))) + +(define (parse-done? result) + "Return #t if the remainder of RESULT is the empty stream." + (stream-null? (parse-result-stream result))) + +(define %parse-failure (parse-result #f #f)) + +(define (parse-fail stream) + "Always fail to parse STREAM." + %parse-failure) + +(define (parse-end stream) + (if (stream-null? stream) + (parse-result #t stream-null) + %parse-failure)) + +(define (parse-bind proc parser) + (lambda (stream) + (match (parser stream) + ((? parse-failure? _) %parse-failure) + (($ <parse-result> value stream) + ((proc value) stream))))) + +(define (parse-return x) + "Return a parser that always yields X as the parse result." + (lambda (stream) + (parse-result x stream))) + +(define (parse-lift proc) + "Return a procedure that wraps the result of PROC in a parser." + (lambda args + (parse-return (apply proc args)))) + +(define (parse-map proc parser) + "Return a new parser that applies PROC to result of PARSER." + (parse-bind (parse-lift proc) parser)) + +(define (%parse-any . parsers) + (lambda (stream) + (let loop ((parsers parsers)) + (match parsers + (() %parse-failure) + ((parser . rest) + (match ((force parser) stream) + ((? parse-failure? _) + (loop rest)) + (result result))))))) + +;; This is a special form due to the lazy evaluation used to handle +;; right recursive grammars. +(define-syntax-rule (parse-any parser ...) + "Create a disjunctive parser that succeeds if any of the input +parsers succeed." + (%parse-any (delay parser) ...)) + +(define (%parse-each . parsers) + (lambda (stream) + (let loop ((stream stream) + (parsers parsers) + (result '())) + (match parsers + (() (parse-result (reverse result) stream)) + ((parser . rest) + (match ((force parser) stream) + ((? parse-failure?) %parse-failure) + (($ <parse-result> value stream) + (loop stream rest (cons value result))))))))) + +(define-syntax-rule (parse-each parser ...) + (%parse-each (delay parser) ...)) + +(define (parse-zero-or-more parser) + (lambda (stream) + (let loop ((stream stream) + (result '())) + (match (parser stream) + ((? parse-failure?) + (parse-result (reverse result) stream)) + (($ <parse-result> value stream) + (loop stream (cons value result))))))) + +(define (parse-one-or-more parser) + (lambda (stream) + (let loop ((stream stream) + (result '())) + (match (parser stream) + ((? parse-failure?) + (if (null? result) + %parse-failure + (parse-result (reverse result) stream))) + (($ <parse-result> value stream) + (loop stream (cons value result))))))) + +(define* (parse-maybe parser #:optional (default #f)) + (lambda (stream) + (match (parser stream) + ((? parse-failure?) + (parse-result default stream)) + (result result)))) + +(define (string->stream str) + "Convert the string STR into a stream of characters." + (stream-map (lambda (i) + (string-ref str i)) + (stream-range 0 (string-length str)))) + +(define* (parse parser obj #:optional (fail-value #f)) + "Parse the contents of OBJ with PARSER. OBJ may be either a string, port, +or stream." + (let ((stream (match obj + ;; Handle strings and ports as a convenience. + ((? string? str) (string->stream str)) + ((? port? port) (port->stream port)) + ((? stream? stream) stream)))) + (match (parser stream) + ((or (? parse-failure?) + (not (? parse-done?))) + fail-value) + (($ <parse-result> value _) value)))) diff --git a/tests.scm b/tests.scm new file mode 100644 index 0000000..bd6a456 --- /dev/null +++ b/tests.scm @@ -0,0 +1,56 @@ +(define-module (tests) + #:use-module (srfi srfi-64) + #:use-module (parser-combinators)) + +(test-begin "parser-combinators") + +(test-assert "parse-failure?" (parse-failure? %parse-failure)) + +(test-group "parse-success?" + (test-assert (parse-success? (parse-result "" 0))) + (test-assert (not (parse-success? %parse-failure)))) + +(test-equal "parse-fail" (parse-fail "foo" 0) %parse-failure) + +(test-equal "parse-return" + ((parse-return "foo") "bar" 0) + (parse-result "foo" 0)) + +(test-equal "parse-lift" + (let ((parser ((parse-lift string-reverse) "foo"))) + (parser "bar" 0)) + (parse-result "oof" 0)) + +(test-group "parse-bind" + (let ((parse-reverse (parse-lift string-reverse))) + (test-equal (let ((parser (parse-bind (parse-return "foo") parse-reverse))) + (parser "bar" 0)) + (parse-result "oof" 0)) + (test-equal ((parse-bind parse-fail parse-reverse) "bar" 0) + %parse-failure))) + +(test-group "parse-alt" + (test-equal ((parse-alt) "foo" 0) %parse-failure) + (test-equal ((parse-alt (parse-return "bar") parse-fail) "foo" 0) + (parse-result "bar" 0)) + (test-equal ((parse-alt parse-fail (parse-return "bar")) "foo" 0) + (parse-result "bar" 0))) + +(test-group "parse-seq" + (test-equal ((parse-seq) "foo" 0) + (parse-result '() 0)) + (test-equal ((parse-seq (parse-return "bar")) "foo" 0) + (parse-result '("bar") 0)) + (test-equal ((parse-seq (parse-return "bar") (parse-return "baz")) "foo" 0) + (parse-result '("bar" "baz") 0)) + (test-equal ((parse-seq (parse-return "bar") parse-fail) "foo" 0) + %parse-failure) + (test-equal ((parse-seq parse-fail (parse-return "bar")) "foo" 0) + %parse-failure)) + +(test-group "parse" + (test-equal (parse (parse-return "foo") "bar") "foo") + (test-equal (parse parse-fail "foo") #f) + (test-equal (parse parse-fail "foo" 'oops) 'oops)) + +(test-end "parser-combinators") |