# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1597810239 14400
# Node ID c9eb52bb4d0ab89244a52ac6a41354e8607a8298
# Parent  8e500ea0d9ff5b455516f085c341a2746bc4a544
Add some basic tests for the MOP-based stuff

diff -r 8e500ea0d9ff -r c9eb52bb4d0a TODO
--- 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
diff -r 8e500ea0d9ff -r c9eb52bb4d0a test/tests.lisp
--- 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 -----------------------------------------------------------