blob: a92355c791cba055466e596a7e963af038c661e5 (
plain)
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
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
|
(in-package #:parser)
(defun run (p input)
(let ((r (funcall p input)))
(if (parsing-p r)
(parsing-tree r)
(input::generate-report (failure-place r) (failure-message r)))))
(defstruct parsing
tree
left)
(defstruct failure
place
message)
(defstruct (normal-failure (:include failure)))
(defstruct (critical-failure (:include failure)))
(defun new (tree)
(lambda (input)
(make-parsing :tree tree :left input)))
(defun bind (p f)
(lambda (input)
(let ((r (funcall p input)))
(if (parsing-p r)
(funcall (funcall f (parsing-tree r)) (parsing-left r))
r))))
(defun discarding-bind (p q)
(lambda (input)
(let ((r (funcall p input)))
(if (parsing-p r)
(funcall q (parsing-left r))
r))))
(defun fail (&optional (message "Unknown error."))
(lambda (input)
(make-critical-failure :place input :message message)))
(defun either (first-parser second-parser &rest other-parsers)
(lambda (input)
(labels ((either-rec (body)
(if (cdr body)
(let ((r (funcall (car body) input)))
(if (normal-failure-p r)
(either-rec (cdr body))
r))
(funcall (car body) input))))
(either-rec (cons first-parser (cons second-parser other-parsers))))))
(defun unit (predicate)
(lambda (input)
(if (input::has-data? input)
(let ((c (input::peek-1 input)))
(if (char= c predicate)
(make-parsing :tree c :left (input::advance input))
(make-normal-failure :place input :message "Predicate not satisfied.")))
(make-normal-failure :place input :message "Reached end of input."))))
(defun not-unit (predicate)
(lambda (input)
(if (input::has-data? input)
(let ((c (input::peek-1 input)))
(if (char/= c predicate)
(make-parsing :tree c :left (input::advance input))
(make-normal-failure :place input :message "Predicate not satisfied.")))
(make-normal-failure :place input :message "Reached end of input."))))
(defun unit-if (&optional (predicate #'characterp))
(lambda (input)
(if (input::has-data? input)
(let ((c (input::peek-1 input)))
(if (funcall predicate c)
(make-parsing :tree c :left (input::advance input))
(make-normal-failure :place input :message "Predicate not satisfied.")))
(make-normal-failure :place input :message "Reached end of input."))))
(defun literal (predicate)
(lambda (input)
(if (input::has-data? input (length predicate))
(let ((c (input::peek-n input (length predicate))))
(if (string= predicate c)
(make-parsing :tree c :left (input::advance input (length c)))
(make-normal-failure :place input :message "Predicate not satisfied.")))
(make-normal-failure :place input :message "Reached end of input."))))
(defun until-literal (predicate)
(lambda (input)
(let ((c (search predicate (input::input-data input) :start2 (input::input-cursor input))))
(if c
(let ((window (- c (input::input-cursor input))))
(if (> window 0)
(make-parsing :tree (input::peek-n input window) :left (input::advance input window))
(make-failure :place input :message "Predicate not satisfied.")))
(make-parsing :tree (input::peek-rest input) :left (input::advance-to-end input))))))
(defmacro comp (bindings &body body)
(if (null bindings)
`(new (progn ,@body))
(let ((v (first (car bindings)))
(p (second (car bindings))))
(if (eq v '_)
`(discarding-bind ,p (comp ,(cdr bindings) ,@body))
`(bind ,p (lambda (,v) (comp ,(cdr bindings) ,@body)))))))
(defparameter nothing
(new nil))
(defun optional (p)
(either p nothing))
(defun many (p)
(comp ((x p)
(xs (optional (many p))))
(cons x xs)))
(defun separated-list (p separator &key (include-separator nil))
(comp ((v p)
(sep (optional separator))
(vn (if sep
(either (separated-list p separator)
(fail "Value expected."))
nothing)))
(if include-separator
(cons v (cons sep vn))
(cons v vn))))
|
