From aa7e4052fd22361ecf346ae1a2f6f30db0202c5c Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Juan=20Manuel=20Tom=C3=A1s?= <jtomas1815@gmail.com>
Date: Sat, 12 Oct 2024 02:16:30 -0300
Subject: Add surrounded parser

---
 parser.lisp | 58 +++++++++++++++++++++++++++++++++++++---------------------
 1 file changed, 37 insertions(+), 21 deletions(-)

(limited to 'parser.lisp')

diff --git a/parser.lisp b/parser.lisp
index 32d9d50..9d4be57 100644
--- a/parser.lisp
+++ b/parser.lisp
@@ -14,7 +14,8 @@
 
 (defstruct parsing
   tree
-  left)
+  left
+  limit)
 
 (defstruct failure
   place
@@ -32,7 +33,6 @@
     (declare (ignore lazy limit))
     (make-parsing :tree tree :left input)))
 
-; (parser<a> (a -> parser<b>) -> b)
 (defun bind (p f &key (greedy t))
   (lambda (input &key limit lazy)
     (let (r)
@@ -40,9 +40,10 @@
         (setf r (funcall p input))
         (let ((next-parser (funcall f nil input))
               (limit -1))
-          (do ((sweep-input input (advance sweep-input))) (limit nil)
-            (when (and (has-data? sweep-input)
-                       (functionp (funcall next-parser sweep-input t)))
+          (do ((sweep-input input (advance sweep-input)))
+            ((or (not (has-data? sweep-input))
+                 (> limit -1)) nil)
+            (when (functionp (funcall next-parser sweep-input :lazy t))
               (setf limit (input-sub sweep-input input))))
           (if (< limit 0)
             (setf r (make-failure :place input
@@ -55,30 +56,37 @@
             (funcall (funcall f (parsing-tree r) input)
                      (parsing-left r)
                      :lazy lazy
-                     :limit (if limit (1- limit))))
+                     :limit (parsing-limit r)))
           (funcall (funcall f (parsing-tree r) input)
                    (parsing-left r)
-                   :limit (if limit (1- limit))))
+                   :limit (parsing-limit r)))
         r))))
 
 (defmacro comp (bindings &body body)
   (if (null bindings)
     `(new (progn ,@body))
-    (let ((v (first (car bindings)))
-          (p (second (car bindings)))
+    (let ((var (first (car bindings)))
+          (parser (second (car bindings)))
+          (lazy (third (car bindings)))
           (unused (gensym)))
-      (if (symbolp v)
-        (if (string= (symbol-name v) "_")
-          `(bind ,p (lambda (&rest ,unused)
-                      (declare (ignore ,unused))
-                      (comp ,(cdr bindings) ,@body)))
-          `(bind ,p (lambda (,v &rest ,unused)
-                      (declare (ignore ,unused))
-                      (comp ,(cdr bindings) ,@body))))
-        (if (and (consp v) (symbolp (car v)) (symbolp (cdr v)))
-          `(bind ,p (lambda (,(car v) ,(cdr v) &rest ,unused)
-                      (declare (ignore ,unused))
-                      (comp ,(cdr bindings) ,@body)))
+      (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."))))))
 
 (defun one-of (first-parser second-parser &rest other-parsers)
@@ -174,3 +182,11 @@
         (if include-separator
           (cons v (cons sep vn))
           (cons v vn))))
+
+(defun surrounded (left p right &key include-surrounding)
+  (comp ((l left)
+         (body p :lazy)
+         (r right))
+        (if include-surrounding
+          (list l body r)
+          body)))
-- 
cgit v1.2.3