Update parser interface

6 files changed, 75 insertions, 71 deletions

diff --git a/base.lisp b/base.lisp
index 61c47bc..6887f0a 100644
--- a/base.lisp
+++ b/base.lisp
@@ -6,25 +6,26 @@
 
 (defstruct failure
   place
-  message)
+  (message "")
+  (priority 0))
+
+(defmethod print-object ((obj failure) stream)
+  (if (failure-place obj)
+    (multiple-value-bind (line column) (line-and-column (failure-place obj))
+      (format stream "~a:~a: ~a~&~a~&"
+              line column (failure-message obj) (failure-place obj)))
+    (format stream "~a~&" (failure-message obj))))
 
 (defun new (tree)
-  (lambda (input &key lazy)
-    (declare (ignore lazy))
+  (lambda (input)
     (make-parsing :tree tree :left input)))
 
 (defun bind (parser f)
-  (lambda (input &key lazy)
+  (lambda (input)
     (let ((r (funcall parser input)))
       (cond ((parsing-p r)
-             (if lazy
-               (lambda (ignored-input &key lazy)
-                 (declare (ignore ignored-input))
-                 (funcall (funcall f (parsing-tree r) input)
-                          (parsing-left r)
-                          :lazy lazy))
-               (funcall (funcall f (parsing-tree r) input)
-                        (parsing-left r))))
+             (funcall (funcall f (parsing-tree r) input)
+                      (parsing-left r)))
             ((failure-p r)
              r)
             (t (error (format nil "Invalid return value: ~a" r)))))))
diff --git a/core.lisp b/core.lisp
index 3b06936..6e4bf6e 100644
--- a/core.lisp
+++ b/core.lisp
@@ -1,17 +1,8 @@
 (in-package #:monparser)
 
-(defun opposite (p)
-  (lambda (input &key lazy)
-    (let ((result (funcall p input)))
-      (cond ((parsing-p result)
-             (make-failure :place input :message "Unexpected match."))
-            ((failure-p result)
-             (make-parsing :tree nil :left input))
-            (t (error "Unexpected result type."))))))
-
-(defun fail (message)
-  (lambda (input &key lazy)
-    (make-failure :place input :message message)))
+(defun fail (message &key (priority 1))
+  (lambda (input)
+    (make-failure :place input :message message :priority priority)))
 
 (defmacro unit (&optional predicate)
   (cond ((null predicate)
@@ -29,44 +20,47 @@
                               (and (symbolp x)
                                    (string-equal (symbol-name x) "IT"))) predicate))))
         (t (error (format nil "Invalid predicate: ~a." predicate))))
