From 10aa42dfd1db3669c19ec1f82a1475d371962dad Mon Sep 17 00:00:00 2001 From: David Thompson Date: Sun, 9 Aug 2015 10:36:33 -0400 Subject: Initial commit. --- parser-combinators.scm | 182 +++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 182 insertions(+) create mode 100644 parser-combinators.scm (limited to 'parser-combinators.scm') 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 +;;; +;;; 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 +;;; . + +;;; 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 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) + (($ 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) + (($ 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)) + (($ 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))) + (($ 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) + (($ value _) value)))) -- cgit v1.2.3