# HG changeset patch # User Steve Losh # Date 1594691983 14400 # Node ID a2712b3d3b16b2b0e11fd7fe9c92872dc7d6e251 Initial commit diff -r 000000000000 -r a2712b3d3b16 .ffignore --- /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 diff -r 000000000000 -r a2712b3d3b16 .hgignore --- /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 diff -r 000000000000 -r a2712b3d3b16 .hgtags --- /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 diff -r 000000000000 -r a2712b3d3b16 .lispwords --- /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) diff -r 000000000000 -r a2712b3d3b16 LICENSE.markdown --- /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. diff -r 000000000000 -r a2712b3d3b16 Makefile --- /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 diff -r 000000000000 -r a2712b3d3b16 README.markdown --- /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:** +* **Mercurial:** +* **Git:** + +Jarl is … diff -r 000000000000 -r a2712b3d3b16 docs/01-usage.markdown --- /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] + diff -r 000000000000 -r a2712b3d3b16 docs/02-reference.markdown --- /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) + diff -r 000000000000 -r a2712b3d3b16 docs/03-changelog.markdown --- /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. + + diff -r 000000000000 -r a2712b3d3b16 docs/api.lisp --- /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") + diff -r 000000000000 -r a2712b3d3b16 docs/footer.markdown --- /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 @@ +Made with Lisp and love by [Steve Losh][]. + +

Rochester Made

+ +[Steve Losh]: http://stevelosh.com/ +[roc]: https://rochestermade.com/ diff -r 000000000000 -r a2712b3d3b16 docs/index.markdown --- /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 diff -r 000000000000 -r a2712b3d3b16 docs/title --- /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 diff -r 000000000000 -r a2712b3d3b16 jarl.asd --- /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 " + :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 " + :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")))) diff -r 000000000000 -r a2712b3d3b16 src/main.lisp --- /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) diff -r 000000000000 -r a2712b3d3b16 src/package.lisp --- /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)) diff -r 000000000000 -r a2712b3d3b16 src/reference.lisp --- /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]") diff -r 000000000000 -r a2712b3d3b16 test/package.lisp --- /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)) diff -r 000000000000 -r a2712b3d3b16 test/run.lisp --- /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) diff -r 000000000000 -r a2712b3d3b16 test/tests.lisp --- /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)))