(use testeez)
(use tinyclos detail-object)
(use 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 "tests/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 fixnum"
                (class-name (class-of 11))
                "fixnum")

  (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 integer"
                (class-name (class-of 11.0))
                "integer")

  (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 input port"
                (class-name (class-of (current-input-port)))
                "stream-port")

  (test/equal   "Primitive output port"
                (class-name (class-of (current-output-port)))
                "output-port")

  #;
  (test/equal   "Primitive output port"
                (class-name (class-of (current-output-port)))
                "stream-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))
                       (name (class-name (class-of memory-map))))
                  (file-close fileno)
                  name)
                "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))))
                "generic: 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   "Generic method called with appropriate argument"
                (let* ((gen (make-generic))
                       (ignore (define-method (gen (x <integer>))
                                 (* 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() (detail-object c)))
                   (begin
                     (move c p)
                     (with-output-to-string (lambda() (detail-object c))))
                   (begin
                     (resize c 8)
                     (with-output-to-string (lambda() (detail-object c))))))
                '("#,(instance \"(anonymous)\" ((radius . 10) (x . 0) (y . 0)))"
                  "#,(instance \"(anonymous)\" ((radius . 10) (x . 10) (y . 11)))"
                  "#,(instance \"(anonymous)\" ((radius . 8) (x . 10) (y . 11)))"))

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

  (test/equal "dotted argument in method (1)"
              (let* ((<pos> (define-class* () (x y)))
                     (gen (make-generic))
                     (p (make <pos>)))
                (define-method (gen (p <pos>) . args) args)
                (gen p "a"))
              '("a"))

  (test/equal "dotted argument in method (2)"
              (let* ((<pos> (define-class* () (x y)))
                     (gen (make-generic))
                     (ignore (define-method (gen (p <pos>) . args) args))
                     (p (make <pos>)))
                (gen p))
              '())

  (test/equal "dotted argument in method (3)"
              (let* ((<pos> (define-class* () (x y)))
                     (gen (make-generic))
                     (p (make <pos>)))
                (define-method (gen (p <pos>) a . args) args)
                (gen p 'a 'b))
              '(b))

  (test/equal "dotted argument in method competing with non-dotted method (1)"
              (let* ((<pos> (define-class* () (x y)))
                     (gen (make-generic))
                     (p (make <pos>)))
                (define-method (gen (p <pos>) a)
                             "non-dotted")
                (define-method (gen (p <pos>) a . args)
                             "dotted")
                (gen p 'a))
              "dotted")

  (test/equal "dotted argument in method competing with non-dotted method (2)"
              (let* ((<pos> (define-class* () (x y)))
                     (gen (make-generic))
                     (p (make <pos>)))
                (define-method (gen (p <pos>) a . args)
                             "dotted")
                (define-method (gen (p <pos>) a)
                             "non-dotted")
                (gen p 'a))
              "non-dotted")

  (test/equal   "Michele Simionato's example 1 from C3 egg"
                (begin
                  (define O <object>)
                  (define-class F (O) ())
                  (define-class E (O) ())
                  (define-class D (O) ())
                  (define-class C (D F) ())
                  (define-class B (D E) ())
                  (define-class A (B C) ())
                  (class-cpl A))
                (list A B C D F E <object> <top>))

  (test/equal   "Michele Simionato's example 2 from C3 egg"
                (begin
                  (define O <object>)
                  (define-class F (O) ())
                  (define-class E (O) ())
                  (define-class D (O) ())
                  (define-class C (D F) ())
                  (define-class B (E D) ())
                  (define-class A (B C) ())
                  (class-cpl A))
                (list A B E C D F <object> <top>))

  (test/equal   "Pedroni's example from C3 egg"
                (begin
                  (define O <object>)
                  (define-class A(O) ())
                  (define-class B(O) ())
                  (define-class C(O) ())
                  (define-class D(O) ())
                  (define-class E(O) ())
                  (define-class K1(A B C) ())
                  (define-class K2(D B E) ())
                  (define-class K3(D A) ())
                  (define-class Z(K1 K2 K3) ())
                  (class-cpl Z))
                (list Z K1 K2 K3 D A B E C <object> <top>))

  (test/equal   "Structure class-of test"
                (begin
                  (define-record point x y)
                  (define-record circle x y r)
                  (delete-structure-class-of 'non-existent)
                  (let ((<point>
                         (make <primitive-class>
                               'direct-supers (list <primitive>)
                               'direct-slots '()
                               'name         'point))
                        (<circle>
                         (make <primitive-class>
                               'direct-supers (list <primitive>)
                               'direct-slots '()
                               'name         'circle))
                        (<duplicate-of-point>
                         (make <primitive-class>
                               'direct-supers (list <primitive>)
                               'direct-slots '()
                               'name         'dupe)) )
                    (add-structure-class-of 'point <point>)
                    (add-structure-class-of 'circle <circle>)
                    (add-structure-class-of 'point <duplicate-of-point>)
                    (let* ((cnm (lambda (x) (class-name (class-of x))))
                           (name1 (cnm (make-point 1 1)))
                           (name2 (cnm (make-circle 1 2 2))))
                      (delete-structure-class-of 'point)
		      (delete-structure-class-of 'random-symbol)
                      (let ((name3 (cnm (make-point 10 10)))
                            (name4 (cnm (make-circle 10 10 20))))
                        (delete-structure-class-of 'circle)
                        (let ((name5 (cnm (make-point 0 0)))
                              (name6 (cnm (make-circle 1 5 4))))
                          (delete-structure-class-of 'does-not-exist)
                          (list name1 name2 name3 name4 name5 name6) ) ) ) ) )
                '("dupe" "circle" "structure" "circle" "structure" "structure"))

  (test/equal   "Mutable class name - this is not good"
                (let ((<testprim>
                       (make <primitive-class>
                             'direct-supers (list <primitive>)
                             'direct-slots '()
                             'name         "test T")))
                  (let ((before (string-copy (class-name <testprim>))))
                    (string-set! (class-name <testprim>) 5 #\_)
                    (list before (class-name <testprim>)) ) )
                `("test T" "test _"))
)