(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 #\- #\+)))
                 (natural (one-or-more (unit #'digit-char-p))))
            (cons sign natural))))
    (comp ((base signed-digits)
           (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 (some-char #\e #\E)))
           (exponent (if e
                       (either signed-digits
                               (fail "Malformed exponent part."))
                       nothing)))
      (read-from-string
        (str:from-list
          (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 #\")
                    (fail "String is not properly closed."))))
    (str:from-list chars)))

(defparameter whitespace
  (comp ((_ (zero-or-more (some-char #\Space #\Newline #\Tab))))
    nil))

(defparameter true-symbol
  (comp ((_ (the-char #\t))
         (_ (either (comp ((_ (the-char #\r))
                           (_ (the-char #\u))
                           (_ (the-char #\e)))
                      nil)
                    (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)
                    (fail "Expected 'false'."))))
    'false))

(defparameter null-symbol
  (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 (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 #\])))
    (apply #'vector vn)))

(defparameter json-object
  (let ((json-pair
          (comp ((_ whitespace)
                 (k (either string-literal
                            (fail "Expected a string.")))
                 (_ whitespace)
                 (_ (either (the-char #\:)
                            (fail "Expected a \":\"")))
                 (v json-value))
            (cons k v))))
    (comp ((_ (the-char #\{))
           (vn (zero-or-one (separated-list json-pair #\,)))
           (_ (the-char #\})))
      (let* ((obj (make-hash-table :test #'equal :size (length vn))))
        (dolist (v vn)
          (setf (gethash (car v) obj) (cdr v)))
        obj))))

(setf json-value
      (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)))

(defun parse-file (file)
  (run json-value (input:from-file file)))