Add lots of tests for new features

2 files changed, 175 insertions, 17 deletions

diff --git a/test/chibi.scm b/test/chibi.scm
index 7d960f2..ba1bb54 100644
--- a/test/chibi.scm
+++ b/test/chibi.scm
@@ -1,5 +1,7 @@
 (import (scheme base)
-	(except (chibi test) test-equal))
+	(scheme case-lambda)
+	(except (chibi test) test-equal)
+	(srfi 2))
 
 (import (zambyte meta json))
 
diff --git a/test/run.scm b/test/run.scm
index a2a515b..f3d63dc 100644
--- a/test/run.scm
+++ b/test/run.scm
@@ -1,3 +1,4 @@
+;; json-object constructor tests
 (test-assert "json-object should meet json-object?"
   (json-object? (json-object)))
 
@@ -8,6 +9,7 @@
 (test-assert "json-object should not meet json-list?"
   (not (json-list? (json-object '(x . 5)))))
 
+;; json-list constructor tests
 (test-assert "json-list should not meet json-object?"
   (not (json-object? (json-list 1 2 3))))
 
@@ -17,9 +19,11 @@
 (test-assert "json-list should meet json-list?"
   (json-list? (json-list "a" 1 #t)))
 
+;; json-null? predicate test
 (test-assert "json-null should meet json-null?"
   (json-null? json-null))
 
+;; json-value? predicate tests
 (test-assert "numbers should meet json-value?"
   (json-value? 5))
 
@@ -35,12 +39,26 @@
 (test-assert "json-lists should meet json-value?"
   (json-value? (json-list 1 2 3)))
 
+;; json-object-contains-key predicate tests
 (test-assert "json-object-contains-key? should return true when the object contains the key"
   (json-object-contains-key? (json-object '(x . 5)) 'x))
 
 (test-assert "json-object-contains-key? should return false when the object does not contain the key"
   (not (json-object-contains-key? (json-object '(x . 5)) 'y)))
 
+(test-assert "json-object-contains-key? should be met when the associated value is false"
+  (json-object-contains-key? (json-object '(x . #f)) 'x))
+
+(test-assert "json-object-contains-key? should be met when the associated value is an empty json-list"
+  (json-object-contains-key? (json-object `(x . ,(json-list))) 'x))
+
+(test-assert "json-object-contains-key? should be met when the associated value is an empty json-object"
+  (json-object-contains-key? (json-object `(x . ,(json-object))) 'x))
+
+(test-assert "json-object-contains-key? should be met when the associated value is json-null"
+  (json-object-contains-key? (json-object `(x . ,json-null)) 'x))
+
+;; string->json tests
 (test-assert "the null string should meet json-null? when parsed"
   (json-null? (string->json "null")))
 
@@ -62,18 +80,7 @@
 (test-assert "string->json should return an object without the incorrect keys"
   (not (json-object-contains-key? (string->json "{\"x\": 5}") 'y)))
 
-(test-assert "json-object-contains-key? should be met when the associated value is false"
-  (json-object-contains-key? (json-object '(x . #f)) 'x))
-
-(test-assert "json-object-contains-key? should be met when the associated value is an empty json-list"
-  (json-object-contains-key? (json-object `(x . ,(json-list))) 'x))
-
-(test-assert "json-object-contains-key? should be met when the associated value is an empty json-object"
-  (json-object-contains-key? (json-object `(x . ,(json-object))) 'x))
-
-(test-assert "json-object-contains-key? should be met when the associated value is json-null"
-  (json-object-contains-key? (json-object `(x . ,json-null)) 'x))
-
+;; json-ref tests
 (test-equal "json-ref should get a value associated with a key in an object"
   5 (json-ref (json-object '(x . 5)) 'x))
 
@@ -89,8 +96,157 @@
 (test-equal "json-ref should recursively get a value in an object in a list"
   5 (json-ref (json-list (json-object) (json-object '(a . 4) '(b . 5) '(c . 6)) #t) 1 'b))
 
-;; (json (object))				; => {}
-
-;; (json (list))				; => []
+(test-assert "json-ref should return no values when a key is missing"
+  (call-with-values (lambda () (json-ref (json-object '(a . 4)) 'b))
+    (case-lambda
+      (() #t)
+      (_ #f))))
+
+(test-assert "json-ref should return a default value when a key is missing"
+  (parameterize ((json-key-not-found (lambda () 'undefined)))
+    (case (json-ref (json-object '(a . 4)) 'b)
+      ((undefined) #t)
+      (else #f))))
+
+(test-assert "json-ref should raise an exception when a key is missing"
+  (guard (e
+	  ((eq? e 'key-not-found) #t)
+	  (else #f))
+    (parameterize ((json-key-not-found (lambda () (raise 'key-not-found))))
+      (and (json-ref (json-object '(a . 4)) 'b)
+	   #f))))
+
+;; json-object-set! tests
+(test-equal "should be able to mutate the value of a field using json-object-set!"
+  1
+  (let ((p (json-object '(x . 5))))
+    (json-object-set! p 'x 1)
+    (json-ref p 'x)))
+
+;; json macro tests
+(test-equal "(json (object)) should be {}"
+  "{}" (json->string (json (object))))
+
+(test-equal "(json (list)) should be []"
+  "[]" (json->string (json (list))))
+
+(test-equal "(json null) should be null"
+  "null" (json->string (json null)))
+
+(test-assert "(json (object)) should contain the correct keys"
+  (json-object-contains-key? (json (object (x . 5))) 'x))
+
+(test-assert "(json (object)) should not contain the incorrect keys"
+  (not (json-object-contains-key? (json (object (x . 5))) 'y)))
+
+(test-equal "should be able to use json-ref on (json (object))"
+  5 (json-ref (json (object (x . 5))) 'x))
+
+(test-equal "should be able to use json-ref on (json (list))"
+  2 (json-ref (json (list 1 2 3)) 1))
+
+;; define-json-record-type tests
+(define-json-record-type <point>
+  (point x y)
+  string->point
+  point?
+  (x point->x)
+  (y point->y point-set-y!))
+
+(test-assert "record constructor should meet the predicate"
+  (point? (point 1 2)))
+
+(test-assert "record value should be meet json-object?"
+  (json-object? (point 1 2)))
+
+(test-equal "record accessor should return associated value for field with only an accessor"
+  1 (point->x (point 1 2)))
+
+(test-equal "record accessor should return associated value for field an accessor and a mutator"
+  2 (point->y (point 1 2)))
+
+(test-equal "record mutator should mutate the record instance"
+  3
+  (let ((p (point 1 2)))
+    (point-set-y! p 3)
+    (point->y p)))
+
+(test-assert "should be able to mutate mutable record fields using json-object-set!"
+  (guard (_ (else #f))
+    (let ((p (point 1 2)))
+      (json-object-set! p 'y #t)
+      (point->y p))))
+
+(test-assert "should not be able to mutate immutable record fields using json-object-set!"
+  (guard (_ (else #t))
+    (let ((p (point 1 2)))
+      (json-object-set! p 'x #f)
+      (point->x p))))
+
+(test-assert "(json (object)) should meet the record predicate with only the correct keys"
+  (point? (json
+	   (object (x . 1)
+		   (y . 2)))))
+
+(test-assert "(json (object)) should meet the record predicate with extra keys"
+  (point? (json
+	   (object (x . 1)
+		   (y . 2)
+		   (z . (list 1 2 3))))))
+
+(test-assert "record should meet json-value?"
+  (json-value? (point 1 2)))
+
+(test-assert "record should round trip to a string"
+  (point? (string->json (json->string (point 1 2)))))
+
+(test-assert "record should round trip to a string with specialized converter"
+  (point? (string->point (json->string (point 1 2)))))
+
+(define-json-record-type <line-segment>
+  (line-segment start end)
+  string->line-segment
+  line-segment?
+  (start line-segment->start)
+  (end line-segment->end))
+
+(test-assert "record should be able to have other records as members"
+  (let* ((p1 (point 1 2))
+	 (p2 (point 3 4))
+	 (ls (line-segment p1 p2)))
+    (point? (line-segment->start ls))))
+
+(test-assert "nested records should be able to round trip to a string"
+  (and-let* ((p1 (point 1 2))
+	     (p2 (point 3 4))
+	     (ls (line-segment p1 p2))
+	     (str (json->string ls))
+	     (res (string->line-segment str)))
+    (and (line-segment? res)
+	 (point? (line-segment->start res)))))
+
+(define-json-record-type <three-d-point>
+  (three-d-point x y z)
+  string->three-d-point
+  three-d-point?
+  (x three-d-point->x)
+  (y three-d-point->y)
+  (z three-d-point->z))
+
+(test-assert "records with all of the correct keys should not meet the predicate for other records"
+  (let ((tdp (three-d-point 1 2 3)))
+    (and (three-d-point? tdp)
+	 (not (point? tdp)))))
+
+(test-assert "object with all of the correct keys should meet the predicate for multiple records"
+  (let ((tdp (json (object (x . 1) (y . 2) (z . 3)))))
+    (and (three-d-point? tdp)
+	 (point? tdp))))
+
+(test-assert "converting an object to a string and converting the string to a record should not meet multiple predicates"
+  (let* ((tdp (json (object (x . 1) (y . 2) (z . 3))))
+	 (str (json->string tdp))
+	 (tdp2 (string->three-d-point str)))
+    (and (three-d-point? tdp2)
+	 (not (point? tdp2)))))
 
-;; (json null)				; => null