Unify cursor start and endHEADmain

1 files changed, 25 insertions, 38 deletions

diff --git a/base.lisp b/base.lisp
index 0599a3c..7c72501 100644
--- a/base.lisp
+++ b/base.lisp
@@ -1,61 +1,48 @@
 (in-package #:monparser)
 
-(defstruct result)
+(defstruct result
+  (place (make-instance 'cursor) :type cursor))
 
 (defstruct (parsing (:include result))
-  tree
-  (start (make-instance 'cursor) :type cursor)
-  (end (make-instance 'cursor) :type cursor))
+  tree)
 
 (defstruct (failure (:include result))
-  (place (make-instance 'cursor) :type cursor)
   (message "" :type string)
   (priority 0 :type integer))
 
+(defmethod print-object ((obj failure) stream)
+  (let ((linecol (line-and-column (result-place obj))))
+    (format stream "~a:~a: ~a~&~a~&"
+            (car linecol) (cdr linecol) (failure-message obj) (result-place obj))))
+
 (deftype parser ()
-  `(function (cursor cursor) result))
+  `(function (cursor) result))
 
 (defmacro lazy (parser &rest args)
-  (let ((start (gensym))
-        (input (gensym)))
+  (let ((input (gensym)))
     `(the parser
-          (lambda (,start ,input)
-            (funcall (,parser ,@args) ,start ,input)))))
-
-(defun line-and-column (str index)
-  (let ((line 1) (column 1))
-    (dotimes (i index)
-      (let ((c (char str i)))
-        (case c
-          (#\Newline
-           (incf line)
-           (setf column 1))
-          (t (incf column)))))
-    (cons line column)))
-
-(defmethod print-object ((obj failure) stream)
-  (let ((linecol (line-and-column (data (failure-place obj))
-                                  (index (failure-place obj)))))
-    (format stream "~a:~a: ~a~&~a~&"
-            (car linecol) (cdr linecol) (failure-message obj) (failure-place obj))))
+          (lambda (,input)
+            (funcall (,parser ,@args) ,input)))))
 
 (declaim (ftype (function (t &key (:priority integer)) parser) fail))
 (defun fail (message &key (priority 1))
-  (lambda (start input)
-    (declare (ignore start))
+  (lambda (input)
     (make-failure :place input :message message :priority priority)))
 
 (declaim (ftype (function (t) parser) new))
 (defun new (tree)
-  (lambda (start input)
-    (make-parsing :tree tree :start start :end input)))
+  (lambda (input)
+    (make-parsing :place input :tree tree)))
+
+(deftype parser-continuation ()
+  `(function (t) parser))
 
-(declaim (ftype (function (parser (function (result) parser)) parser) bind))
+(declaim (ftype (function (parser parser-continuation) parser) bind))
 (defun bind (parser f)
-  (lambda (start input)
-    (let ((r (funcall parser input input)))
+  (lambda (input)
+    (let ((r (funcall parser (cursor-rebase input))))
       (cond ((parsing-p r)
-             (funcall (funcall f r) start (parsing-end r)))
+             (funcall (funcall f r) (cursor-merge input (result-place r))))
             ((failure-p r) r)
             (t (error (format nil "Invalid return value: ~a" r)))))))
 
@@ -67,18 +54,18 @@
       (cond ((symbolp var)
              (if (string= (symbol-name var) "_")
                `(bind ,parser
-                      (the (function (result) parser)
+                      (the parser-continuation
                            (lambda (,var)
                              (declare (ignore ,var))
                              (comp ,(cdr bindings) ,@body))))
                `(bind ,parser
-                      (the (function (result) parser)
+                      (the parser-continuation
                            (lambda (,var)
                              (let ((,var (parsing-tree ,var)))
                                (comp ,(cdr bindings) ,@body)))))))
             ((and (listp var) (= (length var) 1) (symbolp (car var)))
              `(bind ,parser
-                    (the (function (result) parser)
+                    (the parser-continuation
                          (lambda (,(first var))
                            (comp ,(cdr bindings) ,@body)))))
             (t (error "Binding must be either a symbol or a list of one symbol."))))))