(use tinyclos testeez lolevel srfi-14 srfi-18 srfi-25 srfi-69 data-structures posix srfi-4
     tcp regex)

; Supply the path and filename for a file to be used in the memory map test.
; The file will be opened for read and will not be corrupted.
(define MMAP_FILENAME "run.scm")

(testeez
 "tinyclos"
 (test/equal   "Primitive null"
	       (class-name (class-of '()))
	       "null")
 (test/equal   "Primitive exact"
	       (class-name (class-of 11))
	       "exact")
 (test/equal   "Primitive boolean"
	       (class-name (class-of #t))
	       "boolean")
 (test/equal   "Primitive char"
	       (class-name (class-of #\+))
	       "char")
 (test/equal   "Primitive eof"
	       (let ((c (with-input-from-string "" (lambda() (read-char)))))
		 (class-name (class-of c)))
	       "end-of-file")
 (test/equal   "Primitive void"
	       (class-name (class-of (if #f '())))
	       "void")
 (test/equal   "Primitive inexact"
	       (class-name (class-of 11.0))
	       "inexact")
 (test/equal   "Primitive symbol"
	       (class-name (class-of 'abc))
	       "symbol")
 (test/equal   "Primitive vector"
	       (class-name (class-of '#(1 2 3)))
	       "vector")
 (test/equal   "Primitive pair"
	       (class-name (class-of '(a . b)))
	       "pair")
 (test/equal   "Primitive string"
	       (class-name (class-of "only this"))
	       "string")
 (test/equal   "Primitive procedure"
	       (class-name (class-of (lambda() #t)))
	       "procedure")
 (test/equal   "Primitive input port"
	       (class-name (class-of (current-input-port)))
	       "input-port")
 (test/equal   "Primitive output port"
	       (class-name (class-of (current-output-port)))
	       "output-port")
 (test/equal   "Primitive blob"
	       (class-name (class-of (make-blob 10)))
	       "blob")
 (test/equal   "Primitive locative"
	       (class-name (class-of (make-locative "xyz")))
	       "locative")
 (test/equal   "Primitive environment"
	       (class-name (class-of (scheme-report-environment 5)))
	       "environment")
 (test/equal   "Primitive array"
	       (class-name (class-of (make-array (shape 0 10 0 5))))
	       "array")
 (test/equal   "Primitive hash-table"
	       (class-name (class-of (make-hash-table)))
	       "hash-table")
 (test/equal   "Primitive queue"
	       (class-name (class-of (make-queue)))
	       "queue")
 (test/equal   "Primitive condition"
	       (let ((cn
		     (condition-case (/ 1 0)
				     (v () v))))
		 (class-name (class-of cn)))
	       "condition")
 (test/equal   "Primitive condition-variable"
	       (class-name (class-of (make-condition-variable)))
	       "condition-variable")
 (test/equal   "Primitive char-set"
	       (class-name (class-of (make-char-set "a")))
	       "char-set")
 (test/equal   "Primitive time"
	       (class-name (class-of (current-time)))
	       "time")
 (test/equal   "Primitive lock"
	       (let* ((lock (file-lock (current-output-port)))
		      (name (class-name (class-of lock))))
		 (file-unlock lock)
		 name)
	       "lock")
 (test/equal   "Primitive mmap"
	       (let* ((fileno (file-open MMAP_FILENAME open/rdonly))
		      (memory-map (map-file-to-memory #f 20 prot/read map/fixed fileno)))
		 (class-name (class-of memory-map)))
	       "mmap")
 (test/equal   "Primitive promise"
	       (class-name (class-of (delay (+ 1 2))))
	       "promise")
 (test/equal   "Primitive u8vector"
	       (class-name (class-of (make-u8vector 10)))
	       "u8vector")
 (test/equal   "Primitive s8vector"
	       (class-name (class-of (make-s8vector 10)))
	       "s8vector")
 (test/equal   "Primitive u16vector"
	       (class-name (class-of (make-u16vector 10)))
	       "u16vector")
 (test/equal   "Primitive s16vector"
	       (class-name (class-of (make-s16vector 10)))
	       "s16vector")
 (test/equal   "Primitive u32vector"
	       (class-name (class-of (make-u32vector 10)))
	       "u32vector")
 (test/equal   "Primitive f32vector"
	       (class-name (class-of (make-f32vector 10)))
	       "f32vector")
 (test/equal   "Primitive f64vector"
	       (class-name (class-of (make-f64vector 10)))
	       "f64vector")
 (test/equal   "Primitive tcp-listener"
	       (let* ((listener (tcp-listen 12345))
		      (name (class-name (class-of listener))))
		 (tcp-close listener)
		 name)
	       "tcp-listener")
 (test/equal   "Primitive mutex"
               (class-name (class-of (make-mutex)))
               "mutex")
 (test/equal   "Primitive continuation"
               (class-name (class-of (continuation-capture (lambda (x) x))))
               "continuation")
 (test/equal   "Primitive read-table"
               (class-name (class-of (current-read-table)))
               "read-table")
 (test/equal   "Primitive regexp"
               (class-name (class-of (regexp "a")))
               "regexp")
 (test/equal   "Simple class creation"
	       (let* ((<c1> (make-class (list <object>) '())))
		 (class-direct-supers (class-of (make <c1>))))
	       (list <object>))
 (test/equal   "Class slots"
	       (let* ((<c2> (make-class (list <object>) '(a b)))
		      (object (make <c2>)))
		 (slot-set! object 'a 12345)
		 (slot-set! object 'b (/ 12345 5))
		 (/ (slot-ref object 'a) (slot-ref object 'b)))
	       5)
 (test/equal   "Instance-of?"
	       (let* ((<pos> (define-class* () (x y)))
		      (<circle> (define-class* (<pos>) (radius)))
		      (p (make <pos>))
		      (c (make <circle>))
		      (g (make-generic))
		      (profile (lambda (x)
				 (list (instance-of? x <pos>)
				       (instance-of? x <circle>)
				       (instance-of? x <object>)
				       (instance-of? x <class>)
				       (instance-of? x <primitive-class>)
				       (instance-of? x <generic>)
				       (instance-of? x <primitive>)))))
		 (list (profile p) (profile c) (profile g) (profile 12)))
	       '((#t #f #t #f #f #f #f)
		 (#t #t #t #f #f #f #f)
		 (#f #f #t #f #f #t #f)
		 (#f #f #f #f #f #f #t)))
 (test/equal   "subclass?"
	       (let* ((<pos> (define-class* () (x y)))
		      (<circle> (define-class* (<pos>) (radius)))
		      (profile (lambda (x)
				 (list (subclass? x <pos>)
				       (subclass? x <circle>)
				       (subclass? x <object>)
				       (subclass? x <class>)
				       (subclass? x <primitive-class>)
				       (subclass? x <generic>)
				       (subclass? x <primitive>)))))
		 (list (profile <pos>)
		       (profile <circle>)
		       (profile <primitive-class>)
		       (profile <primitive>)))
	       '((#t #f #t #f #f #f #f)
		 (#t #t #t #f #f #f #f)
		 (#f #f #t #t #t #f #f)
		 (#f #f #f #f #f #f #t)))
 (test/equal   "Generic with no methods"
	       (let ((gen (make-generic)))
		 (condition-case (gen)
				 (v () ((condition-property-accessor 'exn 'message) v))))
	       "has no methods")
 (test/equal   "Generic method called with inappropriate argument"
	       (let* ((gen (make-generic))
		      (ignore (define-method (gen (x <inexact>))
				(* x 3))))
		 (condition-case (gen 1)
				 (v () ((condition-property-accessor 'exn 'message) v))))
	       "call-next-method: no methods left")
 (test/equal   "Generic method called with appropriate argument"
	       (let* ((gen (make-generic))
		      (ignore (define-method (gen (x <inexact>))
				(* x 3))))
		 (condition-case (gen 1.0)
				 (v () ((condition-property-accessor 'exn 'message) v))))
	       3.0)
 (test/equal   "Distance: generic method"
	       (let* ((<pos> (define-class* () (x y)))
		      (ignore1 (define-method (initialize (pos <pos>) initargs)
				 (call-next-method)
				 (initialize-slots pos initargs)))
		      (p1 (make <pos> 'x 10 'y 18))
		      (p2 (make <pos> 'x 1 'y 30))
		      (distance (make-generic))
		      (ignore2 (define-method (distance (pos1 <pos>) (pos2 <pos>))
				 (let ((xdiff (- (slot-ref pos1 'x)
						 (slot-ref pos2 'x)))
				       (ydiff (- (slot-ref pos1 'y)
						 (slot-ref pos2 'y))))
				   (sqrt (+ (* xdiff xdiff) (* ydiff ydiff)))))))
		 (distance p1 p2))
	       15.0)
 (test/equal   "Move and resize: generic methods and polymorphism"
	       (let* ((<pos> (define-class* () (x y)))
		      (<circle> (define-class* (<pos>) (radius)))
		      (ignore1 (define-method (initialize (pos <pos>) initargs)
				 (call-next-method)
				 (initialize-slots pos initargs)))
		      (p1 (make <pos> 'x 10 'y 18))
		      (c1 (make <circle> 'x 1 'y 30))
		      (position (make-generic))
		      (size (make-generic))
		      (move (make-generic))
		      (resize (make-generic))
		      (ignore2 (define-method (position (pos <pos>))
				 (cons (slot-ref pos 'x) (slot-ref pos 'y))))
		      (ignore3 (define-method (size (circle <circle>))
				 (slot-ref circle 'radius)))
		      (ignore4 (define-method (resize (circle <circle>) r)
				 (slot-set! circle 'radius r)))
		      (ignore5 (define-method (move (pos1 <pos>) (pos2 <pos>))
				 (slot-set! pos1 'x (slot-ref pos2 'x))
				 (slot-set! pos1 'y (slot-ref pos2 'y))))
		      (c (make <circle> 'x 0 'y 0 'radius 10))
		      (p (make <pos> 'x 10 'y 11)))
		 (list
		  (with-output-to-string (lambda() (describe-object c)))
		  (begin
		    (move c p)
		    (with-output-to-string (lambda() (describe-object c))))
		  (begin
		    (resize c 8)
		    (with-output-to-string (lambda() (describe-object c))))))
	       '("instance of class (anonymous):\n radius\t-> 10\n x\t-> 0\n y\t-> 0\n"
		 "instance of class (anonymous):\n radius\t-> 10\n x\t-> 10\n y\t-> 11\n"
		 "instance of class (anonymous):\n radius\t-> 8\n x\t-> 10\n y\t-> 11\n"))
  (test/equal "make/copy test"
 	      (let* ((<person> (define-class* () (name age)))
		     (<customer> (define-class* (<person>)
				   (last-contact-date purchases customer-number)))
		     (ignore (define-method (initialize (p <person>) initargs )
			       (initialize-slots p initargs)))
		     (customer-number (lambda (c) (slot-ref c 'customer-number)))
		     (name (lambda (c) (slot-ref c 'name)))
		     (purchases (lambda (c) (slot-ref c 'purchases)))
		     (p1 (make <customer> 'name "John" 'purchases 12.80 'customer-number 11))
		     (p2 (make/copy p1 'name "Peter" 'customer-number 12)))
		(list (cons (customer-number p1)(customer-number p2))
		      (cons (name p1)(name p2))
		      (cons (purchases p1)(purchases p2))))
	      '((11 . 12)("John" . "Peter")(12.8 . 12.8)))
)