(in-package :qt.tests)

(5am:in-suite :qt.suite)

(defmacro with-invoke-restart ((condition restart &optional handler) &body body)
  "Invokes RESTART when CONDITION is signaled in BODY."
  (alexandria:with-gensyms (c)
    `(handler-bind ((,condition #'(lambda (,c)
                                    (declare (ignore ,c))
                                    (assert (find-restart ',restart))
                                    ,(when handler `(funcall ,handler))
                                    (invoke-restart ',restart))))
       ,@body)))

(define-condition no-ticket (error) ())

(defun call-slot (slot &rest arguments)
  (let ((sig (qt:make-signal)))
    (qt:connect sig slot qt:+queued-connection+)
    (apply sig arguments)))

(5am:test abort-with-app
  "Test aborting the event loop."
  (dotimes (i 3)
    (bt:with-timeout (5)
      (with-invoke-restart (no-ticket qt::abort-app)
        (qt:with-app ()
            (let ((timer (make-instance 'qt:timer))
                  (continued-p))
              (cxx:set-single-shot timer t)
              (qt:connect (qt:get-signal timer "timeout()")
                          #'(lambda ()
                              (cerror "ignore" (make-condition 'no-ticket))
                              (setf continued-p t)))
              (cxx:start timer 0)
              (qt:exec)
              (5am:is (eq continued-p t))))))))

(defclass error-object (qt:object)
  ()
  (:metaclass cxx:class))

(defmethod cxx:timer-event ((object error-object) timer-event)
  (cxx:kill-timer object (cxx:timer-id timer-event))
  (error (make-condition 'no-ticket)))

(5am:test error-in-callback-return
  "Test returning from a void method on error."
  (qt:with-core-app ()
    (let ((object (make-instance 'error-object))
          (restarted-p))
      (with-invoke-restart (no-ticket smoke::return 
                                      #'(lambda () (setf restarted-p t)))
        (cxx:start-timer object 0)
        (qt:core-application.process-events))
      (5am:is (eq t restarted-p)))))

(5am:test error-in-callback-default
  "Test calling the default C++ method on error in the user defined method."
  (qt:with-core-app ()
    (let ((object (make-instance 'error-object))
          (restarted-p))
      (with-invoke-restart (no-ticket smoke::call-default
                                      #'(lambda () (setf restarted-p t)))
        (cxx:start-timer object 0)
        (qt:core-application.process-events))
      (5am:is (eq t restarted-p)))))

 (5am:test error-in-slot
   "Test skipping a slot function when it signals an error."
   (qt:with-core-app ()
       (let ((timer (make-instance 'qt:timer))
             (continued-p))
       (with-invoke-restart (no-ticket continue
                                       #'(lambda () (setf continued-p t)))
         (cxx:set-single-shot timer t)
         (qt:connect (qt:get-signal timer "timeout()")
                     #'(lambda () 
                         (error (make-condition 'no-ticket))))
         (cxx:start timer 0)
         (qt:core-application.process-events))
     (5am:is (eq t continued-p)))))


(5am:test msg-handler
  "Test catching Q_ASSERTS."
  (5am:signals error
    (qt:qt-assert ":qt.tests msg-handler test assert"
                  "abort.lisp"
                  -1)))