From aa378b3568b7dbb05de0de9f17abaae03863058a Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Juan=20Manuel=20Tom=C3=A1s?= <jtomas1815@gmail.com>
Date: Mon, 1 May 2023 23:03:53 -0300
Subject: Improve flexibility

This will make it easier to run the parser in a multi-stage
setup without sacrificing the standalone setups.

Modified comp to extract the location of parsed things.

I expose the parts of the Input, Parsing and Failure objects
to customize error handling.

Parsing and Failure objects have a default printer now.
---
 parser.lisp | 78 +++++++++++++++++++++++++++++++++++++++----------------------
 1 file changed, 50 insertions(+), 28 deletions(-)

(limited to 'parser.lisp')

diff --git a/parser.lisp b/parser.lisp
index c07120d..a48f6e3 100644
--- a/parser.lisp
+++ b/parser.lisp
@@ -1,19 +1,25 @@
 (in-package #:parser)
 
-(defun run (p input)
-  (let ((r (funcall p input)))
-    (if (parsing-p r)
-      (parsing-tree r)
-      (input::generate-report (failure-place r) (failure-message r)))))
-
 (defstruct parsing
   tree
   left)
 
+(defmethod print-object ((obj parsing) stream)
+  (print-unreadable-object (obj stream :type t)
+    (format stream "~a" (parsing-tree obj))))
+
 (defstruct failure
   place
   message)
 
+(defmethod print-object ((obj failure) stream)
+  (print-unreadable-object (obj stream :type t)
+    (let ((file (input:file (failure-place obj))))
+      (if file
+        (multiple-value-bind (line column) (input:line-and-column (failure-place obj))
+          (format stream "~a:~a:~a: ~a" line column file (failure-message obj)))
+        (format stream "~a: ~a" (input:cursor (failure-place obj)) (failure-message obj))))))
+
 (defstruct (normal-failure (:include failure)))
 
 (defstruct (critical-failure (:include failure)))
@@ -22,18 +28,34 @@
   (lambda (input)
     (make-parsing :tree tree :left input)))
 
+(defun bind-with-input (p f)
+  (declare (optimize (speed 3)))
+  (declare (type function p f))
+  (lambda (input)
+    (let ((r (funcall p input)))
+      (if (parsing-p r)
+        (funcall (the function (funcall f (parsing-tree r) input))
+                 (parsing-left r))
+        r))))
+
 (defun bind (p f)
+  (declare (optimize (speed 3)))
+  (declare (type function p f))
   (lambda (input)
     (let ((r (funcall p input)))
       (if (parsing-p r)
-        (funcall (funcall f (parsing-tree r)) (parsing-left r))
+        (funcall (the function (funcall f (parsing-tree r)))
+                 (parsing-left r))
         r))))
 
 (defun discarding-bind (p f)
+  (declare (optimize (speed 3)))
+  (declare (type function p f))
   (lambda (input)
     (let ((r (funcall p input)))
       (if (parsing-p r)
-        (funcall (funcall f) (parsing-left r))
+        (funcall (the function (funcall f))
+                 (parsing-left r))
         r))))
 
 (defmacro comp (bindings &body body)
@@ -41,9 +63,15 @@
     `(new (progn ,@body))
     (let ((v (first (car bindings)))
           (p (second (car bindings))))
-      (if (string= (symbol-name v) "_")
-        `(discarding-bind ,p (lambda () (comp ,(cdr bindings) ,@body)))
-        `(bind ,p (lambda (,v) (comp ,(cdr bindings) ,@body)))))))
+      (if (eq 'symbol (type-of v))
+        (if (string= (symbol-name v) "_")
+          `(discarding-bind ,p (lambda () (comp ,(cdr bindings) ,@body)))
+          `(bind ,p (lambda (,v) (comp ,(cdr bindings) ,@body))))
+        (if (and (eq 'cons (type-of v))
+                 (eq 'symbol (type-of (car v)))
+                 (eq 'symbol (type-of (cdr v))))
+          `(bind-with-input ,p (lambda (,(car v) ,(cdr v)) (comp ,(cdr bindings) ,@body)))
+          (error "Binding name/(name,input) must be either a symbol or a cons of symbols."))))))
 
 (defun fail (&optional (message "Unknown error."))
   (lambda (input)
@@ -82,10 +110,10 @@
 
 (defun unit-if (&optional (predicate #'characterp))
   (lambda (input)
-    (if (input::has-data? input)
-      (let ((c (input::peek input)))
+    (if (input:has-data? input)
+      (let ((c (input:peek input)))
         (if (funcall predicate c)
-          (make-parsing :tree c :left (input::advance input))
+          (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."))))
 
@@ -97,21 +125,19 @@
 
 (defun literal (target)
   (lambda (input)
-    (if (input::has-data? input (length target))
-      (if (input::prefix? target input)
-        (make-parsing :tree target :left (input::advance input (length target)))
+    (if (input:has-data? input)
+      (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."))))
+      (make-normal-failure :place input :message "Reached end of input."))))
 
 (defun not-literal (target)
   (lambda (input)
-    (if (input::has-data? input (length target))
-      (if (input::prefix? target input)
+    (if (input:has-data? input)
+      (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.")))))
+        (make-parsing :tree (input:peek input) :left (input:advance input)))
+      (make-normal-failure :place input :message "Reached end of input."))))
 
 (defparameter nothing
   (new nil))
@@ -134,7 +160,3 @@
     (if include-separator
       (cons v (cons sep vn))
       (cons v vn))))
-
-(defparameter whitespace
-  (comp ((_ (optional (many (unit-if (lambda (x) (or (char= x #\Space) (char= x #\Newline) (char= x #\Tab))))))))
-    nil))
-- 
cgit v1.2.3