(in-package :climi)

(defun find-process-with-name (name)
  (apply #'values
         (remove-if-not (lambda (process)
                          (string= name (process-name process)))
                        (all-processes))))

(defun destroy-process-with-name (name)
  (mapcar #'destroy-process
          (multiple-value-list (find-process-with-name name))))

(defgeneric launch-application (application-frame-name &rest rest &key &allow-other-keys))

(defmethod launch-application (application-frame-name &rest rest
                                                      &key new-process
                                                           (process-name (format nil "~:(~a~)" application-frame-name))
                                                           width
                                                           height
                                                           frame-manager-name ;; in order to test the 'clim-internals::pixie/clx-look
                                                           force-restart
                                                           (debugger #'clim-debugger:debugger)
                                                           complain-about-existing-process
                                                           arguments-for-application-frame-creation
                                                      &allow-other-keys)
  (declare (ignorable rest))

  ;; complain about existing process
  (when (climi::find-process-with-name process-name)
    (if force-restart
        (climi::destroy-process-with-name process-name)
        (when complain-about-existing-process
          (restart-case (error "There seems to be a running instance of the ~a process."
                               process-name)
            (|destroy-process| nil
              :report "Destroy the old process and make a new one."
              (climi::destroy-process-with-name process-name))
            (|don't-care| nil
              :report "Just run the gui again and don't care about the running process." nil)
            (|do-nothing| nil
              :report "Just return without doing anything more."
              (return-from launch-application))))))

  ;; care for frame-manager
  (if frame-manager-name
      (setf arguments-for-application-frame-creation
            (append arguments-for-application-frame-creation
                    (list :frame-manager (make-instance frame-manager-name
                                                        :port (find-port))))))

  ;; the gist of the matter
  (let ((frame (apply #'make-application-frame application-frame-name
                                               :width width
                                               :height height
                                               arguments-for-application-frame-creation))
        (*debugger-hook* debugger))
    (flet ((run ()
             (run-frame-top-level frame)))
      (if new-process
          (clim-sys:make-process (lambda ()
                                   (run)
                                   (climi::destroy-process-with-name process-name))
                                 :name process-name)
          (run)))
    frame))

(defmacro define-application-starter (application-frame-name &key
                                      (function-name (intern "RUN-GUI" *package*))
                                      default-width
                                      default-height
                                      (default-process-name (format nil "~:(~s~)" application-frame-name))
                                      (default-debugger '#'clim-debugger:debugger)
                                      complain-about-existing-process
                                      (announce-to-clim-launcher t))
  (flet ((make-setf-getf-line (thing plist)
           `(setf (getf ,plist ,(intern (string thing) :keyword)) ,thing)))
  `(multiple-value-prog1

    ;; create the starter function
    (defun ,function-name (&rest rest
                           &key new-process
                           (process-name ,default-process-name)
                           (width ,default-width)
                           (height ,default-height)
                           frame-manager-name ;; in order to test the 'clim-internals::pixie/clx-look
                           force-restart
                           (debugger ,default-debugger)
                           (complain-about-existing-process ,complain-about-existing-process)
                           &allow-other-keys)
      ;; enforce the defaults in REST
      ,@(loop for thing in '(new-process process-name width height frame-manager-name force-restart debugger complain-about-existing-process)
          :collect (make-setf-getf-line thing 'rest))
      (apply #'launch-application ',application-frame-name rest))

     ;; announce the application
     (when (and ,announce-to-clim-launcher
                (find-package :clim-launcher)
                (fboundp (intern "ADD-APPLICATION" :clim-launcher)))
       (funcall (intern "ADD-APPLICATION" :clim-launcher)
                ,default-process-name
                (lambda ()
                  (funcall #',function-name :new-process t)))))))


;;; Clouseau example

(in-package :clouseau)

(climi::define-application-starter inspector
                                   :function-name inspector)

;;; or just use this instead:
;;;   (climi::launch-application 'clouseau:inspector :new-process t :object 'dudel)

(in-package :climi)

(defmethod launch-application :around ((application-frame-name (eql 'clouseau::inspector))
                                       &rest rest
                                       &key arguments-for-application-frame-creation
                                       &allow-other-keys)
  "This method will put the :OBJECT argument into :ARGUMENTS-FOR-APPLICATION-FRAME-CREATION"
  (let ((object (getf rest :object)))
    (when object
      (setf (getf arguments-for-application-frame-creation :obj)
            object
            ;; ensure that its in the list
            (getf rest :arguments-for-application-frame-creation)
            arguments-for-application-frame-creation)))
  ;; call the real thing
  (apply #'call-next-method application-frame-name rest))