summaryrefslogtreecommitdiff
path: root/parser.lisp
diff options
context:
space:
mode:
Diffstat (limited to 'parser.lisp')
-rw-r--r--parser.lisp214
1 files changed, 0 insertions, 214 deletions
diff --git a/parser.lisp b/parser.lisp
deleted file mode 100644
index c627af1..0000000
--- a/parser.lisp
+++ /dev/null
@@ -1,214 +0,0 @@
-(in-package #:monparser)
-
-(defun parse-string (p input)
- (let ((result (funcall p (from-string input))))
- (if (parsing-p result)
- (parsing-tree result)
- result)))
-
-(defun parse-file (p input)
- (let ((result (funcall p (from-file input))))
- (if (parsing-p result)
- (parsing-tree result)
- result)))
-
-(defstruct parsing
- tree
- left
- limit)
-
-(defun lazy-parsing-p (r)
- (or (functionp r)
- (parsing-p r)))
-
-(defstruct failure
- place
- message)
-
-(defmethod print-object ((obj failure) stream)
- (let ((file (file (failure-place obj))))
- (if file
- (multiple-value-bind (line column) (line-and-column (failure-place obj))
- (format stream "~a:~a:~a: ~a" line column file (failure-message obj)))
- (format stream "~a: ~a" (cursor (failure-place obj)) (failure-message obj)))))
-
-(defun new (tree)
- (lambda (input &key limit lazy)
- (declare (ignore lazy))
- (if (and limit (> limit 0))
- (make-failure :place input
- :message (format nil "Didn't reach expected limit: ~a." limit))
- (make-parsing :tree tree :left input))))
-
-(defun bind (p f &key (greedy t))
- (lambda (input &key limit lazy)
- (let (r)
- (if greedy
- (setf r (funcall p input :limit limit))
- (let ((next-parser (funcall f nil input))
- (limit -1))
- (do ((sweep-input input (advance sweep-input)))
- ((or (not (has-data? sweep-input))
- (> limit -1)) nil)
- (when (lazy-parsing-p (funcall next-parser sweep-input :lazy t))
- (setf limit (input-sub sweep-input input))))
- (if (< limit 0)
- (setf r (make-failure :place input
- :message "Reached end of input while sweeping."))
- (setf r (funcall p input :limit limit)))))
- (if (parsing-p r)
- (if lazy
- (lambda (ignored-input &key lazy limit)
- (declare (ignore ignored-input limit))
- (funcall (funcall f (parsing-tree r) input)
- (parsing-left r)
- :lazy lazy
- :limit (if greedy (parsing-limit r))))
- (funcall (funcall f (parsing-tree r) input)
- (parsing-left r)
- :limit (if greedy (parsing-limit r))))
- r))))
-
-(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))
- :greedy ,(not lazy))
- `(bind ,parser
- (lambda (,var &rest ,unused)
- (declare (ignore ,unused))
- (comp ,(cdr bindings) ,@body))
- :greedy ,(not lazy)))
- (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))
- :greedy ,(not lazy))
- (error "Binding must be either a symbol or a cons of symbols."))))))
-
-(defun one-of (first-parser second-parser &rest other-parsers)
- (lambda (input &key limit lazy)
- (declare (ignore lazy))
- (labels ((one-of-rec (parsers)
- (let ((intermediate-parsers '())
- (result nil))
- (dolist (p parsers)
- (let ((r (funcall p
- input
- :lazy (> (length parsers) 1)
- :limit limit)))
- (cond ((functionp r)
- (push r intermediate-parsers))
- ((parsing-p r)
- (when (or (not (parsing-p result))
- (> (cursor (parsing-left r))
- (cursor (parsing-left result))))
- (setf result r)))
- ((failure-p r)
- (when (or (failure-p result)
- (= (length parsers) 1))
- (setf result r))))))
- (if intermediate-parsers
- (one-of-rec intermediate-parsers)
- result))))
- (one-of-rec (cons first-parser (cons second-parser other-parsers))))))
-
-(defun fail (message)
- (lambda (input &key limit 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)))
- (t (setf predicate
- (nsubst-if 'it
- (lambda (x)
- (and (symbolp x)
- (string-equal (symbol-name x) "IT"))) predicate))))
- `(lambda (input &key limit lazy)
- (declare (ignore lazy))
- (if (and limit (<= limit 0))
- (make-failure :place input :message "Reached established limit.")
- (if (has-data? input)
- (let ((it (peek input)))
- (if ,predicate
- (make-parsing :tree it :left (advance input) :limit (if limit (1- limit)))
- (make-failure :place input
- :message (format nil "Expected: ~a, Got: ~a" ',predicate it))))
- (make-failure :place input :message "Reached end of input.")))))
-
-(defmacro literal (word)
- (when (not (stringp word))
- (error "Literal only accepts strings as input."))
- (let ((binding-list '())
- (name-list '()))
- (loop :for c :across word :do
- (when c
- (let ((name (gensym)))
- (push name name-list)
- (push `(,name (unit ,c)) binding-list))))
- `(comp ,(reverse binding-list)
- (coerce ,(cons 'list (reverse name-list)) 'string))))
-
-(defparameter nothing
- (new nil))
-
-(defun optional (p)
- (one-of p nothing))
-
-(defun many (p)
- (comp ((x p)
- (xs (if (not x)
- (fail "Parsing result is empty.")
- (optional (many p)))))
- (cons x xs)))
-
-(defun repeat (p min &optional (max 0))
- (if (> min 0)
- (comp ((x p)
- (xs (repeat p (1- min) (1- max))))
- (cons x xs))
- (if (> max 0)
- (comp ((x (optional p))
- (xs (repeat p 0 (if x (1- max) 0))))
- (if x (cons x xs) x))
- nothing)))
-
-(defun whitespace? (x)
- (some (lambda (y) (char= x y)) '(#\Space #\Newline #\Tab)))
-
-(defparameter whitespace
- (comp ((_ (optional (many (unit whitespace?)))))
- :whitespace))
-
-(defun separated-list (p separator &key include-separator)
- (comp ((v p)
- (sep (optional separator))
- (vn (if sep
- (separated-list p separator)
- nothing)))
- (if include-separator
- (cons v (cons sep vn))
- (cons v vn))))
-
-(defun surrounded (left p right &key include-surrounding)
- (comp ((l left)
- (body p :lazy)
- (r right))
- (if include-surrounding
- (list l body r)
- body)))