(in-package #:json)

(defparameter number-literal
  (let ((signed-digits
          (comp ((sign (zero-or-one (unit (lambda (x) (or (char= x #\-)
                                                          (char= x #\+))))))
                 (natural (one-or-more (unit #'digit-char-p))))
            (cons sign natural))))
    (comp ((base (either signed-digits
                         (fail "Malformed number.")))
           (dot (zero-or-one (unit (lambda (x) (char= x #\.)))))
           (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))))))
           (exponent (if e
                       (either signed-digits
                               (fail "Malformed exponent part."))
                       nothing)))
      (list 'number base fraction exponent))))

(defparameter string-literal
  (comp ((_ (unit (lambda (x) (char= x #\"))))
         (chars (zero-or-more (either (comp ((slash (unit (lambda (x) (char= x #\\))))
                                             (escaped (unit))
                                             (codepoints (if (and escaped (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 4)))
                                                               (setf (char str 0) cp0)
                                                               (setf (char str 1) cp1)
                                                               (setf (char str 2) cp2)
                                                               (setf (char str 3) cp3)
                                                               str))
                                                           nothing)))
                                        (case escaped
                                          (#\n
                                           #\Newline)
                                          (#\t
                                           #\Tab)
                                          (#\u
                                           codepoints)
                                          (t escaped)))
                                      (unit (lambda (x) (char/= x #\"))))))
         (_ (unit (lambda (x) (char= x #\")))))
    (list 'string chars)))

(defparameter whitespace
  (comp ((_ (zero-or-more (unit (lambda (x) (or (char= x #\Space)
                                                (char= x #\Newline)
                                                (char= x #\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)))))
    '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)))))
    '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)))))
    'null))

(defvar json-value)

(defparameter json-array
  (comp ((_ (unit (lambda (x) (char= x #\[))))
         (v0 (either json-value
                     whitespace))
         (vn (if v0
               (zero-or-more (comp ((_ (unit (lambda (x) (char= #\,))))
                                  (vi json-value))
                             vi))
               nothing))
         (_ (unit (lambda (x) (char= x #\])))))
    (if vn
      (list 'array (cons v0 vn))
      (list 'array v0))))

(defparameter json-object
  (let ((json-pair
          (comp ((_ whitespace)
                 (k string-literal)
                 (_ whitespace)
                 (_ (unit (lambda (x) (char= x #\:))))
                 (v json-value))
            (list 'pair k v))))
    (comp ((_ (unit (lambda (x) (char= x #\{))))
           (v0 (either json-pair
                       whitespace))
           (vn (if v0
                 (zero-or-more (comp ((_ (unit (lambda (x) (char= #\,))))
                                      (vi json-pair))
                                 vi))
                 nothing))
           (_ (unit (lambda (x) (char= x #\})))))
      (if vn
        (list 'object (cons v0 vn))
        (list 'object v0)))))

(setf json-value
  (comp ((_ whitespace)
         (v (either number-literal
                    string-literal
                    json-array
                    json-object
                    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)))