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
|
(in-package #:monparser)
(defstruct result)
(defstruct (parsing (:include result))
tree
(start (make-instance 'cursor) :type cursor)
(end (make-instance 'cursor) :type cursor))
(defstruct (failure (:include result))
(place (make-instance 'cursor) :type cursor)
(message "" :type string)
(priority 0 :type integer))
(deftype parser ()
`(function (cursor cursor) result))
(defmacro lazy (parser &rest args)
(let ((start (gensym))
(input (gensym)))
`(the parser
(lambda (,start ,input)
(funcall (,parser ,@args) ,start ,input)))))
(defun line-and-column (str index)
(let ((line 1) (column 1))
(dotimes (i index)
(let ((c (char str i)))
(case c
(#\Newline
(incf line)
(setf column 1))
(t (incf column)))))
(cons line column)))
(defmethod print-object ((obj failure) stream)
(let ((linecol (line-and-column (data (failure-place obj))
(index (failure-place obj)))))
(format stream "~a:~a: ~a~&~a~&"
(car linecol) (cdr linecol) (failure-message obj) (failure-place obj))))
(declaim (ftype (function (t &key (:priority integer)) parser) fail))
(defun fail (message &key (priority 1))
(lambda (start input)
(declare (ignore start))
(make-failure :place input :message message :priority priority)))
(declaim (ftype (function (t) parser) new))
(defun new (tree)
(lambda (start input)
(make-parsing :tree tree :start start :end input)))
(declaim (ftype (function (parser (function (result) parser)) parser) bind))
(defun bind (parser f)
(lambda (start input)
(let ((r (funcall parser input input)))
(cond ((parsing-p r)
(funcall (funcall f r) start (parsing-end 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 (function (result) parser)
(lambda (,var)
(declare (ignore ,var))
(comp ,(cdr bindings) ,@body))))
`(bind ,parser
(the (function (result) parser)
(lambda (,var)
(let ((,var (parsing-tree ,var)))
(comp ,(cdr bindings) ,@body)))))))
((and (listp var) (= (length var) 1) (symbolp (car var)))
`(bind ,parser
(the (function (result) parser)
(lambda (,(first var))
(comp ,(cdr bindings) ,@body)))))
(t (error "Binding must be either a symbol or a list of one symbol."))))))
|
