(in-package :qt.tests)

(5am:in-suite :qt.suite)
;;; The GC stuff depends on (gc :full t) to collect the consed objects.
;;; Sometimes calling GC twice helps in SBCL.

(defun test-gc (class)
  "Returns true when some instances of class get garbage collected
and false otherwise.
It is not required that every instance is gc'ed, since this rarely happens
and is not a bug."
  (let ((objects nil))
    (dotimes (x 30)
      (let ((object (make-instance class)))
        (push (make-weak-pointer object)
              objects)))
    (dotimes (x 2)
      (gc :full t))
    (5am:is (eq t (some #'(lambda (o) (null (weak-pointer-value o)))
                        objects)))))

(defclass lisp-object ()
  ((a :initform (make-array '(1000 1000) :initial-element 3))
   (b :initform (list 1 2 43)))
  (:documentation "For the object to be (hopefully) garbage collected
we cons up some memory."))

(5am:test gc-lisp-object
  "Ensure that GC works for plain lisp objects."
  (test-gc 'lisp-object))

(5am:test (gc-object :depends-on gc-lisp-object)
  "Test garbage collection of a no QObject class."
  (test-gc 'qt:byte-array))

(5am:test (gc-qobject :depends-on gc-object)
  "Test garbage collection of a QObject."
  (test-gc 'qt:object))

(5am:test gc-multi-object
  "Test garbage collection of a custom object that has two C++ superclasses."
  (test-gc 'my-multi-object))

(defclass my-gc-object (qt:object)
  ()
  (:metaclass cxx:class))

;; FIXME 5am prevents garbage collection!?
;; use eval !?
(defun run-gc-child ()
  (let ((objects nil))
    (dotimes (x 10)
      (let ((object (make-instance 'qt:object)))
        (make-instance 'qt:object :args (list object))
        ;;(cxx:set-parent (make-instance 'qt:object) object)
        (push object objects)))
    (gc :full t)))

(defun run-gc-my-child ()
  (let ((objects nil))
    (dotimes (x 10)
      (let ((object (make-instance 'qt:object)))
        (make-instance 'my-gc-object :args (list object))
        (push object objects)))
    (gc :full t)))
  
  
(5am:test (gc-child :depends-on gc-qobject)
  "Test garbage collection of a qt:object with a parent."
  (gc :full t)
  (gc :full t)
  (qt:with-core-app ()
    (let ((count (hash-table-count smoke::*object-map*)))
      (eval '(run-gc-child))
      (eval '(gc :full t))
      (qt:core-application.send-posted-events)
      (gc :full t)
      (qt:core-application.send-posted-events)
      (gc :full t)
      (5am:is (>= count (hash-table-count smoke::*object-map*))))))

(5am:test (gc-lisp-child :depends-on (and gc-child with-app))
  "Test garbage collection of a qt:object with a parent."
  (gc :full t)
  (qt:with-core-app ()
    (let ((count (hash-table-count smoke::*object-map*)))
      (eval '(run-gc-my-child))
      ;; a.k.a :really-full ;)
      (gc :full t)
      (qt:core-application.send-posted-events)
      (eval '(gc :full t))
      (qt:core-application.send-posted-events)
      (eval '(gc :full t))
      (qt:core-application.send-posted-events)
      (gc :full t)
      (qt:core-application.send-posted-events)
      ;; allow some objects to be not collected
      (5am:is (>= (+ count 2) (hash-table-count smoke::*object-map*))))))

(defun test-gc-cycle ()
  (dotimes (i 10)
    (let ((timer (make-instance 'qt:timer)))
      (qt:connect (qt:get-signal timer "timeout()")
                  #'(lambda ()
                      (format *debug-io* "Timeout ~A" timer)))))
  (gc :full t)
  (qt:core-application.send-posted-events)
  (gc :full t)
  (qt:core-application.send-posted-events))

(5am:test (gc-cycle :depends-on gc-lisp-child)
  "Test GC a unreachable cycle."
  ;; timer -> qslot -> closure(lambda)
  ;;   ^------------------/
  (qt:with-core-app ()
    (let ((objects (hash-table-count smoke::*object-map*)))
      (eval '(test-gc-cycle))
      (eval '(gc :full t))
      (qt:core-application.send-posted-events)
      (eval '(gc :full t))
      (qt:core-application.send-posted-events)
      (gc :full t)
      (qt:core-application.send-posted-events)
      (gc :full t)
      (5am:is (>= (+ 2 objects) (hash-table-count smoke::*object-map*))))))

(5am:test (ownership-transfer-no-wrapper :depends-on gc-lisp-child)
  "Test ownership transfer of a QObject without a wrapper."
  (let ((grand-parent (make-instance 'qt:object)))
    (setf (cxx:object-name grand-parent) "grand parent")
    (let* ((parent (make-instance 'qt:object :args (list grand-parent)))
           (object (make-instance 'my-object :args (list parent))))
      (setf (cxx:object-name parent) "parent"
            (cxx:object-name object) "child"))
    (gc :full t)
    (qt:core-application.send-posted-events)
    (gc :full t)
    (qt:core-application.send-posted-events)
    (5am:is (member (find-class 'my-object)
                    (loop for c across (cxx:children grand-parent) append
                         (map 'list #'class-of
                              (cxx:children c)))))))
      
(5am:test (gc-non-smoke-object :depends-on gc-lisp-child)
  "Test adding a child to a non smoke object."
  (qt:with-app ()
    (let ((model (make-instance 'qt:string-list-model :arg0 #("a" "b" "c")))
          (view (make-instance 'qt:list-view))
          (counter 0))
      (setf (cxx:model view) model)
      (qt:connect (qt:get-signal (cxx:selection-model view)
                                 "selectionChanged(QItemSelection, QItemSelection)")
                  #'(lambda (selected deselected)
                      (declare (ignore selected deselected))
                      (incf counter)))
      (cxx:destroyed (cxx:selection-model view)
                    (cxx:selection-model view))
      (gc :full t)
      (qt:core-application.send-posted-events)
      (gc :full t)
      (qt:core-application.send-posted-events)
      (5am:is (= 0 counter))
      (cxx:select (cxx:selection-model view)
                  (cxx:index model 0)
                  qt:item-selection-model.+toggle+)
      (5am:is (= 1 counter))
      (cxx:select (cxx:selection-model view)
                  (cxx:index model 1)
                  qt:item-selection-model.+toggle+)
      (5am:is (= 2 counter)))))
          
#|
;; FIXME
(5am:test (gc-variant-cycle :depends-on gc-lisp-child lisp-variant)
  (let ((finalized-p))
  (let* ((list (list nil))
         (variant (qt:make-lisp-variant list)))
    (setf (first list)
          variant)
    (tg:finalize list #'(lambda () (setf finalized-p t)))
    (5am:is (eq nil finalized-p)))
  (gc :full t)
  (gc :full t)
  (5am:is (eq t finalized-p))))

|#