src/reference.lisp @ 30f068e02285

(in-package :jarl)

;;;; Reading ------------------------------------------------------------------
(defun requires-escape-p (char)
  (or (char= #\" char)
      (char= #\\ char)
      (<= (char-code char) #x1F)))

(defun skip-whitespace (stream)
  (loop :while (member (peek-char nil stream nil nil)
                       '(#\space #\tab #\newline #\linefeed #\return))
        :do (read-char stream)))

(defun read-literal (stream literal)
  (loop :for next :across literal
        :for char = (read-char stream)
        :do (assert (char= next char))))

(defun read-integer (stream &optional (allow-leading-zero t))
  (loop :with i = 0
        :with n = 0
        :with has-leading-zero = nil
        :for ch = (peek-char nil stream nil #\e)
        :for digit = (digit-char-p ch)
        :while digit
        :do (progn
              (when (and (zerop n) (zerop digit))
                (setf has-leading-zero t))
              (incf n)
              (setf i (+ (* 10 i) digit))
              (read-char stream))
        :finally
        (cond
          ((zerop n) (error "Expected integer"))
          ((and has-leading-zero (not allow-leading-zero)
                (not (and (= n 1) (= i 0))))
           (error "Bad leading zero"))
          (t (return (values i n))))))

(defun read-exponent (stream)
  (read-char stream) ; e
  (let* ((char (peek-char nil stream))
         (sign (if (member char '(#\+ #\-))
                 (progn
                   (read-char stream)
                   (case char
                     (#\+ 1)
                     (#\- -1)))
                 1)))
    (* sign (read-integer stream))))

(defun read-number (stream)
  ; todo disallow leading zeros in integer part
  (let ((sign 1) integer
        (fractional 0) (fractional-length 0)
        (exponent 0) has-exponent)
    (when (char= #\- (peek-char nil stream))
      (read-char stream)
      (setf sign -1))
    (setf integer (read-integer stream nil))
    (when (eql #\. (peek-char nil stream nil nil))
      (read-char stream)
      (setf (values fractional fractional-length) (read-integer stream)))
    (when (member (peek-char nil stream nil nil) '(#\e #\E))
      (setf exponent (read-exponent stream)
            has-exponent t))
    (if (and (zerop fractional-length) (not has-exponent))
      (* sign integer (expt 10 exponent))
      (values
        (coerce
          (read-from-string (format nil "~A~D.~V,'0Dd~D" ; good enough for reference
                                    (if (= -1 sign) #\- #\+)
                                    integer
                                    fractional-length
                                    fractional
                                    exponent))
          'double-float)))))

(defun read-hex-digit (stream)
  (or (digit-char-p (read-char stream) 16)
      (error "Expected hex digit.")))

(defun read-escaped-char (stream)
  (read-char stream) ; \
  (ecase (read-char stream)
    (#\" #\")
    (#\\ #\\)
    (#\/ #\/)
    (#\b #\backspace)
    (#\f (code-char #x0C))
    (#\n #\linefeed)
    (#\r #\return)
    (#\t #\tab)
    (#\u (let ((a (read-hex-digit stream)) ; todo handle surrogate pairs
               (b (read-hex-digit stream))
               (c (read-hex-digit stream))
               (d (read-hex-digit stream)))
           (code-char (+ (* a (expt 16 3))
                         (* b (expt 16 2))
                         (* c (expt 16 1))
                         (* d (expt 16 0))))))))

(defun read-string (stream)
  (assert (char= #\" (read-char stream)))
  (coerce (loop :for ch = (peek-char nil stream)
                :collect (cond
                           ((char= #\\ ch) (read-escaped-char stream))
                           ((char= #\" ch) (read-char stream) (loop-finish))
                           ((requires-escape-p ch) (error "Bad unescaped char ~S." ch))
                           (t (read-char stream))))
          'string))

(defun read-array (stream)
  (assert (char= #\[ (read-char stream)))
  (skip-whitespace stream)
  (if (char= #\] (peek-char nil stream))
    (progn
      (read-char stream)
      (vector))
    (coerce (loop :collect (read-thing stream)
                  :do (progn
                        (skip-whitespace stream)
                        (case (peek-char nil stream)
                          (#\] (read-char stream) (loop-finish))
                          (#\, (read-char stream))
                          (t (error "Expected , or ] while reading array, got ~S."
                                    (peek-char nil stream))))))
            'vector)))

(defun read-object (stream)
  (assert (char= #\{ (read-char stream)))
  (skip-whitespace stream)
  (let ((result (make-hash-table :test #'equal)))
    (if (char= #\} (peek-char nil stream))
      (read-char stream)
      (loop :for name = (progn (skip-whitespace stream)
                               (read-string stream))
            :for sep = (progn
                         (skip-whitespace stream)
                         (assert (char= #\: (read-char stream))))
            :for value = (progn (skip-whitespace stream)
                                (read-thing stream))
            :do (progn
                  (setf (gethash name result) value)
                  (skip-whitespace stream)
                  (case (peek-char nil stream)
                    (#\} (read-char stream) (loop-finish))
                    (#\, (read-char stream))
                    (t (error "Expected , or } while reading object, got ~S."
                              (peek-char nil stream)))))))
    result))

(defun read-thing (stream)
  (skip-whitespace stream)
  (ecase (peek-char nil stream)
    (#\f (read-literal stream "false") :false)
    (#\t (read-literal stream "true") :true)
    (#\n (read-literal stream "null") nil)
    (#\" (read-string stream))
    (#\{ (read-object stream))
    (#\[ (read-array stream))
    ((#\- #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) (read-number stream))))

(defun read-json% (stream eof-error-p eof-value)
  (skip-whitespace stream)
  (if (peek-char nil stream nil nil)
    (prog1
        (read-thing stream)
      (skip-whitespace stream))
    (if eof-error-p
      (error "EOF")
      eof-value)))

(defun read-json (&optional (stream-or-string *standard-input*) (eof-error-p t) eof-value)
  (read-json% (etypecase stream-or-string
                (stream stream-or-string)
                (string (make-string-input-stream stream-or-string)))
              eof-error-p
              eof-value))


;;;; Printing -----------------------------------------------------------------
(defun write-escaped-char (char stream)
  (case char
    ((#\newline #\linefeed) (write-string "\\n" stream))
    (#\return (write-string "\\r" stream))
    (#\\ (write-string "\\\\" stream))
    (t (format stream "\\u~4,'0X" (char-code char)))))


(defgeneric print-thing (thing stream))

(defmethod print-thing ((thing null) stream)
  (write-string "null" stream))

(defmethod print-thing ((thing string) stream)
  (write-char #\" stream)
  (loop :for char :across thing
        :do (if (requires-escape-p char)
              (write-escaped-char char stream)
              (write-char char stream)))
  (write-char #\" stream))

(defmethod print-thing ((thing vector) stream)
  (write-char #\[ stream)
  (loop :with first = t
        :for object :across thing
        :do (progn (if first
                     (setf first nil)
                     (write-char #\, stream))
                   (print-thing object stream)))
  (write-char #\] stream))

(defmethod print-thing ((thing hash-table) stream)
  (write-char #\{ stream)
  (loop :with first = t
        :for name :being :the hash-keys :in thing :using (hash-value value)
        :do (progn (if first
                     (setf first nil)
                     (write-char #\, stream))
                   (assert (stringp name))
                   (print-thing name stream)
                   (write-char #\: stream)
                   (print-thing value stream)))
  (write-char #\} stream))

(defmethod print-thing ((thing double-float) stream)
  (princ thing stream))

(defmethod print-thing ((thing integer) stream)
  (format stream "~D" thing))

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

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


(defun print-json (object &optional (stream *standard-output*))
  (let ((*read-default-float-format* 'double-float)
        (*print-base* 10))
    (etypecase stream
      (stream (print-thing object stream)
              (values))
      (null (with-output-to-string (s) (print-thing object s))))))



#; Scratch --------------------------------------------------------------------

(read-json "        false")
(parse-integer )

(print-json
  (read-json
    (substitute #\" #\'
                "{
                    'foo': [ 1, 2, 3221098950382094832.0123948904],
                    'bar': [{'meow': {}, 'woof': null}, {'baz': 1}]
                }")))



(with-open-file (s "../JSONTestSuite/test_parsing/i_string_overlong_sequence_2_bytes.json")
  (read-json s))

(read-json "[123e1000]")