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.

3 files changed, 88 insertions, 55 deletions

diff --git a/input.lisp b/input.lisp
index 8b031fd..a96888f 100644
--- a/input.lisp
+++ b/input.lisp
@@ -1,43 +1,43 @@
 (in-package #:input)
 
-(defstruct input
-  (cursor 0)
-  (file nil :read-only t)
-  (data nil :read-only t))
+(defclass input ()
+  ((cursor :initarg :cursor :accessor cursor :initform 0)
+   (file :initarg :file :reader file :initform nil)
+   (data :initarg :data :reader data :initform nil)))
 
-(defun has-data? (input &optional (window-size 1))
-  (<= (+ window-size (input-cursor input))
-      (length (input-data input))))
+(defun has-data? (input)
+  (< (cursor input) (length (data input))))
 
 (defun prefix? (target input)
-  (string= target (input-data input) :start2 (input-cursor input) :end2 (+ (input-cursor input) (length target))))
+  (string= target
+           (data input)
+           :start2 (cursor input)
+           :end2 (min (+ (cursor input) (length target))
+                      (length (data input)))))
 
 (defun peek (input)
-  (char (input-data input)
-        (input-cursor input)))
+  (char (data input)
+        (cursor input)))
 
 (defun advance (input &optional (amount 1))
-  (let ((new-input (copy-structure input)))
-    (incf (input-cursor new-input) amount)
-    new-input))
+  (make-instance 'input
+                 :data (data input)
+                 :file (file input)
+                 :cursor (1+ (cursor input))))
 
-(declaim (ftype (function (simple-string) (values input &optional)) from-string))
 (defun from-string (str)
-  (make-input :data str))
+  (make-instance 'input :data str))
 
-(declaim (ftype (function (simple-string) (values input &optional)) from-file))
 (defun from-file (filename)
-  (make-input :file filename :data (str:read-file filename)))
+  (make-instance 'input :file filename :data (str:read-file filename)))
 
-(defun generate-report (input message)
+(defun line-and-column (input)
   (let ((line 1) (column 1))
-    (dotimes (i (input-cursor input))
-      (let ((c (char (input-data input) i)))
+    (dotimes (i (cursor input))
+      (let ((c (char (data input) i)))
         (case c
           (#\Newline
            (incf line)
            (setf column 1))
           (t (incf column)))))
-    (if (input-file input)
-      (format nil "~a:~a:~a: ~a" (input-file input) line column message)
-      (format nil "~a:~a: ~a" line column message))))
+    (values line column)))
diff --git a/package.lisp b/package.lisp
index 6e868f9..5936a52 100644
--- a/package.lisp
+++ b/package.lisp
@@ -1,11 +1,23 @@
 (defpackage #:input
   (:use #:cl)
-  (:export #:from-string
+  (:export #:file
+           #:data
+           #:cursor
+           #:line-and-column
+           #:has-data?
+           #:prefix?
+           #:peek
+           #:advance
+           #:from-string
            #:from-file))
 
 (defpackage #:parser
   (:use #:cl)
-  (:export #:run
+  (:export #:parsing-p
+           #:parsing-tree
+           #:parsing-left
+           #:failure-place
+           #:failure-message
            #:fail
            #:comp
            #:one-of
@@ -19,5 +31,4 @@
            #:nothing
            #:optional
            #:many
-           #:separated-list
-           #:whitespace))
+           #:separated-list))
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))