summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--README46
-rw-r--r--parser-combinators.scm182
-rw-r--r--tests.scm56
3 files changed, 284 insertions, 0 deletions
diff --git a/README b/README
new file mode 100644
index 0000000..41f3d03
--- /dev/null
+++ b/README
@@ -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")