(in-package #:json)

(defparameter number-literal
  (let ((signed-digits
          (comp ((sign (optional (one-of (unit #\-)
                                         (unit #\+))))
                 (natural (many (unit digit-char-p))))
                (cons sign natural))))
    (comp ((base signed-digits)
           (dot (optional (unit #\.)))
           (fraction (if dot
                       (many (unit digit-char-p))
                       nothing))
           (e (optional (one-of (unit #\e) (unit #\E))))
           (exponent (if e
                       signed-digits
                       nothing)))
          (read-from-string
            (coerce
              (remove nil (append base
                                  (cons dot fraction)
                                  (cons (when e #\d) exponent)))
              'string)))))

(defparameter string-literal
  (comp ((_ (unit #\"))
         (chars
           (optional
             (many
               (one-of
                 (comp ((slash (unit #\\))
                        (escaped (unit))
                        (codepoints (if (char= escaped #\u)
                                      (repeat (unit digit-char-p) 4)
                                      nothing)))
                       (case escaped
                         (#\n #\Newline)
                         (#\t #\Tab)
                         (#\u (read-from-string
                                (coerce (append '(#\# #\\ #\u)
                                                codepoints)
                                        'string)))
                         (t escaped)))
                 (unit (and (char/= it #\") (char/= it #\\)))))))
         (_ (unit #\")))
        (coerce chars 'string)))

(defmacro json-symbol (name)
  `(comp ((v (literal ,name)))
         (intern v)))

(defparameter true-symbol
  (json-symbol "true"))

(defparameter false-symbol
  (json-symbol "false"))

(defparameter null-symbol
  (json-symbol "null"))

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

(defun json-object (value)
  (let ((json-pair
          (comp ((_ whitespace)
                 (k string-literal)
                 (_ whitespace)
                 (_ (unit #\:))
                 (v 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))))

(defparameter json-value
  (comp ((_ whitespace)
         (value (one-of number-literal
                        string-literal
                        (json-object json-value)
                        (json-array json-value)
                        true-symbol
                        false-symbol
                        null-symbol))
         (_ whitespace))
        value))

(defun from-string (str)
  (parse json-value str))

(defun from-file (path)
  (let (buf)
    (with-open-file (f path)
      (let ((size (file-length f)))
        (setf buf (make-string size))
        (read-sequence buf f)))
    (parse json-value buf)))