Change how critical parts of the parsing are handled

3 files changed, 59 insertions, 78 deletions

diff --git a/input.lisp b/input.lisp
index a96888f..d88d14d 100644
--- a/input.lisp
+++ b/input.lisp
@@ -23,7 +23,7 @@
   (make-instance 'input
                  :data (data input)
                  :file (file input)
-                 :cursor (1+ (cursor input))))
+                 :cursor (+ (cursor input) amount)))
 
 (defun from-string (str)
   (make-instance 'input :data str))
diff --git a/package.lisp b/package.lisp
index 5936a52..603f6cb 100644
--- a/package.lisp
+++ b/package.lisp
@@ -13,22 +13,20 @@
 
 (defpackage #:parser
   (:use #:cl)
-  (:export #:parsing-p
+  (:export #:run
            #:parsing-tree
            #:parsing-left
            #:failure-place
            #:failure-message
-           #:fail
+           #:crit
            #:comp
            #:one-of
            #:all-of
            #:negate
-           #:unit-if
            #:unit
-           #:not-unit
            #:literal
-           #:not-literal
            #:nothing
            #:optional
            #:many
+           #:whitespace
            #:separated-list))
diff --git a/parser.lisp b/parser.lisp
index a48f6e3..5470523 100644
--- a/parser.lisp
+++ b/parser.lisp
@@ -1,28 +1,25 @@
 (in-package #:parser)
 
+(defun run (p input)
+  (let ((result (funcall p input)))
+    (if (parsing-p result)
+      (parsing-tree result)
+      result)))
+
 (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)))
+  (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)))))
 
 (defun new (tree)
   (lambda (input)
@@ -73,71 +70,54 @@
           `(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)
-    (make-critical-failure :place input :message message)))
-
-(defun one-of (first-parser second-parser &rest other-parsers)
-  (lambda (input)
-    (labels ((one-of-rec (body)
-                         (if (cdr body)
-                           (let ((r (funcall (car body) input)))
-                             (if (normal-failure-p r)
-                               (one-of-rec (cdr body))
-                               r))
-                           (funcall (car body) input))))
-      (one-of-rec (cons first-parser (cons second-parser other-parsers))))))
-
-(defun all-of (first-parser second-parser &rest other-parsers)
-  (lambda (input)
-    (labels ((all-of-rec (body)
-                         (if (cdr body)
-                           (let ((r (funcall (car body) input)))
-                             (if (parsing-p r)
-                               (all-of-rec (cdr body))
-                               r))
-                           (funcall (car body) input))))
-      (all-of-rec (cons first-parser (cons second-parser other-parsers))))))
-
-(defun negate (p)
+(defun crit (p)
   (lambda (input)
     (let ((r (funcall p input)))
-      (cond ((parsing-p r)
-             (make-normal-failure :place input :message "Negated parser result."))
-            ((normal-failure-p r)
-             (make-parsing :tree nil :left input))
-            (t r)))))
+      (if (parsing-p r)
+        r
+        (error (format nil "~a" r))))))
 
-(defun unit-if (&optional (predicate #'characterp))
+(defun one-of (first-parser second-parser &rest other-parsers)
   (lambda (input)
-    (if (input:has-data? input)
-      (let ((c (input:peek input)))
-        (if (funcall predicate c)
-          (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."))))
-
-(defun unit (target)
-  (unit-if (lambda (x) (char= x target))))
-
-(defun not-unit (target)
-  (unit-if (lambda (x) (char/= x target))))
+    (labels ((one-of-rec (parsers failures)
+                         (if (car parsers)
+                           (let ((r (funcall (car parsers) input)))
+                             (cond ((failure-p r)
+                                    (one-of-rec (cdr parsers) (cons r failures)))
+                                   ((listp r)
+                                    (one-of-rec (cdr parsers) (append r failures)))
+                                   (t r)))
+                           failures)))
+      (one-of-rec (cons first-parser (cons second-parser other-parsers)) nil))))
+
+(defmacro unit (&optional predicate)
+  (cond ((null predicate)
+         (setf predicate '(characterp it)))
+        ((symbolp predicate)
+         (setf predicate `(,predicate it)))
+        ((characterp predicate)
+         (setf predicate `(char-equal ,predicate it)))
+        (t (setf predicate
+                 (nsubst-if 'it
+                            (lambda (x)
+                              (and (symbolp x)
+                                   (string-equal (symbol-name x) "IT"))) predicate))))
+  `(lambda (input)
+     (if (input:has-data? input)
+       (let ((it (input:peek input)))
+         (if ,predicate
+           (make-parsing :tree it :left (input:advance input))
+           (make-failure :place input
+                         :message (format nil "Expected: ~a, Got: ~a" ',predicate it))))
+       (make-failure :place input :message "Reached end of input."))))
 
 (defun literal (target)
   (lambda (input)
     (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 "Reached end of input."))))
-
-(defun not-literal (target)
-  (lambda (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)))
-      (make-normal-failure :place input :message "Reached end of input."))))
+        (make-failure :place input :message "Predicate not satisfied."))
+      (make-failure :place input :message "Reached end of input."))))
 
 (defparameter nothing
   (new nil))
@@ -150,12 +130,15 @@
          (xs (optional (many p))))
     (cons x xs)))
 
-(defun separated-list (p separator &key (include-separator nil))
+(defparameter whitespace
+  (comp ((_ (optional (many (unit char:whitespace?)))))
+    nil))
+
+(defun separated-list (p separator &key include-separator)
   (comp ((v p)
          (sep (optional separator))
          (vn (if sep
-               (one-of (separated-list p separator)
-                       (fail "Value expected."))
+               (crit (separated-list p separator))
                nothing)))
     (if include-separator
       (cons v (cons sep vn))