Make char parsing more compact and rework keywords

Now true, false and null have more accurate error reporting.

1 files changed, 45 insertions, 36 deletions

diff --git a/json.lisp b/json.lisp
index ef16b0f..6fe95b8 100644
--- a/json.lisp
+++ b/json.lisp
@@ -1,19 +1,26 @@
 (in-package #:json)
 
+(defun the-char (c)
+  (unit (lambda (x) (char= c x))))
+
+(defun some-char (&rest char-list)
+  (unit (lambda (x) (find x char-list))))
+
+(defun not-these-chars (&rest char-list)
+  (unit (lambda (x) (not (find x char-list)))))
+
 (defparameter number-literal
   (let ((signed-digits
-          (comp ((sign (zero-or-one (unit (lambda (x) (or (char= x #\-)
-                                                          (char= x #\+))))))
+          (comp ((sign (zero-or-one (some-char #\- #\+)))
                  (natural (one-or-more (unit #'digit-char-p))))
             (cons sign natural))))
     (comp ((base signed-digits)
-           (dot (zero-or-one (unit (lambda (x) (char= x #\.)))))
+           (dot (zero-or-one (the-char #\.)))
            (fraction (if dot
                        (either (one-or-more (unit #'digit-char-p))
                                (fail "Malformed fractional part."))
                        nothing))
-           (e (zero-or-one (unit (lambda (x) (or (char= x #\e)
-                                                 (char= x #\E))))))
+           (e (zero-or-one (some-char #\e #\E)))
            (exponent (if e
                        (either signed-digits
                                (fail "Malformed exponent part."))
@@ -23,10 +30,10 @@
           (remove nil (append base (cons dot fraction) (cons e exponent))))))))
 
 (defparameter string-literal
-  (comp ((_ (unit (lambda (x) (char= x #\"))))
-         (chars (zero-or-more (either (comp ((slash (unit (lambda (x) (char= x #\\))))
+  (comp ((_ (the-char #\"))
+         (chars (zero-or-more (either (comp ((slash (the-char #\\))
                                              (escaped (unit))
-                                             (codepoints (if (and escaped (char= escaped #\u))
+                                             (codepoints (if (char= escaped #\u)
                                                            (comp ((cp0 (unit #'digit-char-p))
                                                                   (cp1 (unit #'digit-char-p))
                                                                   (cp2 (unit #'digit-char-p))
@@ -49,45 +56,48 @@
                                           (#\u
                                            (read-from-string codepoints))
                                           (t escaped)))
-                                      (unit (lambda (x) (and (char/= x #\")
-                                                             (char/= x #\\)))))))
-         (_ (either (unit (lambda (x) (char= x #\")))
+                                      (not-these-chars #\" #\\))))
+         (_ (either (the-char #\")
                     (fail "String is not properly closed."))))
     (str:from-list chars)))
 
 (defparameter whitespace
-  (comp ((_ (zero-or-more (unit (lambda (x) (or (char= x #\Space)
-                                                (char= x #\Newline)
-                                                (char= x #\Tab)))))))
+  (comp ((_ (zero-or-more (some-char #\Space #\Newline #\Tab))))
     nil))
 
 (defparameter true-symbol
-  (comp ((_ (unit (lambda (x) (char= x #\t))))
-         (_ (unit (lambda (x) (char= x #\r))))
-         (_ (unit (lambda (x) (char= x #\u))))
-         (_ (unit (lambda (x) (char= x #\e)))))
+  (comp ((_ (the-char #\t))
+         (_ (either (comp ((_ (the-char #\r))
+                           (_ (the-char #\u))
+                           (_ (the-char #\e)))
+                      nil)
+                    (fail "Expected 'true'."))))
     'true))
 
 (defparameter false-symbol
-  (comp ((_ (unit (lambda (x) (char= x #\f))))
-         (_ (unit (lambda (x) (char= x #\a))))
-         (_ (unit (lambda (x) (char= x #\l))))
-         (_ (unit (lambda (x) (char= x #\s))))
-         (_ (unit (lambda (x) (char= x #\e)))))
+  (comp ((_ (the-char #\f))
+         (_ (either (comp ((_ (the-char #\a))
+                           (_ (the-char #\l))
+                           (_ (the-char #\s))
+                           (_ (the-char #\e)))
+                      nil)
+                    (fail "Expected 'false'."))))
     'false))
 
 (defparameter null-symbol
-  (comp ((_ (unit (lambda (x) (char= x #\n))))
-         (_ (unit (lambda (x) (char= x #\u))))
-         (_ (unit (lambda (x) (char= x #\l))))
-         (_ (unit (lambda (x) (char= x #\l)))))
+  (comp ((_ (the-char #\n))
+         (_ (either (comp ((_ (the-char #\u))
+                           (_ (the-char #\l))
+                           (_ (the-char #\l)))
+                      nil)
+                    (fail "Expected 'null'."))))
     'null))
 
 (defvar json-value)
 
 (defun separated-list (value-type separator)
   (comp ((v value-type)
-         (sep (zero-or-one (unit (lambda (x) (char= separator x)))))
+         (sep (zero-or-one (the-char separator)))
          (vn (if sep
                (either (separated-list value-type separator)
                        (fail "Expected another value."))
@@ -95,9 +105,9 @@
     (cons v vn)))
 
 (defparameter json-array
-  (comp ((_ (unit (lambda (x) (char= x #\[))))
+  (comp ((_ (the-char #\[))
          (vn (zero-or-one (separated-list json-value #\,)))
-         (_ (unit (lambda (x) (char= x #\])))))
+         (_ (the-char #\])))
     (apply #'vector vn)))
 
 (defparameter json-object
@@ -106,16 +116,15 @@
                  (k (either string-literal
                             (fail "Expected a string.")))
                  (_ whitespace)
-                 (_ (either (unit (lambda (x) (char= x #\:)))
+                 (_ (either (the-char #\:)
                             (fail "Expected a \":\"")))
                  (v json-value))
             (cons k v))))
-    (comp ((_ (unit (lambda (x) (char= x #\{))))
+    (comp ((_ (the-char #\{))
            (vn (zero-or-one (separated-list json-pair #\,)))
-           (_ (unit (lambda (x) (char= x #\})))))
-      (let* ((vlist vn)
-             (obj (make-hash-table :test #'equal :size (length vlist))))
-        (dolist (v vlist)
+           (_ (the-char #\})))
+      (let* ((obj (make-hash-table :test #'equal :size (length vn))))
+        (dolist (v vn)
           (setf (gethash (car v) obj) (cdr v)))
         obj))))