Adapt to changes in monparser

1 files changed, 50 insertions, 76 deletions

diff --git a/json.lisp b/json.lisp
index 23c9198..17e111a 100644
--- a/json.lisp
+++ b/json.lisp
@@ -1,29 +1,21 @@
 (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 (some-char #\- #\+)))
+          (comp ((sign (optional (either (unit #\-)
+                                         (unit #\+))))
                  (natural (if sign
-                            (either (one-or-more (unit #'digit-char-p))
+                            (either (many (unit-if #'digit-char-p))
                                     (fail "Malformed number."))
-                            (one-or-more (unit #'digit-char-p)))))
+                            (many (unit-if #'digit-char-p)))))
             (cons sign natural))))
     (comp ((base signed-digits)
-           (dot (zero-or-one (the-char #\.)))
+           (dot (optional (unit #\.)))
            (fraction (if dot
-                       (either (one-or-more (unit #'digit-char-p))
+                       (either (many (unit-if #'digit-char-p))
                                (fail "Malformed fractional part."))
                        nothing))
-           (e (zero-or-one (some-char #\e #\E)))
+           (e (optional (either (unit #\e) (unit #\E))))
            (exponent (if e
                        (either signed-digits
                                (fail "Malformed exponent part."))
@@ -33,84 +25,66 @@
           (remove nil (append base (cons dot fraction) (cons e exponent))))))))
 
 (defparameter string-literal
-  (comp ((_ (the-char #\"))
-         (chars (zero-or-more (either (comp ((slash (the-char #\\))
-                                             (escaped (unit))
-                                             (codepoints (if (char= escaped #\u)
-                                                           (comp ((cp0 (unit #'digit-char-p))
-                                                                  (cp1 (unit #'digit-char-p))
-                                                                  (cp2 (unit #'digit-char-p))
-                                                                  (cp3 (unit #'digit-char-p)))
-                                                             (let ((str (make-string 7)))
-                                                               (setf (char str 0) #\#)
-                                                               (setf (char str 1) #\\)
-                                                               (setf (char str 2) #\u)
-                                                               (setf (char str 3) cp0)
-                                                               (setf (char str 4) cp1)
-                                                               (setf (char str 5) cp2)
-                                                               (setf (char str 6) cp3)
-                                                               str))
-                                                           nothing)))
-                                        (case escaped
-                                          (#\n
-                                           #\Newline)
-                                          (#\t
-                                           #\Tab)
-                                          (#\u
-                                           (read-from-string codepoints))
-                                          (t escaped)))
-                                      (not-these-chars #\" #\\))))
-         (_ (either (the-char #\")
+  (comp ((_ (unit #\"))
+         (chars (optional (many (either (comp ((slash (unit #\\))
+                                               (escaped (unit-if))
+                                               (codepoints (if (char= escaped #\u)
+                                                             (comp ((cp0 (unit-if #'digit-char-p))
+                                                                    (cp1 (unit-if #'digit-char-p))
+                                                                    (cp2 (unit-if #'digit-char-p))
+                                                                    (cp3 (unit-if #'digit-char-p)))
+                                                               (let ((str (make-string 7)))
+                                                                 (setf (char str 0) #\#)
+                                                                 (setf (char str 1) #\\)
+                                                                 (setf (char str 2) #\u)
+                                                                 (setf (char str 3) cp0)
+                                                                 (setf (char str 4) cp1)
+                                                                 (setf (char str 5) cp2)
+                                                                 (setf (char str 6) cp3)
+                                                                 str))
+                                                             nothing)))
+                                          (case escaped
+                                            (#\n
+                                             #\Newline)
+                                            (#\t
+                                             #\Tab)
+                                            (#\u
+                                             (read-from-string codepoints))
+                                            (t escaped)))
+                                        (unit-if (lambda (x) (and (char/= x #\")
+                                                                  (char/= x #\\))))))))
+         (_ (either (unit #\")
                     (fail "String is not properly closed."))))
     (str:from-list chars)))
 
 (defparameter whitespace
-  (comp ((_ (zero-or-more (some-char #\Space #\Newline #\Tab))))
+  (comp ((_ (optional (many (either (unit #\Space) (unit #\Newline) (unit #\Tab))))))
     nil))
 
 (defparameter true-symbol
-  (comp ((_ (the-char #\t))
-         (_ (either (comp ((_ (the-char #\r))
-                           (_ (the-char #\u))
-                           (_ (the-char #\e)))
-                      nil)
+  (comp ((_ (unit #\t))
+         (_ (either (literal "rue")
                     (fail "Expected 'true'."))))
     'true))
 
 (defparameter false-symbol
-  (comp ((_ (the-char #\f))
-         (_ (either (comp ((_ (the-char #\a))
-                           (_ (the-char #\l))
-                           (_ (the-char #\s))
-                           (_ (the-char #\e)))
-                      nil)
+  (comp ((_ (unit #\f))
+         (_ (either (literal "alse")
                     (fail "Expected 'false'."))))
     'false))
 
 (defparameter null-symbol
-  (comp ((_ (the-char #\n))
-         (_ (either (comp ((_ (the-char #\u))
-                           (_ (the-char #\l))
-                           (_ (the-char #\l)))
-                      nil)
+  (comp ((_ (unit #\n))
+         (_ (either (literal "ull")
                     (fail "Expected 'null'."))))
     'null))
 
 (defvar json-value)
 
-(defun separated-list (value-type separator)
-  (comp ((v value-type)
-         (sep (zero-or-one (the-char separator)))
-         (vn (if sep
-               (either (separated-list value-type separator)
-                       (fail "Expected another value."))
-               nothing)))
-    (cons v vn)))
-
 (defparameter json-array
-  (comp ((_ (the-char #\[))
-         (vn (zero-or-one (separated-list json-value #\,)))
-         (_ (the-char #\])))
+  (comp ((_ (unit #\[))
+         (vn (optional (separated-list json-value (unit #\,))))
+         (_ (unit #\])))
     (apply #'vector vn)))
 
 (defparameter json-object
@@ -119,13 +93,13 @@
                  (k (either string-literal
                             (fail "Expected a string.")))
                  (_ whitespace)
-                 (_ (either (the-char #\:)
+                 (_ (either (unit #\:)
                             (fail "Expected a \":\"")))
                  (v json-value))
             (cons k v))))
-    (comp ((_ (the-char #\{))
-           (vn (zero-or-one (separated-list json-pair #\,)))
-           (_ (the-char #\})))
+    (comp ((_ (unit #\{))
+           (vn (optional (separated-list json-pair (unit #\,))))
+           (_ (unit #\})))
       (let* ((obj (make-hash-table :test #'equal :size (length vn))))
         (dolist (v vn)
           (setf (gethash (car v) obj) (cdr v)))