From f3cc5d4cc7e722e44fe92e63a66983dfb012395c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Juan=20Manuel=20Tom=C3=A1s?= Date: Sat, 17 Dec 2022 03:48:05 -0300 Subject: Add negate operator and polish literals --- parser.lisp | 97 +++++++++++++++++++++++++++++++++---------------------------- 1 file changed, 52 insertions(+), 45 deletions(-) (limited to 'parser.lisp') diff --git a/parser.lisp b/parser.lisp index a92355c..55ded57 100644 --- a/parser.lisp +++ b/parser.lisp @@ -36,81 +36,88 @@ (funcall q (parsing-left r)) r)))) +(defmacro comp (bindings &body body) + (if (null bindings) + `(new (progn ,@body)) + (let ((v (first (car bindings))) + (p (second (car bindings)))) + (if (string= (symbol-name v) "_") + `(discarding-bind ,p (comp ,(cdr bindings) ,@body)) + `(bind ,p (lambda (,v) (comp ,(cdr bindings) ,@body))))))) + (defun fail (&optional (message "Unknown error.")) (lambda (input) (make-critical-failure :place input :message message))) -(defun either (first-parser second-parser &rest other-parsers) +(defun one-of (first-parser second-parser &rest other-parsers) (lambda (input) - (labels ((either-rec (body) + (labels ((one-of-rec (body) (if (cdr body) (let ((r (funcall (car body) input))) (if (normal-failure-p r) - (either-rec (cdr body)) + (one-of-rec (cdr body)) r)) (funcall (car body) input)))) - (either-rec (cons first-parser (cons second-parser other-parsers)))))) + (one-of-rec (cons first-parser (cons second-parser other-parsers)))))) -(defun unit (predicate) +(defun all-of (first-parser second-parser &rest other-parsers) (lambda (input) - (if (input::has-data? input) - (let ((c (input::peek-1 input))) - (if (char= c predicate) - (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.")))) + (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 not-unit (predicate) +(defun negate (p) (lambda (input) - (if (input::has-data? input) - (let ((c (input::peek-1 input))) - (if (char/= c predicate) - (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.")))) + (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))))) (defun unit-if (&optional (predicate #'characterp)) (lambda (input) (if (input::has-data? input) - (let ((c (input::peek-1 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 literal (predicate) - (lambda (input) - (if (input::has-data? input (length predicate)) - (let ((c (input::peek-n input (length predicate)))) - (if (string= predicate c) - (make-parsing :tree c :left (input::advance input (length c))) - (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)))) -(defun until-literal (predicate) +(defun literal (target) (lambda (input) - (let ((c (search predicate (input::input-data input) :start2 (input::input-cursor input)))) - (if c - (let ((window (- c (input::input-cursor input)))) - (if (> window 0) - (make-parsing :tree (input::peek-n input window) :left (input::advance input window)) - (make-failure :place input :message "Predicate not satisfied."))) - (make-parsing :tree (input::peek-rest input) :left (input::advance-to-end input)))))) + (if (input::has-data? input (length target)) + (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.")))) -(defmacro comp (bindings &body body) - (if (null bindings) - `(new (progn ,@body)) - (let ((v (first (car bindings))) - (p (second (car bindings)))) - (if (eq v '_) - `(discarding-bind ,p (comp ,(cdr bindings) ,@body)) - `(bind ,p (lambda (,v) (comp ,(cdr bindings) ,@body))))))) +(defun not-literal (target) + (lambda (input) + (if (input::has-data? input (length target)) + (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."))))) (defparameter nothing (new nil)) (defun optional (p) - (either p nothing)) + (one-of p nothing)) (defun many (p) (comp ((x p) @@ -121,7 +128,7 @@ (comp ((v p) (sep (optional separator)) (vn (if sep - (either (separated-list p separator) + (one-of (separated-list p separator) (fail "Value expected.")) nothing))) (if include-separator -- cgit v1.2.3