Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 581 lines (462 sloc) 15.003 kb
9b284ac @VincentToups Monadic parser update, bug fixes.
authored
1 (require 'monads)
2 (require 'utils)
3 (require 'eieio)
4 (require 'cl)
9dabfe0 @VincentToups microstack first
authored
5 (require 'defn)
b85fabe @VincentToups made monad-parse independent of defn
authored
6 (require 'functional)
9b284ac @VincentToups Monadic parser update, bug fixes.
authored
7
b85fabe @VincentToups made monad-parse independent of defn
authored
8 ;; (defn parser-bind [parser fun]
9 ;; (fn [input]
10 ;; (loop for (value . input) in (funcall parser input)
11 ;; append (funcall (funcall fun value) input))))
9b284ac @VincentToups Monadic parser update, bug fixes.
authored
12
9dabfe0 @VincentToups microstack first
authored
13 (defun parser-bind (parser fun)
14 (lexical-let ((parser parser)
15 (fun fun))
16 (lambda (input)
17 (lexical-let ((input input))
18 (loop for (value . input) in (funcall parser input)
19 append (funcall (funcall fun value) input))))))
20
2d28bac @VincentToups Warning update, monad madness
authored
21 (defn parser-return [val]
22 (fn [input]
fb6606c @VincentToups monad revisions.
authored
23 (list (cons val input))))
2d28bac @VincentToups Warning update, monad madness
authored
24
25 ;; (defun parser-return (val)
26 ;; (lexical-let ((val val))
27 ;; (lambda (input)
28 ;; (list (cons val input)))))
29
30 (defun parser-zero (&optional val)
31 (lambda (input)
32 (lexical-let ((input input))
33 (list (cons nil input)))))
9b284ac @VincentToups Monadic parser update, bug fixes.
authored
34
35 (setq monad-parse
36 (tbl!
37 :m-return #'parser-return
38 :m-bind #'parser-bind))
39
40 (defclass <parser-input-string> ()
41 ((data :accessor string-of :initarg :string)
42 (ix :accessor index-of :initarg :index :initform 0)))
43
aabfc88 @VincentToups multi-method update, utils added.
authored
44
d09d144 @VincentToups fixed, at least, recur.
authored
45
46
9b284ac @VincentToups Monadic parser update, bug fixes.
authored
47 (defmethod input-empty? ((input <parser-input-string>))
48 (= (length (string-of input)) (index-of input)))
49 (defmethod input-empty-p ((input <parser-input-string>))
50 (= (length (string-of input)) (index-of input)))
51
52 (defmethod input-first ((input <parser-input-string>))
53 (elt (string-of input) (index-of input)))
54
55 (defmethod input-rest ((input <parser-input-string>))
56 (make-instance '<parser-input-string> :string
57 (string-of input)
58 :index (+ 1 (index-of input))))
59
aabfc88 @VincentToups multi-method update, utils added.
authored
60 (defclass <parser-input-sequence> ()
61 ((data :accessor seq-of :initarg :seq)
62 (ix :accessor index-of :initarg :index :initform 0)))
63
64 (defmethod input-empty? ((input <parser-input-sequence>))
65 (= (length (seq-of input)) (index-of input)))
66 (defmethod input-empty-p ((input <parser-input-sequence>))
67 (= (length (seq-of input)) (index-of input)))
68 (defmethod input-first ((input <parser-input-sequence>))
69 (elt (seq-of input) (index-of input)))
70 (defmethod input-rest ((input <parser-input-sequence>))
71 (make-instance '<parser-input-sequence> :seq
72 (seq-of input)
73 :index (+ 1 (index-of input))))
74
75
76
d356d1b @VincentToups Lots of new documentation.
authored
77 (defclass <parser-input-buffer> ()
78 ((buffer :accessor buffer-of :initarg :buffer)
79 (ix :accessor index-of :initarg :index :initform 1)))
80
81 (defmethod input-empty-p ((input <parser-input-buffer>))
82 (with-current-buffer (buffer-of input)
83 (if (= (index-of input) (point-max)) t nil)))
84
85 (defmethod input-empty? ((input <parser-input-buffer>))
86 (with-current-buffer (buffer-of input)
87 (if (= (index-of input) (point-max)) t nil)))
88
89 (defmethod input-first ((input <parser-input-buffer>))
90 (with-current-buffer
91 (buffer-of input)
92 (let ((ix (index-of input)))
93 (elt (buffer-substring ix (+ 1 ix)) 0))))
94
95 (defmethod input-rest ((input <parser-input-buffer>))
96 (make-instance '<parser-input-buffer>
97 :buffer (buffer-of input)
98 :index (+ (index-of input) 1)))
99
100 (defmethod input-as-string ((input <parser-input-buffer>))
101 (with-current-buffer/save-excursion
102 (buffer-of input)
103 (buffer-substring (index-of input) (- (point-max) 1))))
104
9dabfe0 @VincentToups microstack first
authored
105 (defun input->string (input)
106 (if input (input-as-string input) nil))
107
aabfc88 @VincentToups multi-method update, utils added.
authored
108 (defmethod input-as-list ((input <parser-input-sequence>))
109 (elts (seq-of input)
110 (range (index-of input)
111 (length (seq-of input)))))
9dabfe0 @VincentToups microstack first
authored
112
d356d1b @VincentToups Lots of new documentation.
authored
113 (defun buffer->parser-input (buffer-or-name)
114 (make-instance '<parser-input-buffer>
115 :buffer (get-buffer buffer-or-name)
116 :index 1))
117
118
9b284ac @VincentToups Monadic parser update, bug fixes.
authored
119 (defun empty-string-parser ()
120 (make-instance '<parser-input-string>
121 :string "" :index 0))
122
123 (defmethod input-as-string ((input <parser-input-string>))
124 (substring (string-of input) (index-of input) (length (string-of input))))
125
126 (defun string->parser-input (str)
127 (make-instance '<parser-input-string>
128 :string str))
129
aabfc88 @VincentToups multi-method update, utils added.
authored
130 (defun sequence->parser-input (seq)
131 (make-instance '<parser-input-sequence>
132 :seq (coerce seq 'vector)))
133
9b284ac @VincentToups Monadic parser update, bug fixes.
authored
134 (defun parser-fail ()
135 (lambda (input) nil))
136
5dc89c9 monad-parse update 3
Vincent Toups authored
137 (setq parser-fail (parser-fail))
138
9b284ac @VincentToups Monadic parser update, bug fixes.
authored
139 (defun parser-item ()
140 (lambda (input)
141 (unless (input-empty? input)
142 (list (cons (input-first input)
143 (input-rest input))))))
144
d09d144 @VincentToups fixed, at least, recur.
authored
145 (defun remaining (input)
146 (list (cons (input-as-string input) input)))
147
148 (defun =or-strings (&rest args)
149 (apply #'=or (mapcar #'=string args)))
150
151 (defun =or-stringsi (&rest args)
152 (apply #'=or (mapcar #'=stringi args)))
153
9dabfe0 @VincentToups microstack first
authored
154 (lex-defun parser-items (n)
fb6606c @VincentToups monad revisions.
authored
155 (lambda (input)
156 (let ((i 0)
157 (ac nil))
158 (loop while (and (< i n)
159 (not (input-empty? input)))
160 do
161 (setq i (+ i 1))
162 (push (input-first input) ac )
163 (setq input (input-rest input)))
d09d144 @VincentToups fixed, at least, recur.
authored
164 (if (= (length ac) n) (list (cons (reverse ac) input)) nil))))
9dabfe0 @VincentToups microstack first
authored
165
166 (lex-defun parser-items->string (n)
fb6606c @VincentToups monad revisions.
authored
167 (lambda (input)
168 (let ((i 0)
169 (ac nil))
170 (loop while (and (< i n)
171 (not (input-empty? input)))
172 do
173 (setq i (+ i 1))
174 (push (input-first input) ac )
175 (setq input (input-rest input)))
409eb8e @VincentToups defn-readme, docs
authored
176 ;(db-print (list n (length ac) (coerce (reverse ac) 'string)))
d09d144 @VincentToups fixed, at least, recur.
authored
177 (if (= (length ac) n) (list (cons (coerce (reverse ac) 'string) input)) nil))))
9dabfe0 @VincentToups microstack first
authored
178
27257ab monad-parse update
Vincent Toups authored
179 (defun =string_ (str)
9dabfe0 @VincentToups microstack first
authored
180 (lexical-let ((str str))
181 (parser-bind (parser-items->string (length str))
182 (lambda (x)
183 (if (string= x str)
184 (parser-return x)
185 (parser-fail))))))
d09d144 @VincentToups fixed, at least, recur.
authored
186
27257ab monad-parse update
Vincent Toups authored
187 (defun =string (&rest strs)
188 (lexical-let ((strs strs))
189 (if (not (cdr strs))
190 (=string_ (car strs))
191 (=or (=string_ (car strs))
192 (apply #'=string (cdr strs))))))
d09d144 @VincentToups fixed, at least, recur.
authored
193
27257ab monad-parse update
Vincent Toups authored
194 ; (byte-compile #'=string)
195
196
197 (defun =stringi_ (str)
d09d144 @VincentToups fixed, at least, recur.
authored
198 (lexical-let ((str str))
199 (parser-bind (parser-items->string (length str))
200 (lambda (x)
201 (if (stringi= x str)
202 (parser-return str)
203 (parser-fail))))))
204
27257ab monad-parse update
Vincent Toups authored
205 (defun =stringi (&rest strs)
206 (lexical-let ((strs strs))
207 (if (not (cdr strs))
208 (=stringi_ (car strs))
209 (=or (=stringi_ (car strs))
210 (apply #'=stringi (cdr strs))))))
211
212
213
d09d144 @VincentToups fixed, at least, recur.
authored
214
9dabfe0 @VincentToups microstack first
authored
215 (defun =string->seq (str)
216 (lexical-let ((str str))
217 (parser-bind (parser-items->string (length str))
218 (lambda (x)
219 (if (string= x str)
220 (parser-return (coerce x 'list))
221 (parser-fail))))))
222
9b284ac @VincentToups Monadic parser update, bug fixes.
authored
223 (funcall (parser-item) (string->parser-input ""))
224
225 (defun =satisfies (predicate)
226 (lexical-let ((lpred predicate))
227 (parser-bind (parser-item)
228 (lambda (x)
229 (if (funcall lpred x)
230 (parser-return x)
231 (parser-fail))))))
232
409eb8e @VincentToups defn-readme, docs
authored
233 (defun* =is (object &optional (pred #'eq))
234 (lexical-let ((object object)
235 (pred pred))
236 (=satisfies
237 (lambda (x) (funcall pred object x)))))
238
9b284ac @VincentToups Monadic parser update, bug fixes.
authored
239 (lexical-let ((digits (coerce "1234567890" 'list)))
240 (defun digit-char? (x)
241 (in x digits)))
242
d356d1b @VincentToups Lots of new documentation.
authored
243 (defun ->in (x)
244 (cond
aabfc88 @VincentToups multi-method update, utils added.
authored
245 ((and (stringp x) (bufferp (get-buffer x)))
d356d1b @VincentToups Lots of new documentation.
authored
246 (buffer->parser-input x))
247 ((stringp x)
248 (string->parser-input x))
aabfc88 @VincentToups multi-method update, utils added.
authored
249 ((sequencep x)
250 (sequence->parser-input x))
d356d1b @VincentToups Lots of new documentation.
authored
251 (t (error "Can't convert %s into a parser input." x))))
252
28275fb @VincentToups routine
authored
253 (lexical-let ((lowers (coerce "abcdefghijklmnopqrsztuvwxyz" 'list))
254 (uppers (coerce "ABCDEFGHIJKLMNOPQRSZTUVWXYZ" 'list)))
9b284ac @VincentToups Monadic parser update, bug fixes.
authored
255 (defun upper-case-char? (x)
256 (in x uppers))
257 (defun lower-case-char? (x)
258 (in x lowers)))
259
260 (defun =char (x)
261 (lexical-let ((x x))
262 (=satisfies (lambda (y) (eql x y)))))
263 (defun =upper-case-char? ()
264 (=satisfies (lambda (y) (upper-case-char? y))))
265 (defun =lower-case-char? ()
266 (=satisfies (lambda (y) (lower-case-char? y))))
267
268 (defun =digit-char ()
269 (=satisfies #'digit-char?))
270
b85fabe @VincentToups made monad-parse independent of defn
authored
271 ;; (defun =digit-char->string ()
272 ;; (=let* [c (=digit-char)]
273 ;; (if c (coerce (list c) 'string) nil)))
7a1b824 @VincentToups Added lambda*, defun-recur, parse-lambda-list
authored
274 (defun =digit-char->string ()
b85fabe @VincentToups made monad-parse independent of defn
authored
275 (=simple-let* ((c (=digit-char)))
276 (if c (coerce (list c) 'string) nil)))
277
7a1b824 @VincentToups Added lambda*, defun-recur, parse-lambda-list
authored
278
279 (defun =digit-char->number ()
280 (=let* [c (=digit-char)]
281 (if c (read (coerce (list c) 'string)) nil)))
282
283
d356d1b @VincentToups Lots of new documentation.
authored
284 (defun parser-plus-2 (p1 p2)
9b284ac @VincentToups Monadic parser update, bug fixes.
authored
285 (lexical-let ((p1 p1)
286 (p2 p2))
287 (lambda (input)
288 (append (funcall p1 input) (funcall p2 input)))))
289
d356d1b @VincentToups Lots of new documentation.
authored
290 (defun parser-plus (&rest args)
291 (reduce #'parser-plus-2 args))
292
9b284ac @VincentToups Monadic parser update, bug fixes.
authored
293 (defun letter () (parser-plus (=lower-case-char?) (=upper-case-char?)))
294
295 (defun alphanumeric () (parser-plus (=digit-char) (letter)))
296
d356d1b @VincentToups Lots of new documentation.
authored
297 (defun =char->string (char)
298 (=let* [_ (=char char)]
299 (coerce (list _) 'string)))
300
409eb8e @VincentToups defn-readme, docs
authored
301 (defun =point ()
302 (=satisfies (par #'eq ?.)))
303
304 (defun =decimal-part ()
305 (=simple-let*
306 ((dot (=point))
307 (rest (=one-or-more (=digit-char))))
308 (coerce (cons dot rest) 'string)))
309
d09d144 @VincentToups fixed, at least, recur.
authored
310 (lex-defun =decimal-part* (dec-string)
311 (=simple-let*
312 ((dot (=string dec-string))
313 (rest (=one-or-more (=digit-char))))
314 (coerce (cons ?. rest) 'string)))
315
316
409eb8e @VincentToups defn-readme, docs
authored
317 (defun =integer-part ()
318 (=simple-let*
319 ((digits (=zero-or-more (=digit-char))))
320 (coerce digits 'string)))
321
322 (defun =number->number ()
323 (=simple-let*
d09d144 @VincentToups fixed, at least, recur.
authored
324 ((minus-sign (=maybe (=string "-")))
325 (int (=integer-part))
409eb8e @VincentToups defn-readme, docs
authored
326 (dec (=maybe (=decimal-part))))
d09d144 @VincentToups fixed, at least, recur.
authored
327 (let ((n (string-to-number (concat int dec))))
328 (if minus-sign (- n) n))))
329
27257ab monad-parse update
Vincent Toups authored
330 (defun =number->string ()
331 (=simple-let*
332 ((minus-sign (=maybe (=string "-")))
333 (int (=integer-part))
334 (dec (=maybe (=decimal-part))))
335 (let ((n (concat int dec)))
336 (if minus-sign (concat "-" n) n))))
337
338
d09d144 @VincentToups fixed, at least, recur.
authored
339 (lex-defun =number->number* (dec-string)
340 (=simple-let*
341 ((minus-sign (=maybe (=string "-")))
342 (int (=integer-part))
343 (dec (=maybe (=decimal-part* dec-string))))
344 (let ((n (string-to-number (concat int dec))))
345 (if minus-sign (- n) n))))
346
d356d1b @VincentToups Lots of new documentation.
authored
347
9dabfe0 @VincentToups microstack first
authored
348 (lex-defun =or2 (p1 p2)
409eb8e @VincentToups defn-readme, docs
authored
349 (lambda (input)
350 (or (funcall p1 input)
351 (funcall p2 input))))
9dabfe0 @VincentToups microstack first
authored
352 (lex-defun =or (&rest ps)
409eb8e @VincentToups defn-readme, docs
authored
353 (reduce #'=or2 ps))
9dabfe0 @VincentToups microstack first
authored
354
355 ;; (lex-defun =or (parser &rest parsers)
356 ;; (lambda (input)
357 ;; (or (funcall parser input)
358 ;; (when parsers
359 ;; (funcall (apply #'=or parsers) input)))))
360
361 ;; (lex-defun =or (parser &rest parsers)
362 ;; (lambda (input)
363 ;; (foldl
364 ;; (lambda (sub-parser state)
365 ;; (or state
366 ;; (funcall sub-parser input)))
367 ;; (funcall parser input)
368 ;; parsers)))
9b284ac @VincentToups Monadic parser update, bug fixes.
authored
369
370 (lex-defun =not (parser)
409eb8e @VincentToups defn-readme, docs
authored
371 (lambda (input)
372 (let ((result (funcall parser input)))
373 (if result
374 nil
27257ab monad-parse update
Vincent Toups authored
375 (funcall (parser-item) input)))))
9b284ac @VincentToups Monadic parser update, bug fixes.
authored
376
377 (defmacro* =let* (forms &body body)
fb6606c @VincentToups monad revisions.
authored
378 `(lexical-domonad< monad-parse ,forms ,@body))
9b284ac @VincentToups Monadic parser update, bug fixes.
authored
379
b85fabe @VincentToups made monad-parse independent of defn
authored
380 (defmacro* =simple-let* (bindings &body body)
381 (if bindings
382 (let ((symbol (car (car bindings))))
383 `(parser-bind ,@(cdr (car bindings))
384 (lex-lambda (,symbol)
385 (=simple-let* ,(cdr bindings)
409eb8e @VincentToups defn-readme, docs
authored
386 ,@body))))
b85fabe @VincentToups made monad-parse independent of defn
authored
387 `(parser-return (progn ,@body))))
388
9dabfe0 @VincentToups microstack first
authored
389 (lex-defun =and2 (p1 p2)
409eb8e @VincentToups defn-readme, docs
authored
390 (lex-lambda (input)
391 (and (funcall p1 input)
392 (funcall p2 input))))
b85fabe @VincentToups made monad-parse independent of defn
authored
393
9dabfe0 @VincentToups microstack first
authored
394 (lex-defun =and (&rest ps)
409eb8e @VincentToups defn-readme, docs
authored
395 (reduce #'=and2 ps))
9b284ac @VincentToups Monadic parser update, bug fixes.
authored
396
9dabfe0 @VincentToups microstack first
authored
397 ;; (lex-defun =and (p1 &rest ps)
398 ;; (=let* [result p1]
399 ;; (if ps
400 ;; (apply #'=and ps)
401 ;; result)))
402
403 (lex-defun =and-concat2 (p1 p2)
409eb8e @VincentToups defn-readme, docs
authored
404 (=let* [r1 p1
405 r2 p2]
406 (concat r1 r2)))
9dabfe0 @VincentToups microstack first
authored
407
408 (lex-defun =and-concat (&rest ps)
409eb8e @VincentToups defn-readme, docs
authored
409 (reduce #'=and-concat2 ps))
9dabfe0 @VincentToups microstack first
authored
410
411 (lex-defun parser-maybe (parser)
409eb8e @VincentToups defn-readme, docs
authored
412 (=or parser (parser-return nil)))
aabfc88 @VincentToups multi-method update, utils added.
authored
413 (lex-defun =maybe (parser)
409eb8e @VincentToups defn-readme, docs
authored
414 (=or parser (parser-return nil)))
aabfc88 @VincentToups multi-method update, utils added.
authored
415
9b284ac @VincentToups Monadic parser update, bug fixes.
authored
416
417 (defun letters ()
418 (=or (=let* [x (letter)
419 xs (letters)]
420 (cons x xs))
421 (parser-return nil)))
422
28275fb @VincentToups routine
authored
423 (defun =letter ()
424 (letter))
425
9dabfe0 @VincentToups microstack first
authored
426 ;; (lex-defun zero-or-more (parser)
427 ;; (=or (=let* [x parser
428 ;; xs (zero-or-more parser)]
429 ;; (cons x xs))
430 ;; (parser-return nil)))
9b284ac @VincentToups Monadic parser update, bug fixes.
authored
431
409eb8e @VincentToups defn-readme, docs
authored
432 (lex-defun =zero-or-one (parser)
433 (=or (=let* [_ parser]
434 _)
435 (parser-return nil)))
d356d1b @VincentToups Lots of new documentation.
authored
436
d09d144 @VincentToups fixed, at least, recur.
authored
437 (lex-defun zero-or-one (parser)
438 (=or (=let* [_ parser]
439 _)
440 (parser-return nil)))
441
9dabfe0 @VincentToups microstack first
authored
442 (lex-defun zero-or-one-list (parser)
409eb8e @VincentToups defn-readme, docs
authored
443 (=or (=let* [_ parser]
444 (list _))
445 (parser-return nil)))
d356d1b @VincentToups Lots of new documentation.
authored
446
9dabfe0 @VincentToups microstack first
authored
447 (lex-defun zero-or-plus-more (parser)
409eb8e @VincentToups defn-readme, docs
authored
448 (lambda (input)
449 (let ((terminals nil)
450 (continuers (funcall (zero-or-one-list parser) input))
451 (done nil)
452 (res nil))
453 (loop while (not done) do
454 (let ((old-continuers continuers))
455 (setq continuers nil)
456 (loop while old-continuers
457 do
458 (let* ((sub-parser-state (pop old-continuers))
459 (state (car sub-parser-state))
460 (sub-input (cdr sub-parser-state))
461 (res (funcall parser sub-input)))
462 (if res
463 (setq continuers
464 (append continuers (mapcar
465 (lambda (sub-res)
466 (cons
467 (suffix state (car sub-res))
468 (cdr sub-res)))
469 res)))
470 (push sub-parser-state terminals)))))
471 (if (empty? continuers)
472 (setq done t)))
473 terminals)))
9dabfe0 @VincentToups microstack first
authored
474
475 (lex-defun zero-or-more
409eb8e @VincentToups defn-readme, docs
authored
476 (parser)
477 (lexical-let ((zero-or-one-parser (zero-or-one parser)))
478 (lex-lambda (input)
479 (let* ((sub-state (car (funcall (zero-or-one-list parser) input)))
480 (acc (car sub-state))
481 (done (not (car sub-state))))
482
483 (if done (list sub-state)
484 (progn
485
486 (loop while (not done) do
487 (let* ((next-input (cdr sub-state))
488 (next-sub-state
489 (car (funcall zero-or-one-parser next-input)))
490 (res (car next-sub-state)))
491 (if res (progn
492 (push res acc)
493 (setq sub-state next-sub-state))
494 (setq done t))))
495 (list (cons (reverse acc) (cdr sub-state)))))))))
496
497 (lex-defun =zero-or-more
498 (parser)
499 (lexical-let ((zero-or-one-parser (zero-or-one parser)))
500 (lex-lambda (input)
501 (let* ((sub-state (car (funcall (zero-or-one-list parser) input)))
502 (acc (car sub-state))
503 (done (not (car sub-state))))
504
505 (if done (list sub-state)
506 (progn
507
508 (loop while (not done) do
509 (let* ((next-input (cdr sub-state))
510 (next-sub-state
511 (car (funcall zero-or-one-parser next-input)))
512 (res (car next-sub-state)))
513 (if res (progn
514 (push res acc)
515 (setq sub-state next-sub-state))
516 (setq done t))))
517 (list (cons (reverse acc) (cdr sub-state)))))))))
9dabfe0 @VincentToups microstack first
authored
518
519
520
409eb8e @VincentToups defn-readme, docs
authored
521 (lex-defun one-or-more
522 (parser)
523 (=let* [x parser
524 y (zero-or-more parser)]
525 (cons x y)))
9dabfe0 @VincentToups microstack first
authored
526
409eb8e @VincentToups defn-readme, docs
authored
527 (lex-defun =one-or-more
528 (parser)
529 (=let* [x parser
530 y (zero-or-more parser)]
531 (cons x y)))
9dabfe0 @VincentToups microstack first
authored
532
9b284ac @VincentToups Monadic parser update, bug fixes.
authored
533
9dabfe0 @VincentToups microstack first
authored
534 (defun parse-string (parser string)
2766faa @VincentToups parser-monad-tutorial
authored
535 (car (car (funcall parser (string->parser-input string)))))
9dabfe0 @VincentToups microstack first
authored
536
aabfc88 @VincentToups multi-method update, utils added.
authored
537 (defun parse-sequence (parser sequence)
538 (car (car (funcall parser (->in sequence)))))
539
9dabfe0 @VincentToups microstack first
authored
540 (defun parse-string-det (parser string)
541 (let* ((pr (funcall parser (->in string)))
542 (result (car (car pr)))
543 (rest (input->string (cdr (car pr)))))
544 (if (or (not result)
545 (not rest)) nil
664a8db @VincentToups weighted graph monad commit
authored
546 (list result rest))))
9dabfe0 @VincentToups microstack first
authored
547
b85fabe @VincentToups made monad-parse independent of defn
authored
548 (defun =lit-sym (sym)
549 (=satisfies (f-and
550 #'symbolp
551 (par #'eq sym))))
552
d09d144 @VincentToups fixed, at least, recur.
authored
553 (defmacro* parser-let* (binders &body body)
554 `(lexical-mlet monad-parse ,binders ,@body))
555
27257ab monad-parse update
Vincent Toups authored
556 (defmacro parser-do (&rest exprs)
557 `(monadic-do monad-parse ,@exprs))
558
559 (defmacro parser (&rest exprs)
560 `(parser-do ,@exprs))
561
562 (defmacro defparser (name maybe-doc &rest exprs)
563 (if (symbolp name)
564 `(progn (defvar ,name
565 nil
566 ,@(if (stringp maybe-doc) (list maybe-doc) '()))
567 (setq ,name (parser ,@(if (stringp maybe-doc) '() (list maybe-doc)) ,@exprs)))
568 `(lex-defun ,(car name) ,(cdr name)
569 ,@(if (stringp maybe-doc) (list maybe-doc) '())
5dc89c9 monad-parse update 3
Vincent Toups authored
570 (parser ,@(if (stringp maybe-doc) '() (list maybe-doc)) ,@exprs))))
27257ab monad-parse update
Vincent Toups authored
571
572 (defun =one-or-more->string (parser)
573 (lexical-let ((parser parser))
574 (parser-do
575 (r <- (=one-or-more parser))
576 (m-return
577 (coerce r 'string)))))
578
9b284ac @VincentToups Monadic parser update, bug fixes.
authored
579 (provide 'monad-parse)
b85fabe @VincentToups made monad-parse independent of defn
authored
580
Something went wrong with that request. Please try again.