(in-package #:json)

(defparameter number-literal
  (let ((signed-digits
          (comp ((sign (optional (either (unit #\-)
                                         (unit #\+))))
                 (natural (if sign
                            (either (many (unit-if #'digit-char-p))
                                    (fail "Malformed number."))
                            (many (unit-if #'digit-char-p)))))
            (cons sign natural))))
    (comp ((base signed-digits)
           (dot (optional (unit #\.)))
           (fraction (if dot
                       (either (many (unit-if #'digit-char-p))
                               (fail "Malformed fractional part."))
                       nothing))
           (e (optional (either (unit #\e) (unit #\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 ((_ (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 ((_ (optional (many (either (unit #\Space) (unit #\Newline) (unit #\Tab))))))
    nil))

(defparameter true-symbol
  (comp ((_ (unit #\t))
         (_ (either (literal "rue")
                    (fail "Expected 'true'."))))
    'true))

(defparameter false-symbol
  (comp ((_ (unit #\f))
         (_ (either (literal "alse")
                    (fail "Expected 'false'."))))
    'false))

(defparameter null-symbol
  (comp ((_ (unit #\n))
         (_ (either (literal "ull")
                    (fail "Expected 'null'."))))
    'null))

(defvar json-value)

(defparameter json-array
  (comp ((_ (unit #\[))
         (vn (optional (separated-list json-value (unit #\,))))
         (_ (unit #\])))
    (apply #'vector vn)))

(defparameter json-object
  (let ((json-pair
          (comp ((_ whitespace)
                 (k (either string-literal
                            (fail "Expected a string.")))
                 (_ whitespace)
                 (_ (either (unit #\:)
                            (fail "Expected a \":\"")))
                 (v json-value))
            (cons k v))))
    (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)))
        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)))