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
|
(in-package #:monparser)
(defun fail (message &key (priority 1))
(lambda (input)
(make-failure :place input :message message :priority priority)))
(defmacro unit (&optional predicate)
(cond ((null predicate)
(setf predicate 't))
((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)
(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: ~:c." ',predicate it))))
(make-failure :place input
:message (format nil "Reached end of input. Expected: ~a." ',predicate)))))
(defun one-of (first-parser second-parser &rest other-parsers)
(lambda (input)
(let ((parsers `(,first-parser ,second-parser ,@other-parsers))
(result (make-failure :place input)))
(dolist (p parsers)
(let ((r (funcall p input)))
(cond ((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 (failure-p result)
(let ((priority-cmp (- (failure-priority r)
(failure-priority result))))
(when (or (> priority-cmp 0)
(and (= priority-cmp 0)
(>= (input-cursor (failure-place r))
(input-cursor (failure-place result)))))
(setf result r)))))
(t (error (format nil "Invalid return value: ~a." r))))))
result)))
;;; TODO: Find a way to be able to use the input without needing to define a name for it.
(defmacro comp (bindings &body body)
(if (null bindings)
`(new (progn ,@body))
(let ((var (first (car bindings)))
(parser (second (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."))))))
|
