Add more general purpose parsers.

1 files changed, 90 insertions, 23 deletions

diff --git a/parser-combinators.scm b/parser-combinators.scm
index e0522dd..1b8c960 100644
--- a/parser-combinators.scm
+++ b/parser-combinators.scm
@@ -40,6 +40,8 @@
             parse-bind
             parse-return
             parse-lift
+            parse
+
             parse-map
             parse-match
             parse-any
@@ -48,7 +50,14 @@
             parse-one-or-more
             parse-up-to
             parse-maybe
-            parse))
+            parse-any-char
+            parse-char
+            parse-char-set
+            parse-string))
+
+;;;
+;;; Core
+;;;
 
 (define-record-type <parse-result>
   (parse-result value stream)
@@ -96,11 +105,39 @@
   (lambda args
     (parse-return (apply proc args))))
 
+(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))))
+
+
+;;;
+;;; Extras
+;;;
+
 (define (parse-map proc parser)
   "Return a new parser that applies PROC to result of PARSER."
   (parse-bind (parse-lift proc) parser))
 
 (define-syntax-rule (parse-match parser matchers ...)
+  "Create a parser that applies pattern matching to transform the
+successful results of PARSER using MATCHERS.  MATCHERS uses the (ice-9
+match) pattern matching syntax."
   (parse-map (match-lambda matchers ...) parser))
 
 (define (%parse-any . parsers)
@@ -135,9 +172,13 @@ parsers succeed."
   (%parse-any (delay parser) ...))
 
 (define-syntax-rule (parse-each parser ...)
+  "Create a sequential parser that returns a list of parse results if
+all of the input parsers succeed."
   (%parse-each (delay parser) ...))
 
 (define (parse-zero-or-more parser)
+  "Create a parser that applies PARSER as many times as it can before
+failing and returns list of the successful parse results."
   (lambda (stream)
     (let loop ((stream stream)
                (result '()))
@@ -148,6 +189,9 @@ parsers succeed."
          (loop stream (cons value result)))))))
 
 (define (parse-one-or-more parser)
+  "Return a parser that succeeds when PARSER can be successfully
+applied at least once and returns a list of the successful parse
+results."
   (lambda (stream)
     (let loop ((stream stream)
                (result '()))
@@ -160,40 +204,63 @@ parsers succeed."
          (loop stream (cons value result)))))))
 
 (define (parse-up-to n parser)
-  "Parse using PARSER at most N times."
+  "Create a parser that applies PARSER at most N times and returns a
+list of the successful parse results."
   (lambda (stream)
     (let loop ((stream stream)
-               (m 0))
-      (if (= m n)
+               (n n))
+      (if (zero? n)
           '()
           (match (parser stream)
                ((? parse-failure?) '())
                (($ <parse-result> value stream)
-                (cons value (loop stream (1+ m)))))))))
+                (cons value (loop stream (1- n)))))))))
 
 (define* (parse-maybe parser #:optional (default #f))
+  "Create a parser that returns the result of PARSER upon success, or
+DEFAULT upon failure."
   (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-any-char stream)
+  "Parse any single character or fail if STREAM is empty."
+  (stream-match stream
+    (() %parse-failure)
+    ((head . tail)
+     (parse-result head tail))))
 
-(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))))
+(define (parse-char c)
+  "Create a parser that succeeds when the next character in the stream
+is C."
+  (lambda (stream)
+    (stream-match stream
+      (() %parse-failure)
+      ((head . tail)
+       (if (equal? head c)
+           (parse-result head tail)
+           %parse-failure)))))
+
+(define (parse-char-set char-set)
+  "Create a parser that succeeds when the next character in the stream
+is a member of CHAR-SET."
+  (lambda (stream)
+    (stream-match stream
+      (() %parse-failure)
+      ((char . tail)
+       (if (char-set-contains? char-set char)
+           (parse-result char tail)
+           %parse-failure)))))
+
+(define stream->string (compose list->string stream->list))
+
+(define (parse-string str)
+  "Create a parser that succeeds when the front of the stream contains
+the character sequence in 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))))