blob: e0522dd8bb05ac01819a8b5d9ffe6c70ae506123 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
|
;;; 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-match
parse-any
parse-each
parse-zero-or-more
parse-one-or-more
parse-up-to
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-syntax-rule (parse-match parser matchers ...)
(parse-map (match-lambda matchers ...) 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)))))))
(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)))))))))
;; parse-any and parse-seach are special forms to abstract 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-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-up-to n parser)
"Parse using PARSER at most N times."
(lambda (stream)
(let loop ((stream stream)
(m 0))
(if (= m n)
'()
(match (parser stream)
((? parse-failure?) '())
(($ <parse-result> value stream)
(cons value (loop stream (1+ m)))))))))
(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))))
|
