diff options
Diffstat (limited to 'parser.lisp')
| -rw-r--r-- | parser.lisp | 127 |
1 files changed, 55 insertions, 72 deletions
diff --git a/parser.lisp b/parser.lisp index a48f6e3..5470523 100644 --- a/parser.lisp +++ b/parser.lisp @@ -1,28 +1,25 @@ (in-package #:parser) +(defun run (p input) + (let ((result (funcall p input))) + (if (parsing-p result) + (parsing-tree result) + result))) + (defstruct parsing tree left) -(defmethod print-object ((obj parsing) stream) - (print-unreadable-object (obj stream :type t) - (format stream "~a" (parsing-tree obj)))) - (defstruct failure place message) (defmethod print-object ((obj failure) stream) - (print-unreadable-object (obj stream :type t) - (let ((file (input:file (failure-place obj)))) - (if file - (multiple-value-bind (line column) (input:line-and-column (failure-place obj)) - (format stream "~a:~a:~a: ~a" line column file (failure-message obj))) - (format stream "~a: ~a" (input:cursor (failure-place obj)) (failure-message obj)))))) - -(defstruct (normal-failure (:include failure))) - -(defstruct (critical-failure (:include failure))) + (let ((file (input:file (failure-place obj)))) + (if file + (multiple-value-bind (line column) (input:line-and-column (failure-place obj)) + (format stream "~a:~a:~a: ~a" line column file (failure-message obj))) + (format stream "~a: ~a" (input:cursor (failure-place obj)) (failure-message obj))))) (defun new (tree) (lambda (input) @@ -73,71 +70,54 @@ `(bind-with-input ,p (lambda (,(car v) ,(cdr v)) (comp ,(cdr bindings) ,@body))) (error "Binding name/(name,input) must be either a symbol or a cons of symbols.")))))) -(defun fail (&optional (message "Unknown error.")) - (lambda (input) - (make-critical-failure :place input :message message))) - -(defun one-of (first-parser second-parser &rest other-parsers) - (lambda (input) - (labels ((one-of-rec (body) - (if (cdr body) - (let ((r (funcall (car body) input))) - (if (normal-failure-p r) - (one-of-rec (cdr body)) - r)) - (funcall (car body) input)))) - (one-of-rec (cons first-parser (cons second-parser other-parsers)))))) - -(defun all-of (first-parser second-parser &rest other-parsers) - (lambda (input) - (labels ((all-of-rec (body) - (if (cdr body) - (let ((r (funcall (car body) input))) - (if (parsing-p r) - (all-of-rec (cdr body)) - r)) - (funcall (car body) input)))) - (all-of-rec (cons first-parser (cons second-parser other-parsers)))))) - -(defun negate (p) +(defun crit (p) (lambda (input) (let ((r (funcall p input))) - (cond ((parsing-p r) - (make-normal-failure :place input :message "Negated parser result.")) - ((normal-failure-p r) - (make-parsing :tree nil :left input)) - (t r))))) + (if (parsing-p r) + r + (error (format nil "~a" r)))))) -(defun unit-if (&optional (predicate #'characterp)) +(defun one-of (first-parser second-parser &rest other-parsers) (lambda (input) - (if (input:has-data? input) - (let ((c (input:peek 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 unit (target) - (unit-if (lambda (x) (char= x target)))) - -(defun not-unit (target) - (unit-if (lambda (x) (char/= x target)))) + (labels ((one-of-rec (parsers failures) + (if (car parsers) + (let ((r (funcall (car parsers) input))) + (cond ((failure-p r) + (one-of-rec (cdr parsers) (cons r failures))) + ((listp r) + (one-of-rec (cdr parsers) (append r failures))) + (t r))) + failures))) + (one-of-rec (cons first-parser (cons second-parser other-parsers)) nil)))) + +(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) + (if (input:has-data? input) + (let ((it (input:peek input))) + (if ,predicate + (make-parsing :tree it :left (input:advance input)) + (make-failure :place input + :message (format nil "Expected: ~a, Got: ~a" ',predicate it)))) + (make-failure :place input :message "Reached end of input.")))) (defun literal (target) (lambda (input) (if (input:has-data? input) (if (input:prefix? target input) (make-parsing :tree target :left (input:advance input (length target))) - (make-normal-failure :place input :message "Predicate not satisfied.")) - (make-normal-failure :place input :message "Reached end of input.")))) - -(defun not-literal (target) - (lambda (input) - (if (input:has-data? input) - (if (input:prefix? target input) - (make-normal-failure :place input :message "Predicate not satisfied.") - (make-parsing :tree (input:peek input) :left (input:advance input))) - (make-normal-failure :place input :message "Reached end of input.")))) + (make-failure :place input :message "Predicate not satisfied.")) + (make-failure :place input :message "Reached end of input.")))) (defparameter nothing (new nil)) @@ -150,12 +130,15 @@ (xs (optional (many p)))) (cons x xs))) -(defun separated-list (p separator &key (include-separator nil)) +(defparameter whitespace + (comp ((_ (optional (many (unit char:whitespace?))))) + nil)) + +(defun separated-list (p separator &key include-separator) (comp ((v p) (sep (optional separator)) (vn (if sep - (one-of (separated-list p separator) - (fail "Value expected.")) + (crit (separated-list p separator)) nothing))) (if include-separator (cons v (cons sep vn)) |