Improve error handling

Adapted the parser to the new failure types in monparser.

Now object and array errors seem to correctly report place of
failure.

1 files changed, 34 insertions, 45 deletions

diff --git a/json.lisp b/json.lisp
index 2829abe..ef16b0f 100644
--- a/json.lisp
+++ b/json.lisp
@@ -6,8 +6,7 @@
                                                           (char= x #\+))))))
                  (natural (one-or-more (unit #'digit-char-p))))
             (cons sign natural))))
-    (comp ((base (either signed-digits
-                         (fail "Malformed number.")))
+    (comp ((base signed-digits)
            (dot (zero-or-one (unit (lambda (x) (char= x #\.)))))
            (fraction (if dot
                        (either (one-or-more (unit #'digit-char-p))
@@ -52,7 +51,8 @@
                                           (t escaped)))
                                       (unit (lambda (x) (and (char/= x #\")
                                                              (char/= x #\\)))))))
-         (_ (unit (lambda (x) (char= x #\")))))
+         (_ (either (unit (lambda (x) (char= x #\")))
+                    (fail "String is not properly closed."))))
     (str:from-list chars)))
 
 (defparameter whitespace
@@ -85,62 +85,51 @@
 
 (defvar json-value)
 
+(defun separated-list (value-type separator)
+  (comp ((v value-type)
+         (sep (zero-or-one (unit (lambda (x) (char= separator x)))))
+         (vn (if sep
+               (either (separated-list value-type separator)
+                       (fail "Expected another value."))
+               nothing)))
+    (cons v vn)))
+
 (defparameter json-array
   (comp ((_ (unit (lambda (x) (char= x #\[))))
-         (v0 (either json-value
-                     whitespace))
-         (vn (if v0
-               (zero-or-more (comp ((_ (unit (lambda (x) (char= #\,))))
-                                  (vi json-value))
-                             vi))
-               nothing))
+         (vn (zero-or-one (separated-list json-value #\,)))
          (_ (unit (lambda (x) (char= x #\])))))
-    (if v0
-      (if vn
-        (cons v0 vn)
-        (list v0))
-      nil)))
+    (apply #'vector vn)))
 
 (defparameter json-object
   (let ((json-pair
           (comp ((_ whitespace)
-                 (k string-literal)
+                 (k (either string-literal
+                            (fail "Expected a string.")))
                  (_ whitespace)
-                 (_ (unit (lambda (x) (char= x #\:))))
+                 (_ (either (unit (lambda (x) (char= x #\:)))
+                            (fail "Expected a \":\"")))
                  (v json-value))
             (cons k v))))
     (comp ((_ (unit (lambda (x) (char= x #\{))))
-           (v0 (either json-pair
-                       whitespace))
-           (vn (if v0
-                 (zero-or-more (comp ((_ (unit (lambda (x) (char= #\,))))
-                                      (vi json-pair))
-                                 vi))
-                 nothing))
+           (vn (zero-or-one (separated-list json-pair #\,)))
            (_ (unit (lambda (x) (char= x #\})))))
-      (if v0
-        (if vn
-          (let* ((vlist (cons v0 vn))
-                 (obj (make-hash-table :test #'equal :size (length vlist))))
-            (dolist (v vlist)
-              (setf (gethash (car v) obj) (cdr v)))
-            obj)
-          (let ((obj (make-hash-table :test #'equal)))
-            (setf (gethash (car v0) obj) (cdr v0))
-            obj))
-        (make-hash-table :test #'equal)))))
+      (let* ((vlist vn)
+             (obj (make-hash-table :test #'equal :size (length vlist))))
+        (dolist (v vlist)
+          (setf (gethash (car v) obj) (cdr v)))
+        obj))))
 
 (setf json-value
-  (comp ((_ whitespace)
-         (v (either number-literal
-                    string-literal
-                    json-array
-                    json-object
-                    true-symbol
-                    false-symbol
-                    null-symbol))
-         (_ whitespace))
-    v))
+      (comp ((_ whitespace)
+             (v (either number-literal
+                        string-literal
+                        json-object
+                        json-array
+                        true-symbol
+                        false-symbol
+                        null-symbol))
+             (_ whitespace))
+        v))
 
 (defun parse-string (str)
   (run json-value (input:from-string str)))