(defpackage :de.bauhh.json
  (:use :common-lisp)
  (:export
   #:print-json
   #:print-json-to-string
   #:read-json
   #:read-json-from-string
   #:json-key-string))

(in-package :de.bauhh.json)

;;;; -- READ-JSON -------------------------------------------------------------

(defun read-json-from-string (string &key start end junk-allowed)
  (setq start (or start 0)
        end (or end (length string)))
  (let (ptr)
    (values
     (with-input-from-string (stream string :start start :end end :index ptr)
       (prog1 (read-json stream)
         (unless junk-allowed
           (skip-json-whitespace stream))))
     (progn
       (unless (or junk-allowed (= ptr end))
         (error "There is junk in this string - ~S" (subseq string start end)))
       ptr))))

(defun read-json (input)
  (let ((la :nix))
    (labels ((tok ()
               (if (eq :nix la)
                   (setq la (read-json-token input))
                   la))
             ;;
             (consume ()
               (prog1 la (setq la :nix)))
             ;;
             (expect (x)
               (unless (typep (tok) x)
                 (error "~S expected, got ~S" x (tok)))
               (consume))
             ;;
             (element ()
               (etypecase (tok)
                 ((or number symbol string)
                  (consume))
                 ((eql #\{)
                  (consume)
                  (prog1 (members) (expect '(eql #\}))))
                 ((eql #\[)
                  (consume)
                  (prog1 (coerce (elements) 'vector) (expect '(eql #\]))))))
             ;;
             (elements ()
               (and (typep (tok) '(or number symbol string (member #\[ #\{)))
                    (cons (element)
                          (loop while (eql #\, (tok)) do (consume) collect (element)))))
             ;;
             (members ()
               (and (stringp (tok))
                    (nconc (member*)
                           (loop while (eql #\, (tok)) do (consume) nconc (member*)))))
             ;;
             (member* ()
               (list (intern-json-key (expect 'string))
                     (progn (expect '(eql #\:))
                            (element)))) )
      (element))))

(defconstant +shift-character+ #\-)

(defun intern-json-key (string)
  (intern (with-output-to-string (bag)
            (loop for c across string do
                  (cond ((char<= #\a c #\z)
                         (write-char (char-upcase c) bag))
                        ((char<= #\A c #\Z)
                         (write-char +shift-character+ bag)
                         (write-char c bag))
                        ((char= +shift-character+ c)
                         (write-char +shift-character+ bag)
                         (write-char +shift-character+ bag))
                        (t
                         (write-char c bag)))))
          :keyword))

(defun read-json-token (input)
  (labels ((read-while (predicate &optional c)
             (with-output-to-string (bag)
               (when c (write-char c bag))
               (loop for c = (read-char input nil nil)
                     while (and c (funcall predicate c))
                     do (write-char c bag)
                     finally (when c (unread-char c input))))))
    (skip-json-whitespace input)
    (let ((c (read-char input)))
      (cond ((find c "{}[],:")
             c)
            ((or (char= #\- c) (char<= #\0 c #\9))
             (let ((bag (read-while (lambda (c) (or (find c ".+-eE") (char<= #\0 c #\9))) c)))
               (if (has-json-number-syntax-p bag)
                   (let ((*read-default-float-format* 'double-float))
                     (read-from-string bag))
                   (error "Bad number - ~S" bag))))
            ((char<= #\a c #\z)
             (let ((ident (read-while (lambda (c) (char<= #\a c #\z)) c)))
               (cond ((string= "null" ident) :null)
                     ((string= "true" ident) :true)
                     ((string= "false" ident) :false)
                     (t (error "Unknown identifier - ~S" ident)))))
            ((char= #\" c)
             (unread-char c input)
             (read-json-string input))
            (t
             (error "Unexpected character seen - ~S" c))))))

(defun skip-json-whitespace (input)
  (loop for c = (read-char input nil nil)
        while (member c '#.(mapcar #'code-char '(#x20 #x0A #x0D #x09)))
        finally (and c (unread-char c input))))

(defun read-json-string (input)
  (let ((c (read-char input nil :eof)))
    (unless (eql #\" c)
      (error "~S expected, got ~S" #\" c)))
  (with-output-to-string (bag)
    (let ((high nil) (new-high nil))
      (loop for c = (read-char input) do
            (cond
              ((char= #\" c) (return))
              ((char= #\\ c)
               (setq c (read-char input))
               (ecase c
                 (#\" (write-char #\" bag))
                 (#\\ (write-char #\\ bag))
                 (#\/ (write-char #\/ bag))
                 (#\b (write-char (code-char #x08) bag))
                 (#\f (write-char (code-char #x0C) bag))
                 (#\n (write-char #\newline bag))
                 (#\r (write-char (code-char #x0D) bag))
                 (#\t (write-char (code-char #x09) bag))
                 (#\u
                  (labels ((h () (let ((c (read-char input)))
                                   (or (and (or (char<= #\0 c #\9)
                                                (char<= #\a c #\f)
                                                (char<= #\A c #\F))
                                            (digit-char-p c 16))
                                       (error "\\u not followed by four hex digits.")))))
                    (let ((code (loop for i from 12 downto 0 by 4 sum (ash (h) i))))
                      (cond ((<= #xD800 code #xDBFF)
                             ;; high surrogate
                             (when high
                               (error "High surrogate followed by another high surrogate."))
                             (setq new-high (ldb (byte 10 0) code)))
                            ((<= #xDC00 code #xDFFF)
                             ;; low surrogate
                             (unless high
                               (error "Low surrogate without preceding high surrogate."))
                             (write-char (code-char (+ #x10000 (dpb high (byte 10 10)
                                                                    (ldb (byte 10 0) code))))
                                         bag)
                             (setq high nil))
                            (t
                             (write-char (code-char code) bag))))))))
              ((>= (char-code c) #x20)
               (write-char c bag))
              (t
               (error "Bad character in string - ~S" c)))
            (when high
              (error "High surrogate not followed by low surrogate."))
            (setq high new-high new-high nil))
      (when high
        (error "High surrogate not followed by low surrogate.")))))

(defun has-json-number-syntax-p (string &key start end)
  (setq start (or start 0)
        end (or end (length string)))
  (let ((p start))
    (labels ((digits ()
               (unless (and (< p end) (char<= #\0 (char string p) #\9))
                 (return-from has-json-number-syntax-p nil))
               (loop while (and (< p end) (char<= #\0 (char string p) #\9))
                     do (incf p))))
      (when (and (< p end) (eql #\- (char string p)))
        (incf p))
      (cond ((and (< p end) (eql #\0 (char string p)))
             (incf p))
            (t
             (digits)))
      ;; fraction
      (when (and (< p end) (char= #\. (char string p)))
        (incf p)
        (digits))
      ;; exponent
      (when (and (< p end) (find (char string p) "eE"))
        (incf p)
        (when (and (< p end) (find (char string p) "+-"))
          (incf p))
        (digits))
      ;;
      (= p end))))

;;;; -- PRINT-JSON ------------------------------------------------------------

(defgeneric print-json (object stream))

(defmethod print-json ((object null) stream)
  (write-string "{}" stream))

(defmethod print-json ((object (eql :null)) stream)
  (write-string "null" stream))

(defmethod print-json ((object (eql :true)) stream)
  (write-string "true" stream))

(defmethod print-json ((object (eql :false)) stream)
  (write-string "false" stream))

(defmethod print-json ((object integer) stream)
  (format stream "~D" object))

(defmethod print-json ((object float) stream)
  (let ((*read-default-float-format* (type-of object)))
    (format stream "~D" object)))

(defmethod print-json ((object real) stream)
  (print-json (coerce object 'float) stream))

(defmethod print-json ((object string) stream)
  (print-json-string object stream))

(defmethod print-json ((object list) stream)
  (cond ((every (lambda (x)
                  (and (consp x) (symbolp (car x))))
                object)
         ;; An alist
         (pprint-logical-block (stream object :prefix "{" :suffix "}")
           (loop for i from 0 do
                 (pprint-exit-if-list-exhausted)
                 (unless (zerop i)
                   (write-string ", " stream)
                   (pprint-newline :linear stream))
                 (destructuring-bind (k . v) (pprint-pop)
                   (print-json-string (string k) stream :shift-processing t)
                   (write-string ": " stream)
                   (print-json v stream)))))
        ((loop for (k) on object by #'cddr always (symbolp k))
         ;; A plist
         (print-json (loop for (k v) on object by #'cddr collect (cons k v)) stream))
        (t
         (error "This is neither an alist nor a plist - ~S" object))))

(defmethod print-json ((object vector) stream)
  (pprint-logical-block (stream (coerce object 'list) :prefix "[" :suffix "]")
    (loop for i from 0 do
          (pprint-exit-if-list-exhausted)
          (unless (zerop i)
            (write-string ", " stream)
            (pprint-newline :fill stream))
          (print-json (pprint-pop) stream))))

(defmethod print-json ((object symbol) stream)
  (print-json-string (string object) stream :shift-processing t))

(defun print-json-string (string stream &key (shift-processing nil))
  ;; This never writes any character outside the printable US-ASCII range.
  (write-char #\" stream)
  (let ((shift nil))
    (loop for char across string do
          (let ((code (char-code char)))
            (cond ((<= #x20 code #x7E)
                   (cond (shift-processing
                          (cond ((= code (char-code +shift-character+))
                                 (if shift
                                     (progn (write-char char stream)
                                            (setq shift nil))
                                     (setq shift t)))
                                ((<= #.(char-code #\A) code (char-code #\Z))
                                 (if shift
                                     (write-char char stream)
                                     (write-char (char-downcase char) stream))
                                 (setq shift nil))
                                ((or (= code #.(char-code #\"))
                                     (= code #.(char-code #\\)))
                                 (write-char #\\ stream)
                                 (write-char char stream)
                                 (setq shift nil))
                                (t
                                 (write-char char stream)
                                 (setq shift nil))))
                         (t
                          (case code
                            ((#.(char-code #\") #.(char-code #\\))
                             (write-char #\\ stream)
                             (write-char char stream))
                            (otherwise
                             (write-char char stream))))))
                  ((= code #x08) (write-string "\\b" stream))
                  ((= code #x09) (write-string "\\t" stream))
                  ((= code #x0A) (write-string "\\n" stream))
                  ((= code #x0C) (write-string "\\f" stream))
                  ((= code #x0D) (write-string "\\r" stream))
                  ((<= code #xFFFF)
                   (format stream "\\u~4,'0X" code))
                  (t
                   ;; UTF-16
                   (let* ((code (- code #x10000))
                          (lo (ldb (byte 10 0) code))
                          (hi (ldb (byte 10 10) code)))
                     (format stream "\\u~4,'0X\\u~4,'0X"
                             (+ #xD800 hi) (+ #xDC00 lo))))))))
  (write-char #\" stream))

(defun print-json-to-string (object)
  (with-output-to-string (stream)
    (print-json object stream)))

;; Sigh.

(defun json-key-string (keyword)
  (setq keyword (string keyword))
  (with-output-to-string (bag)
    (let ((shift nil))
      (loop for char across keyword do
            (cond ((char= char +shift-character+)
                   (if shift
                       (progn (write-char char bag)
                              (setq shift nil))
                       (setq shift t)))
                  ((char<= #\A char #\Z)
                   (if shift
                       (write-char char bag)
                       (write-char (char-downcase char) bag))
                   (setq shift nil))
                  (t
                   (write-char char bag)
                   (setq shift nil)))))))

;;;; -- Tests -----------------------------------------------------------------

#+NIL
(progn
  (defparameter *test-dir*
    #p"home:lisp;json;other;JSONTestSuite;test_parsing;*.json")

  (defun run-test (pathname)
    (let ((condition nil))
      (handler-case
          (with-open-file (input pathname :direction :input :external-format :utf-8)
            (read-json input)
            (skip-json-whitespace input)
            (unless (null (read-char input nil nil))
              (error "Garbage")))
        (error (c)
          (setq condition c)))
      (ecase (subst #\y #\i (char (pathname-name pathname) 0))
        (#\n
         (unless condition
           (format t "~&;; ~A failed.~%" (pathname-name pathname))))
        (#\y
         (when condition
           (format t "~&;; ~A failed.~%" (pathname-name pathname)))) )))

  (defun run-all-tests ()
    (loop for pn in (directory *test-dir*) do (run-test pn))))