diff options
author | Juan Manuel Tomás <jtomas1815@gmail.com> | 2024-10-13 00:34:11 -0300 |
---|---|---|
committer | Juan Manuel Tomás <jtomas1815@gmail.com> | 2024-10-13 00:34:11 -0300 |
commit | 7a6f4586c2e83ffcdb5a8b7b2c5591f6e80e038f (patch) | |
tree | 441e462d4145c95e4aad94c7e64b89ddca667e6c /core.lisp | |
parent | b196a5d56db31d6836c1ed028f38146cbb08436c (diff) | |
download | monparser-7a6f4586c2e83ffcdb5a8b7b2c5591f6e80e038f.tar.gz monparser-7a6f4586c2e83ffcdb5a8b7b2c5591f6e80e038f.zip |
Change project file structure and api
Diffstat (limited to 'core.lisp')
-rw-r--r-- | core.lisp | 83 |
1 files changed, 83 insertions, 0 deletions
diff --git a/core.lisp b/core.lisp new file mode 100644 index 0000000..d0955fe --- /dev/null +++ b/core.lisp @@ -0,0 +1,83 @@ +(in-package #:monparser) + +(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."))))) + +(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)))))) + +(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.")))))) |