--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/.ffignore Mon Jul 13 21:59:43 2020 -0400
@@ -0,0 +1,1 @@
+docs/build
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/.hgignore Mon Jul 13 21:59:43 2020 -0400
@@ -0,0 +1,5 @@
+syntax: glob
+
+scratch.lisp
+*.png
+docs/build
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/.hgtags Mon Jul 13 21:59:43 2020 -0400
@@ -0,0 +1,2 @@
+1a81296fb3ecaf2871b0170a65dc6224a9da6bc5 v1.0.0
+5d5c09688c115ebf86339bf03a947b0d59d9b226 v1.0.1
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/.lispwords Mon Jul 13 21:59:43 2020 -0400
@@ -0,0 +1,2 @@
+(1 make-option)
+(1 signals)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/LICENSE.markdown Mon Jul 13 21:59:43 2020 -0400
@@ -0,0 +1,19 @@
+Copyright (c) 2020 Steve Losh and contributors
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/Makefile Mon Jul 13 21:59:43 2020 -0400
@@ -0,0 +1,44 @@
+.PHONY: test test-sbcl test-ccl test-ecl test-abcl test-clasp pubdocs
+
+heading_printer = $(shell which heading || echo 'true')
+sourcefiles = $(shell ffind --full-path --literal .lisp)
+docfiles = $(shell ls docs/*.markdown)
+apidocs = $(shell ls docs/*reference*.markdown)
+
+# Testing ---------------------------------------------------------------------
+test: test-sbcl test-ccl test-ecl test-abcl test-clasp
+
+test-sbcl:
+ $(heading_printer) computer 'SBCL'
+ time sbcl --load test/run.lisp
+
+test-ccl:
+ $(heading_printer) slant 'CCL'
+ time ccl --load test/run.lisp
+
+test-ecl:
+ $(heading_printer) roman 'ECL'
+ time ecl -load test/run.lisp
+
+test-abcl:
+ $(heading_printer) broadway 'ABCL'
+ time abcl --load test/run.lisp
+
+test-clasp:
+ $(heading_printer) o8 'CLASP'
+ time clasp --load test/run.lisp
+
+# Documentation ---------------------------------------------------------------
+$(apidocs): $(sourcefiles)
+ sbcl --noinform --load docs/api.lisp --eval '(quit)'
+
+docs/build/index.html: $(docfiles) $(apidocs) docs/title
+ cd docs && ~/.virtualenvs/d/bin/d
+
+docs: docs/build/index.html
+
+pubdocs: docs
+ hg -R ~/src/docs.stevelosh.com pull -u
+ rsync --delete -a ./docs/build/ ~/src/docs.stevelosh.com/jarl
+ hg -R ~/src/docs.stevelosh.com commit -Am 'jarl: Update site.'
+ hg -R ~/src/docs.stevelosh.com push
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/README.markdown Mon Jul 13 21:59:43 2020 -0400
@@ -0,0 +1,11 @@
+Jarl
+=====
+
+JSON (Another Reimplementation) in Lisp.
+
+* **License:** MIT
+* **Documentation:** <https://docs.stevelosh.com/jarl/>
+* **Mercurial:** <https://hg.stevelosh.com/jarl/>
+* **Git:** <https://github.com/sjl/jarl/>
+
+Jarl is …
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/docs/01-usage.markdown Mon Jul 13 21:59:43 2020 -0400
@@ -0,0 +1,7 @@
+Usage
+=====
+
+Jarl is yet another JSON library for Common Lisp.
+
+[TOC]
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/docs/02-reference.markdown Mon Jul 13 21:59:43 2020 -0400
@@ -0,0 +1,22 @@
+# API Reference
+
+The following is a list of all user-facing parts of Jarl.
+
+If there are backwards-incompatible changes to anything listed here, they will
+be noted in the changelog and the author will feel bad.
+
+Anything not listed here is subject to change at any time with no warning, so
+don't touch it.
+
+[TOC]
+
+## Package `JARL`
+
+### `PRINT-JSON` (function)
+
+ (PRINT-JSON OBJECT &OPTIONAL (STREAM *STANDARD-OUTPUT*))
+
+### `READ-JSON` (function)
+
+ (READ-JSON &OPTIONAL (STREAM-OR-STRING *STANDARD-INPUT*) (EOF-ERROR-P T) EOF-VALUE)
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/docs/03-changelog.markdown Mon Jul 13 21:59:43 2020 -0400
@@ -0,0 +1,13 @@
+Changelog
+=========
+
+Here's the list of changes in each released version.
+
+[TOC]
+
+0.0.1
+-----
+
+Beta.
+
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/docs/api.lisp Mon Jul 13 21:59:43 2020 -0400
@@ -0,0 +1,20 @@
+(ql:quickload "cl-d-api")
+
+(defparameter *header*
+ "The following is a list of all user-facing parts of Jarl.
+
+If there are backwards-incompatible changes to anything listed here, they will
+be noted in the changelog and the author will feel bad.
+
+Anything not listed here is subject to change at any time with no warning, so
+don't touch it.
+
+")
+
+(d-api:generate-documentation
+ :jarl
+ #p"docs/02-reference.markdown"
+ (list "JARL")
+ *header*
+ :title "API Reference")
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/docs/footer.markdown Mon Jul 13 21:59:43 2020 -0400
@@ -0,0 +1,6 @@
+<i>Made with Lisp and love by [Steve Losh][].</i>
+
+<p><a href="http://rochestermade.com" title="Rochester Made"><img src="https://rochestermade.com/media/images/rochester-made-dark-on-light.png" alt="Rochester Made" title="Rochester Made" /></a></p>
+
+[Steve Losh]: http://stevelosh.com/
+[roc]: https://rochestermade.com/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/docs/index.markdown Mon Jul 13 21:59:43 2020 -0400
@@ -0,0 +1,1 @@
+../README.markdown
\ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/docs/title Mon Jul 13 21:59:43 2020 -0400
@@ -0,0 +1,1 @@
+Jarl
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/jarl.asd Mon Jul 13 21:59:43 2020 -0400
@@ -0,0 +1,35 @@
+(asdf:defsystem :jarl
+ :description "JSON (Another Reimplementation) in Lisp"
+ :author "Steve Losh <steve@stevelosh.com>"
+ :homepage "https://docs.stevelosh.com/jarl/"
+
+ :license "MIT"
+ :version "0.0.1"
+
+ :depends-on ()
+
+ :in-order-to ((asdf:test-op (asdf:test-op :jarl/test)))
+
+ :serial t
+ :components ((:module "src" :serial t
+ :components ((:file "package")
+ (:file "reference")
+ (:file "main")))))
+
+
+(asdf:defsystem :jarl/test
+ :description "Test suite for jarl."
+
+ :author "Steve Losh <steve@stevelosh.com>"
+ :license "MIT"
+
+ :depends-on (:jarl :1am)
+
+ :serial t
+ :components ((:module "test"
+ :serial t
+ :components ((:file "package")
+ (:file "tests"))))
+
+ :perform (asdf:test-op (op system)
+ (funcall (read-from-string "jarl.test:run-tests"))))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/main.lisp Mon Jul 13 21:59:43 2020 -0400
@@ -0,0 +1,1 @@
+(in-package :jarl)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/package.lisp Mon Jul 13 21:59:43 2020 -0400
@@ -0,0 +1,5 @@
+(defpackage :jarl
+ (:use :cl)
+ (:export
+ :read-json
+ :print-json))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/reference.lisp Mon Jul 13 21:59:43 2020 -0400
@@ -0,0 +1,268 @@
+(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]")
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/test/package.lisp Mon Jul 13 21:59:43 2020 -0400
@@ -0,0 +1,3 @@
+(defpackage :jarl.test
+ (:use :cl :1am)
+ (:export :run-tests))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/test/run.lisp Mon Jul 13 21:59:43 2020 -0400
@@ -0,0 +1,5 @@
+#+ecl (setf compiler:*user-cc-flags* "-Wno-shift-negative-value")
+
+(ql:quickload :jarl :silent t)
+(asdf:test-system :jarl)
+(quit)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/test/tests.lisp Mon Jul 13 21:59:43 2020 -0400
@@ -0,0 +1,17 @@
+(in-package :jarl.test)
+
+
+;;;; Utils --------------------------------------------------------------------
+(defmacro define-test (name &body body)
+ `(test ,(intern (concatenate 'string (symbol-name 'test-) (symbol-name name)))
+ (let ((*package* ,*package*))
+ ,@body)))
+
+
+(defun run-tests ()
+ (1am:run))
+
+
+;;;; Tests --------------------------------------------------------------------
+(define-test noop
+ (is (= 1 1)))