diff options
| -rw-r--r-- | base.lisp | 44 | ||||
| -rw-r--r-- | core.lisp | 73 | ||||
| -rw-r--r-- | extra.lisp | 41 | ||||
| -rw-r--r-- | input.lisp | 43 | ||||
| -rw-r--r-- | main.lisp | 13 | ||||
| -rw-r--r-- | monparser.asd | 3 | ||||
| -rw-r--r-- | package.lisp | 17 | ||||
| -rw-r--r-- | quant.lisp | 33 |
8 files changed, 117 insertions, 150 deletions
@@ -2,7 +2,8 @@ (defstruct parsing tree - left) + start + end) (defstruct failure place @@ -11,21 +12,48 @@ (defmethod print-object ((obj failure) stream) (if (failure-place obj) - (multiple-value-bind (line column) (line-and-column (failure-place obj)) + (let ((linecol (str:line-and-column (cursed:data (failure-place obj)) + (cursed:index (failure-place obj))))) (format stream "~a:~a: ~a~&~a~&" - line column (failure-message obj) (failure-place obj))) + (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 :left input))) + (make-parsing :tree tree :start input :end input))) + +(defun fail (message &key (priority 1)) + (lambda (input) + (make-failure :place input :message message :priority priority))) (defun bind (parser f) (lambda (input) (let ((r (funcall parser input))) (cond ((parsing-p r) - (funcall (funcall f (parsing-tree r) input) - (parsing-left r))) - ((failure-p r) - r) + (funcall (funcall f r) (parsing-end r))) + ((failure-p r) r) (t (error (format nil "Invalid return value: ~a" r))))))) + +(defmacro comp (bindings &body body) + (if (null bindings) + `(new (progn ,@body)) + (let ((var (first (car bindings))) + (parser (second (car bindings))) + (unused (gensym))) + (cond ((symbolp var) + (if (string= (symbol-name var) "_") + `(bind ,parser + (lambda (&rest ,unused) + (declare (ignore ,unused)) + (comp ,(cdr bindings) ,@body))) + `(bind ,parser + (lambda (,var &rest ,unused) + (let ((,var (parsing-tree ,var))) + (declare (ignore ,unused)) + (comp ,(cdr bindings) ,@body)))))) + ((and (listp var) (= (length var) 1) (symbolp (car var))) + `(bind ,parser + (lambda (,(first var) &rest ,unused) + (declare (ignore ,unused)) + (comp ,(cdr bindings) ,@body)))) + (t (error "Binding must be either a symbol or a list of one symbol.")))))) @@ -1,8 +1,7 @@ (in-package #:monparser) -(defun fail (message &key (priority 1)) - (lambda (input) - (make-failure :place input :message message :priority priority))) +(defparameter nothing + (new nil)) (defmacro unit (&optional predicate) (cond ((null predicate) @@ -15,16 +14,15 @@ (if (eq (car predicate) 'function) (setf predicate `(funcall ,predicate it)) (setf predicate - (nsubst-if 'it - (lambda (x) - (and (symbolp x) - (string-equal (symbol-name x) "IT"))) predicate)))) + (symbol:normalize 'it predicate)))) (t (error (format nil "Invalid predicate: ~a." predicate)))) `(lambda (input) - (if (has-data? input) - (let ((it (peek input))) + (if (cursed:has-data? input) + (let ((it (cursed:peek input))) (if ,predicate - (make-parsing :tree it :left (advance input)) + (make-parsing :tree it + :start input + :end (cursed:advance input)) (make-failure :place input :message (format nil "Expected: ~a, Got: ~:c." ',predicate it)))) (make-failure :place input @@ -32,14 +30,15 @@ (defun one-of (first-parser second-parser &rest other-parsers) (lambda (input) - (let ((parsers `(,first-parser ,second-parser ,@other-parsers)) + (let ((parsers (cons first-parser (cons second-parser other-parsers))) (result (make-failure :place input))) (dolist (p parsers) (let ((r (funcall p input))) (cond ((parsing-p r) (when (or (not (parsing-p result)) - (> (input-cursor (parsing-left r)) - (input-cursor (parsing-left result)))) + (> (cursed:distance (parsing-end result) + (parsing-end r)) + 0)) (setf result r))) ((failure-p r) (when (failure-p result) @@ -47,32 +46,30 @@ (failure-priority result)))) (when (or (> priority-cmp 0) (and (= priority-cmp 0) - (>= (input-cursor (failure-place r)) - (input-cursor (failure-place result))))) + (>= (cursed:distance (failure-place result) + (failure-place r)) + 0))) (setf result r))))) (t (error (format nil "Invalid return value: ~a." r)))))) result))) -;;; TODO: Find a way to be able to use the input without needing to define a name for it. -(defmacro comp (bindings &body body) - (if (null bindings) - `(new (progn ,@body)) - (let ((var (first (car bindings))) - (parser (second (car bindings))) - (unused (gensym))) - (if (symbolp var) - (if (string= (symbol-name var) "_") - `(bind ,parser - (lambda (&rest ,unused) - (declare (ignore ,unused)) - (comp ,(cdr bindings) ,@body))) - `(bind ,parser - (lambda (,var &rest ,unused) - (declare (ignore ,unused)) - (comp ,(cdr bindings) ,@body)))) - (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))) - (error "Binding must be either a symbol or a cons of symbols.")))))) +(defun optional (p) + (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))))) @@ -1,11 +1,24 @@ (in-package #:monparser) -(defun whitespace? (x) - (or (char= x #\Space) - (not (graphic-char-p x)))) - (defparameter whitespace - (many (unit #'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)))) + +(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))) (defmacro literal (word) (when (not (stringp word)) @@ -20,13 +33,13 @@ `(comp ,(reverse binding-list) ,(cons 'list (reverse name-list))))) -(defun separated-list (p separator) - (many - (comp ((v p) - (_ (optional separator))) - v))) +(defmacro within (left p right) + `(comp ((_ ,left) + (cell ,p) + (_ ,right)) + cell)) -(defun surround (left p &optional right) - (comp ((_ left) - (value p) - (_ (or right nothing))))) +(defmacro interlinked (p separator) + `(many (comp ((cell ,p) + (_ (optional ,separator))) + cell))) diff --git a/input.lisp b/input.lisp deleted file mode 100644 index e464d0e..0000000 --- a/input.lisp +++ /dev/null @@ -1,43 +0,0 @@ -(in-package #:monparser) - -(defclass parser-input () - ((cursor :initarg :cursor :accessor input-cursor :initform 0) - (data :initarg :data :reader input-data :initform nil))) - -(defun has-data? (input) - (< (input-cursor input) (length (input-data input)))) - -(defun peek (input) - (char (input-data input) - (input-cursor input))) - -(defun advance (input) - (make-instance 'parser-input - :data (input-data input) - :cursor (+ (input-cursor input) 1))) - -(defun line-and-column (input) - (let ((line 1) (column 1)) - (dotimes (i (input-cursor input)) - (let ((c (char (input-data input) i))) - (case c - (#\Newline - (incf line) - (setf column 1)) - (t (incf column))))) - (values line column))) - -(defmethod print-object ((obj parser-input) stream) - (let ((context-length 20)) - (let ((begin (max (- (input-cursor obj) context-length) 0)) - (end (min (+ (input-cursor obj) context-length) (length (input-data obj))))) - (when (< 0 begin) - (format stream "...")) - (format stream "~a" - (substitute #\↲ #\Newline (subseq (input-data obj) begin (input-cursor obj)))) - (when (< (input-cursor obj) (length (input-data obj))) - (format stream "[4;33m~a[m~a" - (substitute #\↲ #\Newline (subseq (input-data obj) (input-cursor obj) (1+ (input-cursor obj)))) - (substitute #\↲ #\Newline (subseq (input-data obj) (1+ (input-cursor obj)) end)))) - (when (< end (length (input-data obj))) - (format stream "..."))))) @@ -2,10 +2,10 @@ (defun parse (parser data) (let* ((result (funcall parser - (make-instance 'parser-input + (make-instance 'cursed:text :data data)))) (if (parsing-p result) - (let ((finished? (not (has-data? (parsing-left result))))) + (let ((finished? (not (cursed:has-data? (parsing-end result))))) (values (parsing-tree result) finished?)) result))) @@ -20,6 +20,9 @@ (defmacro defparser (name args parser) (let ((message (format nil "In ~a:~&" name))) - (if (null args) - `(defparameter ,name (append-on-failure ,parser ,message)) - `(defun ,name ,args (append-on-failure ,parser ,message))))) + (cond ((equal args :const) + `(defparameter ,name (append-on-failure ,parser ,message))) + ((listp args) + `(defun ,name ,args (append-on-failure ,parser ,message))) + (t (error + (format nil "Cannot define ~a: ~a is not :const or a list." name args)))))) diff --git a/monparser.asd b/monparser.asd index 68165a9..37e47b1 100644 --- a/monparser.asd +++ b/monparser.asd @@ -1,10 +1,9 @@ (defsystem #:monparser :serial t + :depends-on (#:utils #:cursed) :components ((:file "package") - (:file "input") (:file "base") (:file "core") - (:file "quant") (:file "extra") (:file "main"))) diff --git a/package.lisp b/package.lisp index dca5908..e3882c6 100644 --- a/package.lisp +++ b/package.lisp @@ -2,22 +2,25 @@ (:use #:cl) (:export #:parse #:defparser + #:parsing + #:parsing-p + #:parsing-tree + #:parsing-start + #:parsing-end + #:failure #:failure-p #:failure-place #:failure-message - #:fail #:unit #:one-of #:comp - #:nothing #:optional #:many #:repeat - - #:literal - #:whitespace? #:whitespace - #:separated-list - #:surround)) + #:end-of-input + #:literal + #:within + #:interlinked)) diff --git a/quant.lisp b/quant.lisp deleted file mode 100644 index bdd0cfc..0000000 --- a/quant.lisp +++ /dev/null @@ -1,33 +0,0 @@ -(in-package #:monparser) - -(defparameter nothing - (new nil)) - -(defun optional (p) - (one-of p nothing)) - -(defun many (p &key all) - (lambda (input) - (let* ((result '()) - (last-failure - (do ((r (funcall p input) (funcall p input))) ((failure-p r) r) - (when (parsing-p r) - (setf input (parsing-left r)) - (when (parsing-tree r) - (push (parsing-tree r) result)))))) - (if (or (not result) - (and result all (has-data? (failure-place last-failure)))) - (make-failure :place input :message (failure-message last-failure)) - (make-parsing :tree (reverse result) :left input))))) - -; TODO: Need to be redone in a non-recursive way -(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))) |