(in-package :cl-smoke.qt.core)

(defvar *app*)
(defvar qt:*exec-p* t
  "Run exec if true and not otherwise.")

(defun qt:app ()
  "Returns the APPLICATION (or CORE-APPLICATION) object,
within a WITH-APP."
  (assert (qt:app-p)
          (*app*)
          "No application.")
  *app*)

(defun qt:app-p ()
  "Returns t when the APPLICATION object exists and nil otherwise."
  (boundp '*app*))

(defun ensure-app (&optional 
                   (application 'qt:core-application)
                   (args #+sbcl sb-ext:*posix-argv*
                         #+ccl  ccl:*command-line-argument-list*
                         #-(or sbcl ccl) (list (lisp-implementation-type))))
  "Constructs the global application object, when there is none,
with the command line arguments ARGS.

Returns the application object a first value and
true when a new application was created and false otherwise."
  (assert (not (null args))
          (args)
          "No program name supplied.")
  (if (qt:app-p)
      (progn
        (assert (typep (qt:app) (find-class application))
                (application)
                "The existing application object ~A is
not of type ~A." (qt:app) (find-class application))
        (values (qt:app) nil))
      (progn
        (when (not (null-pointer-p (smoke::pointer
                                    (qt:core-application.instance))))
          (cerror (format nil "Delete the active application ~A."
                          (qt:core-application.instance))
                  "Active application not created by QT:WITH-APP.")
          (smoke::delete-pointer (smoke::pointer (qt:core-application.instance))
                                 (find-class 'qt:core-application)))
        (let* ((argc (smoke:make-auto-pointer
                      (foreign-alloc :int :initial-element (length args))))
               (argv (smoke:make-auto-pointer
                      (foreign-alloc :string :initial-contents args)))
               (app (make-instance application :args (list argc argv))))
          ;; argc and argv must remain valid during the lifetime of APP.
          (setf (qt:property app 'cmdline-args) 
                (qt:make-lisp-variant (list argc argv)))
          (tg:cancel-finalization app)
          (values app t)))))

(defgeneric delete-app (application)
  (:method (application)
    (unless (null-pointer-p (smoke:pointer application))
      (cxx:quit application)
      ;; Call the destructor; -> destructed callback is called,
      ;; (~QApplication() is virtual) which takes care of cleanup on the
      ;; Lisp side.
      (smoke::delete-pointer (smoke:pointer application) (class-of application)))
    (makunbound '*app*)))

(defun kill-app ()
  (delete-app (qt:app)))

(defmacro with-application ((ensure-app remove-app) &body body)
  (let ((cleanup-p (gensym)))
    `(multiple-value-bind (*app* ,cleanup-p) ,ensure-app
       (unwind-protect
            (progn ,@body)
         (when ,cleanup-p
           ,remove-app)))))

(defmacro qt:with-core-app (options &body body)
  (assert (null options)
          (options)
          "Currently no options can be passed to QT:WITH-CORE-APP.")
  `(with-application ((cl-smoke.qt.core::ensure-app 'qt:core-application) (kill-app))
     ,@body))
  
(defun qt:exec ()
  "Executes APP. When QT:*EXEC-P* is false it returns immediately
and transfers the ownership of the top-level widgets to the qt:application
instance."
  (when qt:*exec-p*
    (restart-bind ((qt::abort-app #'(lambda ()
                                      (cxx:quit (qt:app))
                                      (invoke-restart (find-restart 'continue)))
                     :report-function
                     #'(lambda (stream)
                         (format stream "Return from the application event loop."))
                     :test-function
                     #'(lambda (condition)
                         (declare (ignore condition))
                         (and (qt:app-p)
                              (find-restart 'continue)))))
      (let ((qt:*exec-p* nil))
        (cxx:exec (qt:app))))))