--- a/TODO Tue Aug 18 21:50:45 2020 -0400
+++ b/TODO Wed Aug 19 00:10:39 2020 -0400
@@ -2,3 +2,5 @@
Add basic wrapper definition | id:861f048b3b69079dedf8779be1cb73c05e6fc732
Add after-read and before-print functions | id:9f982ca45b68d644159e0c64f0dc1b185f72a2f8
Add extra key preservation | id:cfb63b37d87893083fc98477ec3d488fb909a984
+Test reading explicit types, not just t. | id:d2def699c46f12c02d49c01c869fc9b927bda72d
+Add more MOP-based tests (including errors). | id:df727baeb41bad02c7d79b92f98c24c8a28ca772
--- a/test/tests.lisp Tue Aug 18 21:50:45 2020 -0400
+++ b/test/tests.lisp Wed Aug 19 00:10:39 2020 -0400
@@ -48,6 +48,16 @@
(null (set-difference y x :test #'equal))))
+(defun slot= (a b slot)
+ (if (not (slot-boundp a slot))
+ (not (slot-boundp b slot))
+ (same (slot-value a slot)
+ (slot-value b slot))))
+
+(defun slots= (a b &rest slots)
+ (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)))
@@ -310,31 +320,95 @@
(signals jarl::json-depth-limit-exceeded-error (jarl:read nil (json "[{'foo': [[1]]}]")))))
+;;;; 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)))))
+
+
;;;; Allow Print/Read ---------------------------------------------------------
-(defclass foo ()
+(defclass apr ()
((id :json number :initarg :id))
(:metaclass jarl:json-class))
-(defclass foo/deny-read ()
+(defclass apr/deny-read ()
((id :json number :initarg :id))
(:metaclass jarl:json-class)
(:allow-read nil))
-(defclass foo/deny-print ()
+(defclass apr/deny-print ()
((id :json number :initarg :id))
(:metaclass jarl:json-class)
(:allow-print nil))
(define-test allow-read
- (is (= 1 (slot-value (jarl:read 'foo (json "{'id': 1}")) 'id)))
- (is (= 1 (slot-value (jarl:read 'foo/deny-print (json "{'id': 1}")) 'id)))
- (signals error (jarl:read 'foo/deny-read (json "{'id': 1}"))))
+ (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 'foo :id 1) nil)))
- (is (string= (json "{'id':1}") (jarl:print (make-instance 'foo/deny-read :id 1) nil)))
- (signals error (jarl:print (make-instance 'foo/deny-print :id 1) nil)))
+ (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)))
;;;; Fuzz Utilities -----------------------------------------------------------