31c17ae6769d79121e87d6d66b38dd8b64ea98c6
[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 #:export (parse-fail
32 parse-bind
33 parse-return
34 parse-lift
35 parse-map
36 parse-filter
37 parse-either
38 parse-both
39 parse-any
40 parse-each
41 parse-many
42 parse-string
43 parse-char-set
44 parse-whitespace
45 parse-delimited
46 parse-regexp
47 tagged-parser))
48
49 ;;;
50 ;;; Parser combinators
51 ;;;
52
53 (define (parse-fail stream)
54 "Always fail to parse STREAM without consuming any of it."
55 (values #f stream))
56
57 (define (parse-bind proc parser)
58 (lambda (stream)
59 (let-values (((result stream) (parser stream)))
60 (if result
61 ((proc result) stream)
62 (parse-fail stream)))))
63
64 (define (parse-return x)
65 "Return a parser that always yields X as the parse result."
66 (lambda (stream)
67 (values x stream)))
68
69 (define (parse-lift proc)
70 "Return a procedure that wraps the result of PROC in a parser."
71 (lambda args
72 (parse-return (apply proc args))))
73
74 (define (parse-map proc parser)
75 "Return a new parser that applies PROC to result of PARSER."
76 (parse-bind (parse-lift proc) parser))
77
78 (define (parse-filter predicate parser)
79 "Create a new parser that succeeds when PARSER is successful and
80 PREDICATE is satisfied with the result."
81 (lambda (stream)
82 (let-values (((result remaining) (parser stream)))
83 (if (and result (predicate result))
84 (values result remaining)
85 (parse-fail stream)))))
86
87 (define (parse-either first second)
88 "Create a parser that tries to parse with FIRST or, if that fails,
89 parses SECOND."
90 (lambda (stream)
91 (let-values (((result stream) (first stream)))
92 (if result
93 (values result stream)
94 (second stream)))))
95
96 (define (parse-both first second)
97 "Create a parser that returns a pair of the results of the parsers
98 FIRST and SECOND if both are successful."
99 (lambda (stream)
100 (let-values (((result1 stream) (first stream)))
101 (if result1
102 (let-values (((result2 stream) (second stream)))
103 (if result2
104 (values (cons result1 result2) stream)
105 (parse-fail stream)))
106 (parse-fail stream)))))
107
108 (define (parse-any . parsers)
109 "Create a parser that returns the result of the first successful
110 parser in PARSERS. This parser fails if no parser in PARSERS
111 succeeds."
112 (fold-right parse-either parse-fail parsers))
113
114 (define (parse-each . parsers)
115 "Create a parser that builds a list of the results of PARSERS. This
116 parser fails without consuming any input if any parser in PARSERS
117 fails."
118 (fold-right parse-both (parse-return '()) parsers))
119
120 (define (parse-many parser)
121 "Create a parser that uses PARSER as many times as possible until it
122 fails and return the results of each successful parse in a list. This
123 parser always succeeds."
124 (lambda (stream)
125 (let loop ((stream stream)
126 (results '()))
127 (let-values (((result remaining) (parser stream)))
128 (if result
129 (loop remaining (cons result results))
130 (values (reverse results)
131 remaining))))))
132
133 (define stream->string (compose list->string stream->list))
134
135 (define (parse-string str)
136 "Create a parser that succeeds when the front of the stream contains
137 the character sequence in STR."
138 (lambda (stream)
139 (let ((input (stream->string (stream-take (string-length str) stream))))
140 (if (string=? str input)
141 (values str (stream-drop (string-length str) stream))
142 (parse-fail stream)))))
143
144 (define (parse-char-set char-set)
145 "Create a parser that returns a string containing a contiguous
146 sequence of characters that belong to CHAR-SET."
147 (lambda (stream)
148 (let loop ((stream stream)
149 (result '()))
150 (define (stringify)
151 (if (null? result)
152 (parse-fail stream)
153 (values (list->string (reverse result))
154 stream)))
155
156 (stream-match stream
157 (() (stringify))
158 ((head . rest)
159 (if (char-set-contains? char-set head)
160 (loop rest (cons head result))
161 (stringify)))))))
162
163 (define parse-whitespace
164 (parse-char-set char-set:whitespace))
165
166 (define* (parse-delimited str #:key (until str) (escape #\\))
167 "Create a parser that parses a delimited character sequence
168 beginning with the string STR and ending with the string UNTIL.
169 Within the sequence, ESCAPE is recognized as the escape character."
170 (let ((parse-str (parse-string str))
171 (parse-until (parse-string until)))
172
173 (define (stringify lst stream)
174 (values (list->string (reverse lst))
175 stream))
176
177 (define (parse-until-maybe stream)
178 (let-values (((result remaining) (parse-until stream)))
179 (and result remaining)))
180
181 (lambda (stream)
182 (let-values (((result remaining) (parse-str stream)))
183 (if result
184 (let loop ((stream remaining)
185 (result (reverse (string->list str))))
186 (cond
187 ((stream-null? stream)
188 (stringify result stream))
189 ;; Escape character.
190 ((eqv? (stream-car stream) escape)
191 (stream-match (stream-cdr stream)
192 (() (stringify result stream-null))
193 ((head . rest)
194 (loop rest (cons* head escape result)))))
195 ((parse-until-maybe stream) =>
196 (lambda (remaining)
197 (stringify (append (reverse (string->list until)) result)
198 remaining)))
199 (else
200 (loop (stream-cdr stream) (cons (stream-car stream) result)))))
201 (parse-fail stream))))))
202
203 (define (parse-regexp regexp parser)
204 "Create a parser that succeeds if the result of PARSER is a string
205 that matches the string REGEXP."
206 (let ((rx (make-regexp regexp)))
207 (parse-filter (lambda (result)
208 (regexp-match? (regexp-exec rx result)))
209 parser)))
210
211 (define (tagged-parser tag parser)
212 "Create a parser that wraps the result of PARSER in a two element
213 list whose first element is TAG."
214 (parse-map (cut list tag <>) parser))