(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))
(defun json (string)
;; This makes it less miserable to write JSON strings in Lisp.
(substitute #\" #\' string))
(defun obj= (a b &key (test #'equal))
(and (= (hash-table-count a)
(hash-table-count b))
(not (maphash (lambda (ak av)
(multiple-value-bind (bv found) (gethash ak b)
(when (or (not found) (not (funcall test av bv)))
(return-from obj= nil))))
a))))
(defun vec= (a b &key (test #'equal))
(and (= (length a) (length b))
(every test a b)))
(defgeneric same (a b))
(defmethod same (a b)
(equal a b))
(defmethod same ((a vector) (b vector))
(vec= a b :test #'same))
(defmethod same ((a hash-table) (b hash-table))
(obj= a b :test #'same))
(defun h (&rest keys-and-values)
(alexandria:plist-hash-table keys-and-values :test #'equal))
(defun v (&rest values)
(coerce values 'vector))
(defun set-equal (x y)
(and (null (set-difference x y :test #'equal))
(null (set-difference y x :test #'equal))))
(defun slot= (a b slot)
(let ((ab (slot-boundp a slot))
(bb (slot-boundp b slot)))
(cond ((and ab bb) (same (slot-value a slot)
(slot-value b slot)))
((or ab bb) nil)
(t t))))
(defun slots= (a b &rest slots)
(and (eql (class-of a) (class-of b))
(every (alexandria:curry #'slot= a b) slots)))
(defun check-reads-one-object (object string)
(with-input-from-string (s string)
(is (same object (jarl:read t s)))
(signals end-of-file (jarl:read t s))))
(defun check-discards-one-object (string)
(with-input-from-string (s string)
(is (null (multiple-value-list (jarl:read nil s))))
(signals end-of-file (jarl:read t s))))
(defun roundtrip-string (class-designator string)
(jarl:print (jarl:read class-designator (json string)) nil))
(defun roundtrip-object (class-designator object)
(jarl:read class-designator (jarl:print object nil)))
(defun check-roundtrips (object)
(is (same object (roundtrip-object t object)))
(let ((jarl::*indent* t))
(is (same object (roundtrip-object t object)))))
(defun check-errors (line col string)
(dolist (class '(t nil)) ; todo check discarding errors too
(handler-case
(progn
(jarl:read class string)
(error "Should have signaled a json-reading-error when reading ~S but didn't."
class))
(jarl::json-reading-error (e)
(is (equal (list class line col)
(list class (jarl:line e) (jarl:column e))))))))
;;;; Basic Tests --------------------------------------------------------------
(defmacro define-basic-tests (name &rest clauses)
`(define-test ,name
,@(loop :for (object class-designator string) :in clauses :collect
(alexandria:once-only (object string)
`(let ((,string (json ,string)))
;; Check that the entire string deserializes to the expected form.
(check-reads-one-object ,object ,string)
;; Check that we can roundtrip the form reliably.
(check-roundtrips ,object)
;; Check that we can discard it safely.
(check-discards-one-object ,string)
;; Check that we can read it with an explicit class designator, not just t.
(is (same ,object (jarl:read ',class-designator ,string)))
;; Check that reading it with a wrong class designator signals an error.
,@(loop :for wrong-class
:in (remove class-designator '(null keyword string vector hash-table number))
:collect `(signals error (jarl:read ',wrong-class ,string))))))))
(define-basic-tests null
(nil null "null"))
(define-basic-tests keywords
(:true keyword "true")
(:false keyword "false"))
(define-basic-tests integers
(0 number "0")
(0 number "-0")
(1 number "1")
(-1 number "-1")
(10 number "10")
(-10 number "-10")
(123456789123456789123456789 number "123456789123456789123456789")
(-123456789123456789123456789 number "-123456789123456789123456789"))
(define-basic-tests floats
(0.0d0 number "0e0")
(0.0d0 number "0.0e0")
(-0.0d0 number "-0.0e0")
(1.0d0 number "1e0")
(1.0d0 number "1e+0")
(1.0d0 number "1e-0")
(1.2d0 number "1.2e0")
(1.2d0 number "1.2e+0")
(1.2d0 number "1.2e-0")
(100.0d0 number "1e2")
(100.0d0 number "1e+2")
(123.4d0 number "0.01234e+4")
(0.1234d0 number "1.234e-1")
(1.234d-10 number "1.234e-10"))
(define-basic-tests strings
("" string "''")
(" " string "' '")
(" " string " ' ' ")
("foo" string "'foo'")
("\"foo" string "'\\'foo'")
("f\\oo" string "'f\\\\oo'")
((format nil "foo~%bar") string "'foo\\nbar'")
((format nil "foo~Abar" #\tab) string "'foo\\tbar'")
((format nil "u: ~A" (code-char #x1234)) string "'u: \\u1234'")
((format nil "(~A)" (code-char #xCAFE)) string "'(\\uCaFe)'")
((format nil "~A~A" (code-char #xABCD) (code-char #xBEEF)) string "'\\uABCD\\ubeef'"))
(define-basic-tests vectors
(#() vector "[]")
(#(1) vector "[1]")
(#(1 2 3) vector "[1,2,3]")
(#("meow" "wow") vector "['meow', 'wow']")
(#(1 nil "meow" :false -2 :true) vector "[1, null, 'meow', false, -2, true]")
(#(#(1 2) #() #(3.0d0 4.0d0 5.0d0)) vector "[[1, 2], [], [3e0, 40e-1, 0.5e1]]"))
(define-basic-tests objects
((h) hash-table "{}")
((h "foo" 1 "bar" 2) hash-table "{'foo': 1, 'bar': 2}")
((h "foo" 1 "bar" 2) hash-table "{'bar': 2, 'foo': 1}")
((h "foo" (h "a" nil "b" :false)
"bar" :true
"baz" (v (h) (h) (h)))
hash-table
"{'foo': {'a': null, 'b': false},
'bar': true,
'baz': [{},{},{}]}"))
(define-basic-tests whitespace
(#() vector "[ ]")
((h) hash-table " { }")
((v (v) (h)) vector " [[ ] , { }]")
(#(1 2 3 4 5) vector " [ 1, 2 ,3, 4,5]"))
(define-test multiple-objects
(with-input-from-string (s (json "{} 1 2 [true, false] {'foo': null}"))
(is (same (h) (jarl:read t s)))
(is (same 1 (jarl:read t s)))
(is (same 2 (jarl:read t s)))
(is (same #(:true :false) (jarl:read t s)))
(is (same (h "foo" nil) (jarl:read t s)))
(is (eql :eof (jarl:read t s nil :eof)))
(signals end-of-file (jarl:read t s))))
(define-test complicated-object
(is (same (v (h "foo" (v 1 nil 2)
"bar" (v))
(h)
(h "baz" (v nil 3)))
(jarl:read '(vector (hash-table (vector (or null number))))
(json "[{ 'foo': [1, null, 2],
'bar': [] },
{},
{ 'baz': [null, 3] }]")))))
;;;; Real-World Data ----------------------------------------------------------
(defmacro define-file-test (name (object path) &body body)
(alexandria:with-gensyms (string)
`(define-test ,name
(let ((,string (alexandria:read-file-into-string ,path)))
;; Check that discarding works.
(check-discards-one-object ,string)
(let ((,object (jarl:read t ,string)))
;; Check that we can discard it.
(check-roundtrips ,object)
;; Other test-specific checks.
,@body)))))
(define-file-test github/sjl (o "test/data/github/sjl.json")
(is (string= "sjl" (gethash "login" o)))
(is (= 182 (gethash "public_repos" o))))
(define-file-test github/sjl-repos (o "test/data/github/sjl-repos.json")
(is (set-equal '(:true :false)
(remove-duplicates (map 'list (lambda (r) (gethash "fork" r)) o)))))
(define-file-test reddit/r-common_lisp (o "test/data/reddit/r-common_lisp.json"))
(define-file-test jira/MVNCENTRAL (o "test/data/jira/MVNCENTRAL.json"))
(define-file-test openweathermap/onecall (o "test/data/openweathermap/onecall.json"))
(defclass owm/weather ()
((id :json number)
(main :json string)
(description :json string)
(icon :json string))
(:metaclass jarl::json-class))
(defclass owm/day ()
((clouds :json number)
(dew-point :json number)
(timestamp :json number :json/name "dt")
(humidity :json number)
(pressure :json number)
(sunrise :json number)
(sunset :json number)
(temperature :json t :json/name "temp")
(feels-like :json t)
(uvi :json number)
(visibility :json number)
(weather :json (vector owm/weather))
(wind-degree :json number :json/name "wind_deg")
(wind-speed :json number))
(:metaclass jarl::json-class))
(defclass owm/hour ()
((clouds :json number)
(dew-point :json number)
(timestamp :json number :json/name "dt")
(precipitation :json number :json/name "pop")
(humidity :json number)
(pressure :json number)
(sunset :json number)
(temperature :json number :json/name "temp")
(feels-like :json number)
(visibility :json number)
(weather :json (vector owm/weather))
(wind-degree :json number :json/name "wind_deg")
(wind-speed :json number))
(:metaclass jarl::json-class))
(defclass owm/minute ()
((timestamp :json number :json/name "dt")
(precipitation :json number))
(:metaclass jarl::json-class))
(defclass owm/onecall ()
((latitude :json number :json/name "lat")
(longitude :json number :json/name "lon")
(timezone :json string)
(timezone-offset :json number)
(current :json owm/day)
(daily :json (vector owm/day))
(hourly :json (vector owm/hour))
(minutely :json (vector owm/minute)))
(:metaclass jarl::json-class))
(define-test parse-owm-data-into-classes
;; At least make sure it doesn't crash.
(with-open-file (f "test/data/openweathermap/onecall.json")
(is (typep (jarl:read 'owm/onecall f) 'owm/onecall))))
;;;; Error Tests --------------------------------------------------------------
(defmacro define-error-tests (name &rest clauses)
`(define-test ,name
,@(loop :for (line col string) :in clauses
:collect `(check-errors ,line ,col (json ,string)))))
(define-error-tests trash
(1 1 "meow")
(1 3 "number")
(1 4 "truthy")
(1 3 "famous")
(1 1 "<what>")
(1 1 "(cons nil nil)")
(1 1 "NULL")
(1 1 "undefined")
(1 1 "NaN")
(1 1 ":::")
(1 1 "&rest")
(1 1 "]")
(1 1 "}"))
(define-error-tests bad-eof
(1 4 "nul")
(1 4 "tru")
(1 5 "fals")
(1 2 "[")
(1 7 "['no',")
(1 6 "['no'")
(1 5 "[[[{")
(1 2 "{")
(1 6 "{'foo")
(1 7 "{'foo'")
(1 8 "{'foo':")
(1 10 "{'foo': 1")
(1 11 "{'foo': 1,")
(1 2 "'")
(1 7 "'whops")
(1 9 "'whops\\'")
(1 2 "1.")
(1 2 "1e")
(1 3 "1e-")
(1 3 "1e+")
(1 1 "-"))
(define-error-tests mispaired-delimiters
(1 2 "{]")
(1 2 "[}")
(1 10 "[1, [2, 3}]"))
(define-error-tests commas
(1 1 ",")
(1 2 "[,]")
(1 4 "[1 2]")
(1 4 "[1,,2]")
(1 2 "{,}")
(1 9 "{'a': 1,}")
(1 9 "{'a': 1,, 'b': 2}")
(1 5 "{'a', 1}")
(1 2 "{,'a': 1}"))
(define-error-tests unescaped-string-chars
;; todo more of these
(2 0 (format nil "'~%'")))
(define-error-tests bad-unicode-sequence
;; todo more of these
(1 4 "'\\uNOPE'")
(1 6 "'\\u12'")
(1 4 "'\\u 1234'")
(1 4 "'\\uUUID'"))
(define-error-tests bad-escape
;; todo more of these
(1 3 "'\\x'"))
(define-error-tests leading-zero
(1 1 "01")
(1 1 "00")
(1 1 "00.0"))
(define-test size-limit
;; TODO Add some more of these.
(let ((jarl::*read-size-limit* 9))
(is (same #(1 2 3) (jarl:read t "[1, 2, 3]")))
(signals jarl::json-size-limit-exceeded-error (jarl:read t "[1, 2, 3 ]"))
(signals jarl::json-size-limit-exceeded-error (jarl:read t " null"))
(signals jarl::json-size-limit-exceeded-error (jarl:read t "\"foobarbaz"))
(signals jarl::json-size-limit-exceeded-error (jarl:read t "[[[[[[[[[[[[[[[[[[["))
(signals jarl::json-size-limit-exceeded-error (jarl:read nil "[1, 2, 3 ]"))
(let ((input (jarl::make-input "123456789[][1,2,3,4,5,6,7,8,9]")))
(is (same 123456789 (jarl:read t input)))
(is (same (v) (jarl:read t input)))
(signals jarl::json-size-limit-exceeded-error (jarl:read t input)))))
(define-test depth-limit
;; TODO Add some more of these.
(let ((jarl::*read-depth-limit* 3))
(is (same #(#(#(1))) (jarl:read t "[[[1]]]")))
(signals jarl::json-depth-limit-exceeded-error (jarl:read t "[[[[1]]]]"))
(signals jarl::json-depth-limit-exceeded-error (jarl:read t (json "[{'foo': [[1]]}]")))
(signals jarl::json-depth-limit-exceeded-error (jarl:read nil "[[[[1]]]]"))
(signals jarl::json-depth-limit-exceeded-error (jarl:read nil (json "[{'foo': [[1]]}]")))
(let ((input (jarl::make-input "[[[]]][[[[]]]]")))
(is (same (v (v (v))) (jarl:read t input)))
(signals jarl::json-depth-limit-exceeded-error (jarl:read t input))) ))
;;;; MOP ----------------------------------------------------------------------
(defclass foo ()
((i :json number :initarg :i)
(s :json string :initarg :s)
(k :json keyword :initarg :k)
(n :json null :initarg :n)
(h :json hash-table :initarg :h)
(v :json vector :initarg :v)
(any :json t :initarg :any))
(:metaclass jarl:json-class))
(defclass bar ()
((id :json (or null number) :initarg :id)
(foos :json (vector foo) :initarg :foos))
(:metaclass jarl:json-class))
(defun foo (&rest args) (apply #'make-instance 'foo args))
(defun bar (&rest args) (apply #'make-instance 'bar args))
(defmethod same ((a foo) (b foo))
(slots= a b 'i 's 'k 'n 'h 'v 'any))
(defmethod same ((a bar) (b bar))
(slots= a b 'id 'foos))
(defmacro define-class-tests (name &body clauses)
`(define-test ,name
,@(loop :for (class string . initargs) :in clauses
:collect `(is (same (make-instance ',class ,@initargs)
(jarl:read ',class (json ,string)))))))
(define-class-tests basic-class
(foo "{}")
(foo "{'i': 1}" :i 1)
(foo "{'i': 1, 's': 'meow'}" :i 1 :s "meow")
(foo "{ 'i': 2,
's': 'wow',
'k': false,
'n': null,
'h': {'x': 'hello', 'y': -1},
'v': [true, 1,2, 'x'],
'any': 0.0 }"
:i 2
:s "wow"
:k :false
:n nil
:h (h "x" "hello" "y" -1)
:v (v :true 1 2 "x")
:any 0d0))
(define-class-tests nested-classes
(bar "{}")
(bar "{'id': 1}" :id 1)
(bar "{'id': 1, 'foos': []}" :id 1 :foos (v))
(bar "{'id': null, 'foos': [{'i': 10}, {'n': null, 'v': []}]}"
:id nil
:foos (v (foo :i 10) (foo :n nil :v (v)))))
(define-test class-indent
(let ((jarl::*indent* t))
(is (string= (format nil "{~% \"v\": [~% 1,~% 2,~% 3~% ]~%}")
(jarl:print (make-instance 'foo :v #(1 2 3)) nil)))))
;;;; Slot Coalescing ----------------------------------------------------------
(defclass coal/0 ()
((foo :json number :initarg :foo)
(bar :json string :json/name "bar0" :initarg :bar))
(:metaclass jarl:json-class))
(defclass coal/1 (coal/0)
((foo :json string)
(bar :json/name "bar1"))
(:metaclass jarl:json-class))
(defclass coal/2 (coal/1)
((foo))
(:metaclass jarl:json-class))
(defun coal/0 (&rest args) (apply #'make-instance 'coal/0 args))
(defun coal/1 (&rest args) (apply #'make-instance 'coal/1 args))
(defun coal/2 (&rest args) (apply #'make-instance 'coal/2 args))
(defmethod same ((a coal/0) (b coal/0)) (slots= a b 'foo 'bar))
(defmethod same ((a coal/1) (b coal/1)) (slots= a b 'foo 'bar))
(defmethod same ((a coal/2) (b coal/2)) (slots= a b 'foo 'bar))
(define-test slot-coalescing-json-class
;; More-specific classes should take precedence.
(is (same (coal/0 :foo 1) (jarl:read 'coal/0 (json "{'foo': 1}"))))
(is (same (coal/1 :foo "meow") (jarl:read 'coal/1 (json "{'foo': 'meow'}"))))
(is (same (coal/2 :foo "meow") (jarl:read 'coal/2 (json "{'foo': 'meow'}")))))
(define-test slot-coalescing-json-name
;; More-specific names should take precedence.
(is (same (coal/0 :bar "x") (jarl:read 'coal/0 (json "{'bar0': 'x'}"))))
(is (same (coal/1 :bar "x") (jarl:read 'coal/1 (json "{'bar1': 'x'}"))))
(is (same (coal/2 :bar "x") (jarl:read 'coal/2 (json "{'bar1': 'x'}")))))
;;;; Wrappers -----------------------------------------------------------------
(defclass w ()
((names :type list :initarg :names)))
(define-test wrappers
(jarl::set-wrapper
'w '(vector string)
:read (lambda (strings) (make-instance 'w :names (coerce strings 'list)))
:print (lambda (w) (coerce (slot-value w 'names) 'vector)))
(jarl::set-wrapper
'uuid:uuid 'string
:read 'uuid:make-uuid-from-string
:print 'princ-to-string)
(unwind-protect
(progn
(is (equal `("a" "b" "c")
(slot-value (jarl:read 'w (json "['a', 'b', 'c']")) 'names)))
(is (uuid:uuid=
(uuid:make-uuid-from-string "733DB032-C573-4EAA-AF6B-0FF7C99302D2")
(jarl:read 'uuid:uuid (json "'733db032-c573-4eaa-af6b-0ff7c99302d2'"))))
(is (string= (json "'733DB032-C573-4EAA-AF6B-0FF7C99302D2'")
(string-upcase
(jarl:print
(uuid:make-uuid-from-string "733DB032-C573-4EAA-AF6B-0FF7C99302D2")
nil))))
(is (string= (json "['meow','wow']")
(jarl:print (make-instance 'w :names '("meow" "wow")) nil))))
(map nil 'jarl::remove-wrapper '(w uuid:uuid))))
;;;; Allow Print/Read ---------------------------------------------------------
(defclass apr ()
((id :json number :initarg :id))
(:metaclass jarl:json-class))
(defclass apr/deny-read ()
((id :json number :initarg :id))
(:metaclass jarl:json-class)
(:allow-read nil))
(defclass apr/deny-print ()
((id :json number :initarg :id))
(:metaclass jarl:json-class)
(:allow-print nil))
(defclass apr/sub (apr)
()
(:metaclass jarl:json-class))
(defclass apr/sub/remove (apr/sub)
()
(:metaclass jarl:json-class)
(:allow-print nil)
(:allow-read nil))
(defclass apr/sub/remove/sub (apr/sub/remove)
()
(:metaclass jarl:json-class))
(defclass apr/sub/add (apr/sub/remove)
()
(:metaclass jarl:json-class)
(:allow-print t)
(:allow-read t))
(define-test allow-read
(is (= 1 (slot-value (jarl:read 'apr (json "{'id': 1}")) 'id)))
(is (= 1 (slot-value (jarl:read 'apr/deny-print (json "{'id': 1}")) 'id)))
(signals error (jarl:read 'apr/deny-read (json "{'id': 1}"))))
(define-test allow-print
(is (string= (json "{'id':1}") (jarl:print (make-instance 'apr :id 1) nil)))
(is (string= (json "{'id':1}") (jarl:print (make-instance 'apr/deny-read :id 1) nil)))
(signals error (jarl:print (make-instance 'apr/deny-print :id 1) nil)))
(define-test allow-read-inheritance
(is (= 1 (slot-value (jarl:read 'apr (json "{'id': 1}")) 'id)))
;; Subclassing without overriding inherits.
(is (= 1 (slot-value (jarl:read 'apr/sub (json "{'id': 1}")) 'id)))
;; Remove, can no longer read.
(signals error (jarl:read 'apr/sub/remove (json "{'id': 1}")))
;; Can inherit the removal.
(signals error (jarl:read 'apr/sub/remove/sub (json "{'id': 1}")))
;; Readd, can print again.
(is (= 1 (slot-value (jarl:read 'apr/sub/add (json "{'id': 1}")) 'id))))
(define-test allow-print-inheritance
(is (string= (json "{'id':1}") (jarl:print (make-instance 'apr :id 1) nil)))
;; Subclassing without overriding inherits.
(is (string= (json "{'id':1}") (jarl:print (make-instance 'apr/sub :id 1) nil)))
;; Remove, can no longer read.
(signals error (jarl:print (make-instance 'apr/sub/remove :id 1) nil))
;; Can inherit the removal.
(signals error (jarl:print (make-instance 'apr/sub/remove/sub :id 1) nil))
;; Readd, can print again.
(is (string= (json "{'id':1}") (jarl:print (make-instance 'apr/sub/add :id 1) nil))))
;;;; After Read/Before Print --------------------------------------------------
(define-condition validation-error (error) ())
(defun validate-small (i)
(if (> (abs i) 10)
(error 'validation-error)
i))
(defclass arbp ()
((i :json number :initarg :i
:json/after-read validate-small)
(s :json string :initarg :s
:json/after-read string-upcase
:json/before-print string-downcase))
(:metaclass jarl:json-class))
(define-test before-print
(is (string= (json "{'s':'hello'}")
(jarl:print (make-instance 'arbp :s "Hello") nil))))
(define-test after-read
(is (string= "HELLO" (slot-value (jarl:read 'arbp (json "{'s':'Hello'}")) 's)))
(is (= 5 (slot-value (jarl:read 'arbp (json "{'i':5}")) 'i)))
(signals validation-error (jarl:read 'arbp (json "{'i':999}"))))
;;;; Unknown Slots ------------------------------------------------------------
(defclass us-pres ()
((id :json number))
(:metaclass jarl:json-class)
(:unknown-slots :preserve))
(defclass us-disc ()
((id :json number))
(:metaclass jarl:json-class)
(:unknown-slots :discard))
(defclass us-err ()
((id :json number))
(:metaclass jarl:json-class)
(:unknown-slots :error))
(define-test preserve-unknown-slots
(is (string= (json "{'id':1}")
(roundtrip-string 'us-pres "{'id':1}")))
(is (string= (json "{'foo':10}")
(roundtrip-string 'us-pres "{'foo':10}")))
(is (same (h "id" 1 "foo" "bar" "meow" "wow")
(jarl:read t (roundtrip-string 'us-pres "{'id':1, 'foo': 'bar', 'meow': 'wow'}")))))
(define-test discard-unknown-slots
(is (string= (json "{'id':1}")
(roundtrip-string 'us-disc "{'id':1}")))
(is (string= (json "{}")
(roundtrip-string 'us-disc "{'foo':10}")))
(is (string= (json "{'id':1}")
(roundtrip-string 'us-disc "{'id':1, 'foo': 'bar', 'meow': 'wow'}"))))
(define-test error-on-unknown-slots
(is (string= (json "{'id':1}")
(roundtrip-string 'us-err "{'id':1}")))
(signals jarl::unknown-json-slot-error
(jarl:read 'us-err (json "{'foo':10}")))
(signals jarl::unknown-json-slot-error
(jarl:read 'us-err (json "{'id':1, 'foo': 'bar', 'meow': 'wow'}"))))
;;;; Passing Input ------------------------------------------------------------
(define-test passing-input
(let ((input (jarl::make-input (json "[1,2] 99 [} {}"))))
(is (same (v 1 2) (jarl:read '(vector number) input)))
(is (same 99 (jarl:read 'number input)))
(handler-case
(progn (jarl:read 'vector input)
(error "Should have signaled an error, but did not."))
(jarl::json-reading-error (e)
(is (= 1 (jarl::line e)))
(is (= 13 (jarl::column e)))))))
;;;; Fuzz Utilities -----------------------------------------------------------
(defparameter *basic-chars*
" abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789-_,'[]{}+=")
(defparameter *gen-depth* 0)
(defparameter *max-gen-depth* 5)
(chancery:define-rule gen/keyword
:true
:false)
(chancery:define-rule gen/null
nil)
(chancery:define-rule (random-char :distribution :weighted)
(50 (chancery:eval (string (alexandria:random-elt *basic-chars*))))
(1 "\\\\")
(1 "\\\"")
(1 "\\n")
(1 "\\b")
(1 "\\f")
(1 "\\t")
;; todo more unicode
(1 (chancery:eval (format nil "\\u~4,'0X" (char-code (alexandria:random-elt *basic-chars*))))))
(defun random-string ()
(with-output-to-string (s)
(dotimes (i (random 20))
(write-string (random-char) s))))
(chancery:define-rule (gen/string :distribution :weighted)
(1 "")
(5 random-string))
(chancery:define-rule gen/float
0.0d0
(chancery:eval (- (random 1d12) 0.5d12)))
(defun gen/integer ()
(- (random 100000) 50000))
(chancery:define-rule gen/number
0
0d0
gen/integer
gen/float)
(defun gen/vector ()
(if (> *gen-depth* *max-gen-depth*)
(vector)
(let ((result (make-array (random 20)))
(*gen-depth* (1+ *gen-depth*)))
(dotimes (i (length result))
(setf (aref result i) (gen/any)))
result)))
(defun gen/object ()
(if (> *gen-depth* *max-gen-depth*)
(h)
(let* ((result (h))
(*gen-depth* (1+ *gen-depth*))
(keys (remove-duplicates (loop :repeat (random 10)
:collect (gen/string))
:test #'equal)))
(dolist (k keys)
(setf (gethash k result) (gen/any)))
result)))
(chancery:define-rule gen/any
gen/keyword
gen/null
gen/string
gen/number
gen/vector
gen/object)
(defun copy-and-map-hash-table (function hash-table)
(let ((result (make-hash-table :test #'equal
:size (hash-table-count hash-table))))
(maphash (lambda (k v)
(setf (gethash (funcall function k) result)
(funcall function v)))
hash-table)
result))
(defgeneric to-jarl (from o)
(:method (from o) (declare (ignore from)) o)
(:method (from (o string)) (declare (ignore from)) o))
(defmethod to-jarl (from (o vector))
(map 'vector (alexandria:curry #'to-jarl from) o))
(defmethod to-jarl (from (o hash-table))
(copy-and-map-hash-table (alexandria:curry #'to-jarl from) o))
(defgeneric from-jarl (to o)
(:method (to o) (declare (ignore to)) o)
(:method (to (o string)) (declare (ignore to)) o))
(defmethod from-jarl (to (o vector))
(map 'vector (alexandria:curry #'from-jarl to) o))
(defmethod from-jarl (to (o hash-table))
(copy-and-map-hash-table (alexandria:curry #'from-jarl to) o))
;;;; Yason Fuzzing ------------------------------------------------------------
(defun yason/read (string)
(let ((yason:*parse-json-arrays-as-vectors* t)
(yason:*parse-json-booleans-as-symbols* t)
(*read-default-float-format* 'double-float))
(yason:parse string)))
(defun yason/print (object)
(let ((yason:*parse-json-arrays-as-vectors* t)
(yason:*parse-json-booleans-as-symbols* t)
(*read-default-float-format* 'double-float))
(with-output-to-string (s)
(yason:encode object s))))
(defmethod to-jarl ((from (eql 'yason)) (o symbol))
(alexandria:make-keyword o))
(defmethod to-jarl ((from (eql 'yason)) (o null))
nil)
(defmethod to-jarl ((from (eql 'yason)) (o string))
#+abcl (copy-seq o) ; https://github.com/armedbear/abcl/issues/275
#-abcl o)
(defmethod from-jarl ((to (eql 'yason)) (o symbol))
(ecase o
((nil) nil)
(:true 'yason:true)
(:false 'yason:false)))
(define-test fuzz-against-yason
(dotimes (i 1000)
(let* ((o (gen/any))
(js (jarl:print o nil))
(ys (yason/print (from-jarl 'yason o))))
(is (same (jarl:read t js)
(to-jarl 'yason (yason/read js))))
(is (same (jarl:read t ys)
(to-jarl 'yason (yason/read ys)))))))