diff options
| -rw-r--r-- | json.lisp | 81 |
1 files changed, 45 insertions, 36 deletions
@@ -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)))) |