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
|
(in-package #:monparser)
(defstruct result
(place (make-instance 'cursor) :type cursor))
(defstruct (parsing (:include result))
tree)
(defstruct (failure (:include result))
(message "" :type string)
(priority 0 :type integer))
(defmethod print-object ((obj failure) stream)
(let ((linecol (line-and-column (result-place obj))))
(format stream "~a:~a: ~a~&~a~&"
(car linecol) (cdr linecol) (failure-message obj) (result-place obj))))
(deftype parser ()
`(function (cursor) result))
(defmacro lazy (parser &rest args)
(let ((input (gensym)))
`(the parser
(lambda (,input)
(funcall (,parser ,@args) ,input)))))
(declaim (ftype (function (t &key (:priority integer)) parser) fail))
(defun fail (message &key (priority 1))
(lambda (input)
(make-failure :place input :message message :priority priority)))
(declaim (ftype (function (t) parser) new))
(defun new (tree)
(lambda (input)
(make-parsing :place input :tree tree)))
(deftype parser-continuation ()
`(function (t) parser))
(declaim (ftype (function (parser parser-continuation) parser) bind))
(defun bind (parser f)
(lambda (input)
(let ((r (funcall parser (cursor-rebase input))))
(cond ((parsing-p r)
(funcall (funcall f r) (cursor-merge input (result-place r))))
((failure-p r) r)
(t (error (format nil "Invalid return value: ~a" r)))))))
(defmacro comp (bindings &body body)
(if (null bindings)
`(new (progn ,@body))
(let ((var (first (car bindings)))
(parser (second (car bindings))))
(cond ((symbolp var)
(if (string= (symbol-name var) "_")
`(bind ,parser
(the parser-continuation
(lambda (,var)
(declare (ignore ,var))
(comp ,(cdr bindings) ,@body))))
`(bind ,parser
(the parser-continuation
(lambda (,var)
(let ((,var (parsing-tree ,var)))
(comp ,(cdr bindings) ,@body)))))))
((and (listp var) (= (length var) 1) (symbolp (car var)))
`(bind ,parser
(the parser-continuation
(lambda (,(first var))
(comp ,(cdr bindings) ,@body)))))
(t (error "Binding must be either a symbol or a list of one symbol."))))))
|
