;;; Copyright (c) 2000-2004, 2007 Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
;;;
;;; Permission is hereby granted, free of charge, to any person obtaining a copy
;;; of this software and associated documentation files (the "Software"), to deal
;;; in the Software without restriction, including without limitation the rights
;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
;;; copies of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be included in
;;; all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
;;; THE SOFTWARE.
;;
(print-struct #t)

(require "ubf.ss"
	 (lib "4.ss" "srfi")
	 (lib "6.ss" "srfi")
	 (lib "13.ss" "srfi")
	 (planet "test.ss" ("schematics" "schemeunit.plt" 2))
	 (planet "text-ui.ss" ("schematics" "schemeunit.plt" 2)))

(define (object->ubf x)
  (let ((p (open-output-string)))
    (encode-ubf-a (lambda (ch) (display ch p)) x)
    (get-output-string p)))

(define (ubf->object x)
  (let ((p (open-input-string x)))
    (decode-ubf-a (lambda () (read-char p)))))

(define (u8vector=? u1 u2)
  (and (= (u8vector-length u1) (u8vector-length u2))
       (let loop ((index (- (u8vector-length u1) 1)))
	 (cond
	  ((negative? index) #t)
	  ((= (u8vector-ref u1 index) (u8vector-ref u2 index)) (loop (- index 1)))
	  (else #f)))))

(define the-eof-object
  (let ((p (open-input-string "")))
    (read p)))

(define-struct reference-object (name encoding value comparator) (make-inspector))

(define (load-test-case-definition sym)
  (let* ((str (symbol->string sym))
	 (test-case-text (with-input-from-file (string-append "../../tests/encoding-tests/" str)
			   (lambda ()
			     (do ((ch (read-char) (read-char))
				  (acc '() (cons ch acc)))
				 ((eof-object? ch)
				  (list->string (reverse acc))))))))
    (list str test-case-text)))

(define (test-spec->reference-object test-spec)
  (let ((definition (load-test-case-definition (car test-spec))))
    (make-reference-object (car definition)
			   (cadr definition)
			   (cadr test-spec)
			   (if (null? (cddr test-spec))
			       equal?
			       (caddr test-spec)))))

(define reference-objects
  (map test-spec->reference-object
       `((ok:bigger-negative-integers #(-123 -234 -345))
	 (ok:bizarre-tag-with-backquote ,(make-tagged-ubf (string->symbol "a`b") '()))
	 (ok:bizarre-tag-with-backslash ,(make-tagged-ubf (string->symbol "a\\b") '()))
	 (ok:double-tag ,(make-tagged-ubf 'outer (make-tagged-ubf 'inner '())))
	 (ok:empty-structure #())
	 (ok:large-integer 123456789123456789)
	 (ok:list (a b))
	 (ok:list-of-lists ((1) (2)))
	 (ok:list-with-registers (hello hello hello))
	 (ok:negative-integer -123)
	 (ok:negative-integers #(-1 -2 -3))
	 (ok:register-allocation-sensible #(1 "a" 1 "b" 1 "c" 1 "d" 1))
	 (ok:small-integer 123)
	 (ok:string "a\"b")
	 (ok:struct-of-structs #(a #(1) b #(2) c #(3) d))
	 (ok:struct-of-tagged-values #(,(make-tagged-ubf 'a 1)
				       ,(make-tagged-ubf 'b 2)
				       ,(make-tagged-ubf 'c 3)))
	 (ok:structure-vector #(1 2 3))
	 (ok:structure-with-registers #(hello hello hello))
	 (ok:symbol ,(string->symbol "a'b"))
	 (ok:tagged-structure ,(make-tagged-ubf 'tag '#(1 2 3)))
	 (ok:u8vector ,(u8vector 97 98 99) ,u8vector=?))))

(define (make-test-suite name tests)
  (define (void-thunk) (void))
  (make-schemeunit-test-suite name tests void-thunk void-thunk))

(define all-ubf-encoding-tests
  (make-test-suite
   "UBF encoding tests"

   (map (lambda (ro)
	  (test-case (string-append "Encode: " (reference-object-name ro))
		     (check-equal? (reference-object-encoding ro)
				   (object->ubf (reference-object-value ro)))))
	reference-objects)))

(define all-ubf-decoding-tests
  (make-test-suite
   "UBF decoding tests"

   (map (lambda (ro)
	  (test-case (string-append "Decode: " (reference-object-name ro))
		     (check-true ((reference-object-comparator ro)
				  (ubf->object (reference-object-encoding ro))
				  (reference-object-value ro)))))
	(append reference-objects
		(map test-spec->reference-object
		     `((ok:ignore-spaces hi)
		       (ok:ignore-comments 123)
		       (ok:struct-with-comma #(1 2 3))
		       (ok:comment-escaping #(123 234))
		       (fail:early-end-of-stream ,the-eof-object)
		       (fail:early-end-of-string ,the-eof-object)
		       ))))))

(define (not-break-exn? x)
  (and (exn? x)
       (not (exn:break? x))))

(define error-checking-tests
  (make-test-suite
   "Error checking tests"

   (let ((fail-test (lambda (test-definition-sym)
		      (let ((definition (load-test-case-definition test-definition-sym)))
			(test-case (car definition)
				   (check-exn not-break-exn?
					      (lambda ()
						(let ((o (ubf->object
							  (cadr definition))))
						  (write (list
							  'received-result-unexpectedly
							  o))
						  (newline)
						  o))))))))
     (append (map fail-test '(fail:unhandled-ubf-a-opcode
			      fail:orphan-tag-outside-struct
			      fail:orphan-tag-inside-struct
			      fail:orphan-binary-data
			      fail:non-integer-binary-data-length
			      fail:binary-missing-data
			      fail:binary-extra-data
			      fail:empty-stack-at-eom
			      fail:extra-close-struct
			      fail:non-empty-stack-at-eom))
	     (list
	      (test-case "Bind to reserved char"
			 (for-each (lambda (c)
				     (check-exn not-break-exn?
						(lambda () (ubf->object
							    (list->string #\> c c #\$)))))
				   ubf-a-reserved-chars)))))))

(define all-ubf-tests
  (make-test-suite
   "All UBF tests"
   (list all-ubf-encoding-tests
	 all-ubf-decoding-tests
	 error-checking-tests)))

(define (run-ubf-tests)
  (test/text-ui all-ubf-tests))