Initial commit.

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")