Initial commit.

1 files changed, 182 insertions, 0 deletions

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