Add (syntax-highlight utils) module.
[guile-syntax-highlight.git] / syntax-highlight / parsers.scm
1 ;;; guile-syntax-highlight --- General-purpose syntax highlighter
2 ;;; Copyright © 2015 David Thompson <davet@gnu.org>
3 ;;;
4 ;;; Guile-syntax-highlight is free software; you can redistribute it
5 ;;; and/or modify it under the terms of the GNU Lesser General Public
6 ;;; License as published by the Free Software Foundation; either
7 ;;; version 3 of the License, or (at your option) any later version.
8 ;;;
9 ;;; Guile-syntax-highlight is distributed in the hope that it will be
10 ;;; useful, but WITHOUT ANY WARRANTY; without even the implied
11 ;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
12 ;;; See the GNU Lesser General Public License for more details.
13 ;;;
14 ;;; You should have received a copy of the GNU Lesser General Public
15 ;;; License along with guile-syntax-highlight. If not, see
16 ;;; <http://www.gnu.org/licenses/>.
17
18 ;;; Commentary:
19 ;;
20 ;; Parsing utilities.
21 ;;
22 ;;; Code:
23
24 (define-module (syntax-highlight parsers)
25 #:use-module (ice-9 match)
26 #:use-module (ice-9 regex)
27 #:use-module (srfi srfi-1)
28 #:use-module (srfi srfi-11)
29 #:use-module (srfi srfi-26)
30 #:use-module (srfi srfi-41)
31 #:use-module (syntax-highlight utils)
32 #:export (parse-fail
33 parse-bind
34 parse-return
35 parse-lift
36 parse-map
37 parse-filter
38 parse-either
39 parse-both
40 parse-any
41 parse-each
42 parse-maybe
43 parse-many
44 parse-string
45 parse-char-set
46 parse-whitespace
47 parse-delimited
48 parse-regexp
49 tagged-parser))
50
51 ;;;
52 ;;; Parser combinators
53 ;;;
54
55 (define (parse-fail stream)
56 "Always fail to parse STREAM without consuming any of it."
57 (values #f stream))
58
59 (define (parse-bind proc parser)
60 (lambda (stream)
61 (let-values (((result stream) (parser stream)))
62 (if result
63 ((proc result) stream)
64 (parse-fail stream)))))
65
66 (define (parse-return x)
67 "Return a parser that always yields X as the parse result."
68 (lambda (stream)
69 (values x stream)))
70
71 (define (parse-lift proc)
72 "Return a procedure that wraps the result of PROC in a parser."
73 (lambda args
74 (parse-return (apply proc args))))
75
76 (define (parse-map proc parser)
77 "Return a new parser that applies PROC to result of PARSER."
78 (parse-bind (parse-lift proc) parser))
79
80 (define (parse-filter predicate parser)
81 "Create a new parser that succeeds when PARSER is successful and
82 PREDICATE is satisfied with the result."
83 (lambda (stream)
84 (let-values (((result remaining) (parser stream)))
85 (if (and result (predicate result))
86 (values result remaining)
87 (parse-fail stream)))))
88
89 (define (parse-either first second)
90 "Create a parser that tries to parse with FIRST or, if that fails,
91 parses SECOND."
92 (lambda (stream)
93 (let-values (((result remaining) (first stream)))
94 (if result
95 (values result remaining)
96 (second stream)))))
97
98 (define (parse-both first second)
99 "Create a parser that returns a pair of the results of the parsers
100 FIRST and SECOND if both are successful."
101 (lambda (stream)
102 (let-values (((result1 remaining) (first stream)))
103 (if result1
104 (let-values (((result2 remaining) (second remaining)))
105 (if result2
106 (values (cons result1 result2) remaining)
107 (parse-fail stream)))
108 (parse-fail stream)))))
109
110 (define (parse-any . parsers)
111 "Create a parser that returns the result of the first successful
112 parser in PARSERS. This parser fails if no parser in PARSERS
113 succeeds."
114 (fold-right parse-either parse-fail parsers))
115
116 (define (parse-each . parsers)
117 "Create a parser that builds a list of the results of PARSERS. This
118 parser fails without consuming any input if any parser in PARSERS
119 fails."
120 (fold-right parse-both (parse-return '()) parsers))
121
122 (define (parse-maybe parser)
123 "Create a parser that always succeeds, but tries to use PARSER. If
124 PARSER succeeds, its result is returned, otherwise the empty string is
125 returned without consuming any input."
126 (lambda (stream)
127 (let-values (((result remaining) (parser stream)))
128 (if result
129 (values result remaining)
130 (values "" stream)))))
131
132 (define (parse-many parser)
133 "Create a parser that uses PARSER as many times as possible until it
134 fails and return the results of each successful parse in a list. This
135 parser always succeeds."
136 (lambda (stream)
137 (let loop ((stream stream)
138 (results '()))
139 (let-values (((result remaining) (parser stream)))
140 (if result
141 (loop remaining (cons result results))
142 (values (reverse results)
143 remaining))))))
144
145 (define (parse-string str)
146 "Create a parser that succeeds when the front of the stream contains
147 the character sequence in STR."
148 (lambda (stream)
149 (let ((input (stream->string (stream-take (string-length str) stream))))
150 (if (string=? str input)
151 (values str (stream-drop (string-length str) stream))
152 (parse-fail stream)))))
153
154 (define (parse-char-set char-set)
155 "Create a parser that returns a string containing a contiguous
156 sequence of characters that belong to CHAR-SET."
157 (lambda (stream)
158 (let loop ((stream stream)
159 (result '()))
160 (define (stringify)
161 (if (null? result)
162 (parse-fail stream)
163 (values (list->string (reverse result))
164 stream)))
165
166 (stream-match stream
167 (() (stringify))
168 ((head . rest)
169 (if (char-set-contains? char-set head)
170 (loop rest (cons head result))
171 (stringify)))))))
172
173 (define parse-whitespace
174 (parse-char-set char-set:whitespace))
175
176 (define* (parse-delimited str #:key (until str) (escape #\\))
177 "Create a parser that parses a delimited character sequence
178 beginning with the string STR and ending with the string UNTIL.
179 Within the sequence, ESCAPE is recognized as the escape character."
180 (let ((parse-str (parse-string str))
181 (parse-until (parse-string until)))
182
183 (define (stringify lst stream)
184 (values (list->string (reverse lst))
185 stream))
186
187 (define (parse-until-maybe stream)
188 (let-values (((result remaining) (parse-until stream)))
189 (and result remaining)))
190
191 (lambda (stream)
192 (let-values (((result remaining) (parse-str stream)))
193 (if result
194 (let loop ((stream remaining)
195 (result (reverse (string->list str))))
196 (cond
197 ((stream-null? stream)
198 (stringify result stream))
199 ;; Escape character.
200 ((eqv? (stream-car stream) escape)
201 (stream-match (stream-cdr stream)
202 (() (stringify result stream-null))
203 ((head . rest)
204 (loop rest (cons* head escape result)))))
205 ((parse-until-maybe stream) =>
206 (lambda (remaining)
207 (stringify (append (reverse (string->list until)) result)
208 remaining)))
209 (else
210 (loop (stream-cdr stream) (cons (stream-car stream) result)))))
211 (parse-fail stream))))))
212
213 (define (parse-regexp regexp parser)
214 "Create a parser that succeeds if the result of PARSER is a string
215 that matches the string REGEXP."
216 (let ((rx (make-regexp regexp)))
217 (parse-filter (lambda (result)
218 (regexp-match? (regexp-exec rx result)))
219 parser)))
220
221 (define (tagged-parser tag parser)
222 "Create a parser that wraps the result of PARSER in a two element
223 list whose first element is TAG."
224 (parse-map (cut list tag <>) parser))