diff options
| -rw-r--r-- | base.lisp | 32 | ||||
| -rw-r--r-- | core.lisp | 63 | ||||
| -rw-r--r-- | cursor.lisp | 40 | ||||
| -rw-r--r-- | extra.lisp | 9 | ||||
| -rw-r--r-- | main.lisp | 17 | ||||
| -rw-r--r-- | monparser.asd | 8 | ||||
| -rw-r--r-- | test.lisp | 62 |
7 files changed, 177 insertions, 54 deletions
@@ -10,27 +10,39 @@ (message "") (priority 0)) +(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) (if (failure-place obj) - (let ((linecol (str:line-and-column (cursed:data (failure-place obj)) - (cursed:index (failure-place obj))))) + (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))) (format stream "~a~&" (failure-message obj)))) -(defun new (tree) - (lambda (input) - (make-parsing :tree tree :start input :end input))) - (defun fail (message &key (priority 1)) - (lambda (input) + (lambda (start input) + (declare (ignore start)) (make-failure :place input :message message :priority priority))) +(defun new (tree) + (lambda (start input) + (make-parsing :tree tree :start start :end input))) + (defun bind (parser f) - (lambda (input) - (let ((r (funcall parser input))) + (lambda (start input) + (let ((r (funcall parser input input))) (cond ((parsing-p r) - (funcall (funcall f r) (parsing-end r))) + (funcall (funcall f r) start (parsing-end r))) ((failure-p r) r) (t (error (format nil "Invalid return value: ~a" r))))))) @@ -3,6 +3,14 @@ (defparameter nothing (new nil)) +(defun normalize (sym expression) + (nsubst-if sym + (lambda (x) + (and (symbolp x) + (string-equal (symbol-name x) + (symbol-name sym)))) + expression)) + (defmacro unit (&optional predicate) (cond ((null predicate) (setf predicate 't)) @@ -14,29 +22,31 @@ (if (eq (car predicate) 'function) (setf predicate `(funcall ,predicate it)) (setf predicate - (symbol:normalize 'it predicate)))) + (normalize 'it predicate)))) (t (error (format nil "Invalid predicate: ~a." predicate)))) - `(lambda (input) - (if (cursed:has-data? input) - (let ((it (cursed:peek input))) + `(lambda (start input) + (declare (ignore start)) + (if (has-data? input) + (let ((it (peek input))) (if ,predicate (make-parsing :tree it :start input - :end (cursed:advance input)) + :end (advance input)) (make-failure :place input :message (format nil "Expected: ~a, Got: ~:c." ',predicate it)))) (make-failure :place input :message (format nil "Reached end of input. Expected: ~a." ',predicate))))) (defun one-of (first-parser second-parser &rest other-parsers) - (lambda (input) + (lambda (start input) + (declare (ignore start)) (let ((parsers (cons first-parser (cons second-parser other-parsers))) (result (make-failure :place input))) (dolist (p parsers) - (let ((r (funcall p input))) + (let ((r (funcall p input input))) (cond ((parsing-p r) (when (or (not (parsing-p result)) - (> (cursed:distance (parsing-end result) + (> (distance (parsing-end result) (parsing-end r)) 0)) (setf result r))) @@ -46,7 +56,7 @@ (failure-priority result)))) (when (or (> priority-cmp 0) (and (= priority-cmp 0) - (>= (cursed:distance (failure-place result) + (>= (distance (failure-place result) (failure-place r)) 0))) (setf result r))))) @@ -57,19 +67,22 @@ (one-of p nothing)) (defun many (p &key all) - (lambda (input) - (let* ((result '()) - (input-left input) - (last-failure - (do ((r (funcall p input-left) (funcall p input-left))) ((failure-p r) r) - (when (parsing-p r) - (setf input-left (parsing-end r)) - (when (parsing-tree r) - (push (parsing-tree r) result)))))) - (if (or (not result) - (and result all (cursed:has-data? (failure-place last-failure)))) - (make-failure :place (failure-place last-failure) - :message (failure-message last-failure)) - (make-parsing :tree (reverse result) - :start input - :end input-left))))) + (lambda (start input) + (declare (ignore start)) + (let* ((result '())) + (do ((r (funcall p input input) + (funcall p (parsing-end r) (parsing-end r)))) + ((or (failure-p r) + (= (index (parsing-start r)) + (index (parsing-end r)))) + nil) + (push r result)) + (cond ((not result) + (make-failure :place input + :message "No matches.")) + ((and all (has-data? (parsing-end (first result)))) + (make-failure :place (parsing-end (first result)) + :message "Input not exausted.")) + (t (make-parsing :tree (reverse (mapcar (lambda (x) (parsing-tree x)) result)) + :start input + :end (parsing-end (first result)))))))) diff --git a/cursor.lisp b/cursor.lisp new file mode 100644 index 0000000..321ec3b --- /dev/null +++ b/cursor.lisp @@ -0,0 +1,40 @@ +(in-package #:monparser) + +(defclass text () + ((index :type (unsigned-byte 44) :initarg :index :accessor index :initform 0) + (data :type simple-string :initarg :data :reader data :initform ""))) + +(defun has-data? (cursor) + (< (index cursor) (length (data cursor)))) + +(defun peek (cursor) + (char (data cursor) + (index cursor))) + +(defun advance (cursor) + (make-instance 'text + :data (data cursor) + :index (+ (index cursor) 1))) + +(defun distance (from to) + (- (index to) + (index from))) + +(defun context-window (str index &key (side-length 20)) + (let ((begin (max (- index side-length) 0)) + (end (min (+ index side-length) (length str))) + (result '())) + (push (subseq str (1+ index) end) result) + (push (elt str index) result) + (push (subseq str begin index) result) + result)) + +(defmethod print-object ((obj text) stream) + (print-unreadable-object (obj stream :type t) + (let ((str (if (has-data? obj) + (format nil "~{~a[4;33m~a[m~a~}" + (context-window (data obj) + (index obj) + :side-length 10)) + "END OF DATA"))) + (format stream "~s" (substitute #\~ #\Newline str))))) @@ -1,13 +1,8 @@ (in-package #:monparser) (defparameter whitespace - (many (unit #'char:whitespace?))) - -(defparameter end-of-input - (lambda (input) - (if (cursed:has-data? input) - (make-failure :place input :message "Didn't reach end of input.") - (make-parsing :tree nil :start input :end input)))) + (many (unit (or (char= it #\Space) + (not (graphic-char-p it)))))) (defun repeat (p min &optional (max 0)) (if (> min 0) @@ -1,17 +1,16 @@ (in-package #:monparser) (defun parse (parser data) - (let* ((result (funcall parser - (make-instance 'cursed:text - :data data)))) - (if (parsing-p result) - (let ((finished? (not (cursed:has-data? (parsing-end result))))) - (values (parsing-tree result) finished?)) - result))) + (if (typep data 'string) + (funcall parser + (make-instance 'text :data data) + (make-instance 'text :data data)) + (error "Only string parsing is allowed."))) (defun append-on-failure (p message) - (lambda (input) - (let ((result (funcall p input))) + (lambda (start input) + (declare (ignore start)) + (let ((result (funcall p input input))) (if (failure-p result) (make-failure :place (failure-place result) :message (concatenate 'string message (failure-message result)) diff --git a/monparser.asd b/monparser.asd index 37e47b1..f9ee915 100644 --- a/monparser.asd +++ b/monparser.asd @@ -1,9 +1,11 @@ -(defsystem #:monparser +(defsystem "monparser" :serial t - :depends-on (#:utils #:cursed) + :depends-on () :components ((:file "package") + (:file "cursor") (:file "base") (:file "core") (:file "extra") - (:file "main"))) + (:file "main") + (:file "test"))) diff --git a/test.lisp b/test.lisp new file mode 100644 index 0000000..b0ffdc2 --- /dev/null +++ b/test.lisp @@ -0,0 +1,62 @@ +(in-package #:monparser) + +(defmacro deftest (title &body tests) + (let ((result '(progn))) + (push `(format t "~a:~&" ,title) result) + (dolist (test tests) + (let ((parser (first test)) + (input (second test))) + (push `(format t "~a~&" (parse ,parser ,input)) result))) + (push '(format t "~%") result) + (reverse result))) + +(defun test () + (deftest "unit" + ((unit) "hello") + ((unit #\h) "hello")) + (deftest "many" + ((many (unit #\h)) "hello") + ((many (unit #\h)) "hhhhhhhello") + ((many (unit #\h)) "ello")) + (deftest "optional many" + ((optional (many (unit #\h))) "hello") + ((optional (many (unit #\h))) "hhhhhhhello") + ((optional (many (unit #\h))) "ello")) + (deftest "many optional" + ((many (optional (unit #\h))) "hello") + ((many (optional (unit #\h))) "hhhhhhhello") + ((many (optional (unit #\h))) "ello")) + (deftest "until literal" + ((comp ((prefix (optional (literal "zy"))) + (match (if prefix + (fail "Reached prefix") + (unit)))) + match) + "zy") + ((comp (((prefix) (optional (literal "zy"))) + ((match) (if (parsing-tree prefix) + (fail "Reached prefix") + (progn + (format t "prefix start: ~a, end: ~a~&" + (parsing-start prefix) + (parsing-end prefix)) + (unit))))) + (format t "match start: ~a, end: ~a~&" + (parsing-start match) + (parsing-end match)) + match) + "ezy") + ((many (comp ((prefix (optional (literal "zy"))) + (match (if prefix + (fail "Reached prefix") + (unit)))) + match)) + "the quick brown fox jumps over the lazy dog.") + ((optional + (many + (comp ((prefix (optional (literal "zy"))) + (match (if prefix + (fail "Reached prefix") + (unit)))) + match))) + "the quick brown fox jumps over the lazy dog."))) |