diff options
Diffstat (limited to 'parser.lisp')
-rw-r--r-- | parser.lisp | 214 |
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))) |