diff options
author | Juan Manuel Tomás <jtomas1815@gmail.com> | 2023-05-01 23:03:53 -0300 |
---|---|---|
committer | Juan Manuel Tomás <jtomas1815@gmail.com> | 2023-05-01 23:03:53 -0300 |
commit | aa378b3568b7dbb05de0de9f17abaae03863058a (patch) | |
tree | 7646ee29fc91bcd6add3f38dc73bf38820e4d1c6 /parser.lisp | |
parent | d63d9d6d881a67bd132b1f55000fe4dc54491173 (diff) | |
download | monparser-aa378b3568b7dbb05de0de9f17abaae03863058a.tar.gz monparser-aa378b3568b7dbb05de0de9f17abaae03863058a.zip |
Improve flexibility
This will make it easier to run the parser in a multi-stage
setup without sacrificing the standalone setups.
Modified comp to extract the location of parsed things.
I expose the parts of the Input, Parsing and Failure objects
to customize error handling.
Parsing and Failure objects have a default printer now.
Diffstat (limited to 'parser.lisp')
-rw-r--r-- | parser.lisp | 78 |
1 files changed, 50 insertions, 28 deletions
diff --git a/parser.lisp b/parser.lisp index c07120d..a48f6e3 100644 --- a/parser.lisp +++ b/parser.lisp @@ -1,19 +1,25 @@ (in-package #:parser) -(defun run (p input) - (let ((r (funcall p input))) - (if (parsing-p r) - (parsing-tree r) - (input::generate-report (failure-place r) (failure-message r))))) - (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))) @@ -22,18 +28,34 @@ (lambda (input) (make-parsing :tree tree :left input))) +(defun bind-with-input (p f) + (declare (optimize (speed 3))) + (declare (type function p f)) + (lambda (input) + (let ((r (funcall p input))) + (if (parsing-p r) + (funcall (the function (funcall f (parsing-tree r) input)) + (parsing-left r)) + r)))) + (defun bind (p f) + (declare (optimize (speed 3))) + (declare (type function p f)) (lambda (input) (let ((r (funcall p input))) (if (parsing-p r) - (funcall (funcall f (parsing-tree r)) (parsing-left r)) + (funcall (the function (funcall f (parsing-tree r))) + (parsing-left r)) r)))) (defun discarding-bind (p f) + (declare (optimize (speed 3))) + (declare (type function p f)) (lambda (input) (let ((r (funcall p input))) (if (parsing-p r) - (funcall (funcall f) (parsing-left r)) + (funcall (the function (funcall f)) + (parsing-left r)) r)))) (defmacro comp (bindings &body body) @@ -41,9 +63,15 @@ `(new (progn ,@body)) (let ((v (first (car bindings))) (p (second (car bindings)))) - (if (string= (symbol-name v) "_") - `(discarding-bind ,p (lambda () (comp ,(cdr bindings) ,@body))) - `(bind ,p (lambda (,v) (comp ,(cdr bindings) ,@body))))))) + (if (eq 'symbol (type-of v)) + (if (string= (symbol-name v) "_") + `(discarding-bind ,p (lambda () (comp ,(cdr bindings) ,@body))) + `(bind ,p (lambda (,v) (comp ,(cdr bindings) ,@body)))) + (if (and (eq 'cons (type-of v)) + (eq 'symbol (type-of (car v))) + (eq 'symbol (type-of (cdr v)))) + `(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) @@ -82,10 +110,10 @@ (defun unit-if (&optional (predicate #'characterp)) (lambda (input) - (if (input::has-data? input) - (let ((c (input::peek input))) + (if (input:has-data? input) + (let ((c (input:peek input))) (if (funcall predicate c) - (make-parsing :tree c :left (input::advance input)) + (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.")))) @@ -97,21 +125,19 @@ (defun literal (target) (lambda (input) - (if (input::has-data? input (length target)) - (if (input::prefix? target input) - (make-parsing :tree target :left (input::advance input (length target))) + (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 "Not enough data.")))) + (make-normal-failure :place input :message "Reached end of input.")))) (defun not-literal (target) (lambda (input) - (if (input::has-data? input (length target)) - (if (input::prefix? target 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))) - (if (input::has-data? input) - (make-parsing :tree (input::peek input) :left (input::advance input)) - (make-normal-failure :place input :message "Reached end of input."))))) + (make-parsing :tree (input:peek input) :left (input:advance input))) + (make-normal-failure :place input :message "Reached end of input.")))) (defparameter nothing (new nil)) @@ -134,7 +160,3 @@ (if include-separator (cons v (cons sep vn)) (cons v vn)))) - -(defparameter whitespace - (comp ((_ (optional (many (unit-if (lambda (x) (or (char= x #\Space) (char= x #\Newline) (char= x #\Tab)))))))) - nil)) |