path: root/test/run.scm

;; json-object constructor tests
(test-assert "json-object should meet json-object?"
  (json-object? (json-object)))

(test-assert "json-object should meet json-object?"
  (json-object? (json-object '(name . "alice")
			     '(age . 26))))

(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))))

(test-assert "json-list should meet json-list?"
  (json-list? (json-list)))

(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))

(test-assert "strings should meet json-value?"
  (json-value? "hello"))

(test-assert "booleans should meet json-value?"
  (json-value? #t))

(test-assert "json-objects should meet json-value?"
  (json-value? (json-object '(x . 5))))

(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")))

(test-equal "numbers should parse to their scheme values"
  5 (string->json "5"))

(test-equal "true should parse to the boolean true"
  #t (string->json "true"))

(test-equal "false should parse to the boolean false"
  #f (string->json "false"))

(test-equal "string->json should properly parse string values"
  "hello" (string->json "\"hello\""))

(test-assert "string->json should return an object with the correct keys"
  (json-object-contains-key? (string->json "{\"x\": 5}") 'x))

(test-assert "string->json should return an object without the incorrect keys"
  (not (json-object-contains-key? (string->json "{\"x\": 5}") 'y)))

;; 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))

(test-equal "json-ref should get the value at an index of a list"
  5 (json-ref (json-object '(x . 5) '(y . #t)) 'x))

(test-equal "json-ref should get the value at an index of a list"
  2 (json-ref (json-list 1 2 3) 1))

(test-equal "json-ref should recursively get a value in a list in an object"
  json-null (json-ref (json-object `(x . ,(json-list #t json-null #f))) 'x 1))

(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))

(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))))
    (set! p (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)))
    (set! p (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)))
      (set! p (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 (e ((or (eq? e 'could-mutate)
		 (eq? e 'no-error)) #f)
	    (else #t))
    (let ((p (point 1 2)))
      (set! p (json-object-set! p 'x #f))
      (if (not (point->x p))
	  (raise 'could-mutate)
	  (raise 'no-error)))))

(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"
  (let* ((ls (line-segment (point 1 2) (point 3 4)))
	 (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)))))

(test-assert "the string to record converter should raise an exception if there are missing keys"
  (guard (_ (else #t))
    (string->point "{\"x\": 5}")
    #f))