-  `(lambda (input &key lazy)
-     (declare (ignore lazy))
+  `(lambda (input)
      (if (has-data? input)
        (let ((it (peek input)))
          (if ,predicate
            (make-parsing :tree it :left (advance input))
            (make-failure :place input
-                         :message (format nil "Expected: ~a, Got: ~a" ',predicate it))))
+                         :message (format nil "Expected: ~a, Got: ~:c." ',predicate it))))
        (make-failure :place input
-                     :message (format nil "Reached end of input. Expected: ~a" ',predicate)))))
+                     :message (format nil "Reached end of input. Expected: ~a." ',predicate)))))
+
+(defparameter end
+  (lambda (input)
+    (if (has-data? input)
+      (make-failure :place input :message "Didn't reach end of input.")
+      (make-parsing :tree nil :left input))))
 
-(defun lazily-select-parser (input parsers)
-  (let ((intermediate-parsers '())
-        (result (make-failure :place input
-                              :message "Exhausted options.")))
+(defun select-parser (input parsers)
+  (let ((result (make-failure :place input)))
     (dolist (p parsers)
-      (let ((r (funcall p
-                        input
-                        :lazy (> (length parsers) 1))))
-        (cond ((functionp r)
-               (push r intermediate-parsers))
-              ((parsing-p r)
+      (let ((r (funcall p input)))
+        (cond ((parsing-p r)
                (when (or (not (parsing-p result))
                          (> (input-cursor (parsing-left r))
                             (input-cursor (parsing-left result))))
                  (setf result r)))
               ((failure-p r)
                (when (failure-p result)
-                 (setf result r)))
-              (t (error (format nil "Invalid return value: ~a" r))))))
-    (if intermediate-parsers
-      (lazily-select-parser input intermediate-parsers)
-      result)))
+                 (let ((priority-cmp (- (failure-priority r)
+                                        (failure-priority result))))
+                   (when (or (> priority-cmp 0)
+                             (and (= priority-cmp 0)
+                                  (>= (input-cursor (failure-place r))
+                                      (input-cursor (failure-place result)))))
+                     (setf result r)))))
+              (t (error (format nil "Invalid return value: ~a." r))))))
+    result))
 
 (defmacro one-of (first-parser second-parser &rest other-parsers)
-  `(lambda (input &key lazy)
-     (declare (ignore lazy))
-       (lazily-select-parser input (list ,first-parser ,second-parser ,@other-parsers))))
+  `(lambda (input)
+     (select-parser input
+                    (list ,first-parser ,second-parser ,@other-parsers))))
 
 ;;; TODO: Find a way to be able to use the input without needing to define a name for it.
 (defmacro comp (bindings &body body)
diff --git a/extra.lisp b/extra.lisp
index 9451ce8..20a13b1 100644
--- a/extra.lisp
+++ b/extra.lisp
@@ -11,7 +11,7 @@
               (push name name-list)
               (push `(,name (unit ,c)) binding-list))))
     `(comp ,(reverse binding-list)
-           (coerce ,(cons 'list (reverse name-list)) 'string))))
+       ,(cons 'list (reverse name-list)))))
 
 (defparameter nothing
   (new nil))
@@ -19,27 +19,28 @@
 (defun optional (p)
   (one-of p nothing))
 
-(defun many (p)
+(defun many (p &key all)
   (comp ((x p)
-         (xs (optional (many p))))
-        (if x (cons x xs) xs)))
+         (xs (if all
+               (one-of end
+                       (many p :all all))
+               (optional (many p)))))
+    (if x (cons x xs) xs)))
 
 (defun repeat (p min &optional (max 0))
   (if (> min 0)
     (comp ((x p)
            (xs (repeat p (1- min) (1- max))))
-          (cons x xs))
+      (cons x xs))
     (if (> max 0)
       (comp ((x (optional p))
              (xs (repeat p 0 (if x (1- max) 0))))
-            (if x (cons x xs) x))
+        (if x (cons x xs) x))
       nothing)))
 
 (defun whitespace? (x)
-  (some (lambda (y) (char= x y)) '(#\Space #\Newline #\Return #\Tab)))
-
-(defparameter whitespace
-  (optional (many (unit whitespace?))))
+  (or (char= x #\Space)
+      (not (graphic-char-p x))))
 
 (defun separated-list (p separator)
   (comp ((v p)
@@ -47,4 +48,4 @@
          (vn (if sep
                (separated-list p separator)
                nothing)))
-        (cons v vn)))
+    (cons v vn)))
diff --git a/input.lisp b/input.lisp
index 5d6a162..e464d0e 100644
--- a/input.lisp
+++ b/input.lisp
@@ -35,10 +35,9 @@
         (format stream "..."))
       (format stream "~a"
               (substitute #\↲ #\Newline (subseq (input-data obj) begin (input-cursor obj))))
-      (if (< (input-cursor obj) (length (input-data obj)))
+      (when (< (input-cursor obj) (length (input-data obj)))
         (format stream "~a~a"
                 (substitute #\↲ #\Newline (subseq (input-data obj) (input-cursor obj) (1+ (input-cursor obj))))
-                (substitute #\↲ #\Newline (subseq (input-data obj) (1+ (input-cursor obj)) end)))
-        (format stream "¬"))
-        (when (< end (length (input-data obj)))
-          (format stream "...")))))
+                (substitute #\↲ #\Newline (subseq (input-data obj) (1+ (input-cursor obj)) end))))
+      (when (< end (length (input-data obj)))
+        (format stream "...")))))
diff --git a/main.lisp b/main.lisp
index 197f1b2..f802d25 100644
--- a/main.lisp
+++ b/main.lisp
@@ -6,9 +6,20 @@
                                          :data data))))
     (if (parsing-p result)
       (let ((finished? (not (has-data? (parsing-left result)))))
-        (values result finished?))
+        (values (parsing-tree result) finished?))
       result)))
 
-(defmethod print-object ((obj failure) stream)
-  (multiple-value-bind (line column) (line-and-column (failure-place obj))
-    (format stream "~a:~a: ~a~&~a" line column (failure-message obj) (failure-place obj))))
+(defun append-on-failure (p message)
+  (lambda (input)
+    (let ((result (funcall p input)))
+      (if (failure-p result)
+        (make-failure :place (failure-place result)
+                      :message (concatenate 'string message (failure-message result))
+                      :priority (failure-priority result))
+        result))))
+
+(defmacro defparser (name args parser)
+  (let ((message (format nil "In ~a:~&" name)))
+    (if (null args)
+      `(defparameter ,name (append-on-failure ,parser ,message))
+      `(defun ,name ,args (append-on-failure ,parser ,message)))))
diff --git a/package.lisp b/package.lisp
index a20934f..e0a58e5 100644
--- a/package.lisp
+++ b/package.lisp
@@ -1,21 +1,19 @@
 (defpackage #:monparser
   (:use #:cl)
   (:export #:parse
+           #:defparser
+           #:failure-p
            #:failure-place
            #:failure-message
-           #:input-cursor
-           #:input-data
-           #:line-and-column 
            #:comp
            #:one-of
            #:unit
            #:fail
-           #:opposite
+           #:end
            #:literal
            #:nothing
            #:optional
            #:many
            #:repeat
            #:whitespace?
-           #:whitespace
            #:separated-list))