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
|
(in-package #:monparser)
(defun fail (message)
(lambda (input &key lazy)
(make-failure :place input :message message)))
(defmacro unit (&optional predicate)
(cond ((null predicate)
(setf predicate '(characterp it)))
((symbolp predicate)
(setf predicate `(,predicate it)))
((characterp predicate)
(setf predicate `(char-equal ,predicate it)))
((listp predicate)
(if (eq (car predicate) 'function)
(setf predicate `(funcall ,predicate it))
(setf predicate
(nsubst-if 'it
(lambda (x)
(and (symbolp x)
(string-equal (symbol-name x) "IT"))) predicate))))
(t (error (format nil "Invalid predicate: ~a." predicate))))
`(lambda (input &key lazy)
(declare (ignore lazy))
(if (has-data? input)
(let ((it (peek input)))
(if ,predicate
(make-parsing :tree it :left (advance input))
(make-failure :place input
:message (format nil "Expected: ~a, Got: ~a" ',predicate it))))
(make-failure :place input :message "Reached end of input."))))
(defmacro one-of (first-parser second-parser &rest other-parsers)
`(lambda (input &key lazy)
(declare (ignore lazy))
(labels ((one-of-rec (parsers)
(let ((intermediate-parsers '())
(result (make-failure :place input
:message "Exhausted options.")))
(dolist (p parsers)
(let ((r (funcall p
input
:lazy (> (length parsers) 1))))
(cond ((functionp r)
(push r intermediate-parsers))
((parsing-p r)
(when (or (not (parsing-p result))
(> (input-cursor (parsing-left r))
(input-cursor (parsing-left result))))
(setf result r)))
((failure-p r)
(when (or (failure-p result)
(= (length parsers) 1))
(setf result r)))
(t (error (format nil "Invalid return value: ~a" r))))))
(if intermediate-parsers
(one-of-rec intermediate-parsers)
result))))
(one-of-rec (list ,first-parser ,second-parser ,@other-parsers)))))
(defmacro comp (bindings &body body)
(if (null bindings)
`(new (progn ,@body))
(let ((var (first (car bindings)))
(parser (second (car bindings)))
(lazy (third (car bindings)))
(unused (gensym)))
(if (symbolp var)
(if (string= (symbol-name var) "_")
`(bind ,parser
(lambda (&rest ,unused)
(declare (ignore ,unused))
(comp ,(cdr bindings) ,@body)))
`(bind ,parser
(lambda (,var &rest ,unused)
(declare (ignore ,unused))
(comp ,(cdr bindings) ,@body))))
(if (and (consp var) (symbolp (car var)) (symbolp (cdr var)))
`(bind ,parser
(lambda (,(car var) ,(cdr var) &rest ,unused)
(declare (ignore ,unused))
(comp ,(cdr bindings) ,@body)))
(error "Binding must be either a symbol or a cons of symbols."))))))
|
