(module app racket/base
  (require racket/class
           (prefix-in wx: "kernel.rkt")
           "lock.rkt"
           "helper.rkt"
           "wx.rkt"
           "wxtop.rkt")

  (provide application-preferences-handler
           application-about-handler
           application-quit-handler
           application-file-handler
           application-start-empty-handler
           current-eventspace-has-standard-menus?
           current-eventspace-has-menu-root?
           eventspace-handler-thread)

  ;; An app-handler record keeps a wrapped procedure with
  ;; its original wrappee.
  (define-values (struct:app-handler
		  make-app-handler
		  app-handler?
		  app-handler-ref
		  app-handler-set!)
    (make-struct-type 'app-handler
		      #f 2 0
		      #f null (current-inspector)
		      0))
  (define (app-handler-orig ah)
    (app-handler-ref ah 1))

  (let* ([running-quit? #f]
	 [f (entry-point
	     (lambda ()
	       (unless running-quit?
		 (let ([af (weak-box-value active-main-frame)])
		   (when af
		     (set! running-quit? #t)
		     (queue-window-callback
		      af
		      (entry-point
		       (lambda ()
			 (dynamic-wind
			     void
			     (lambda ()
                               (as-exit (lambda ()
                                          (send af on-exit)))
			       (unless (null? (wx:get-top-level-windows))
				 (wx:cancel-quit)))
			     (lambda () 
			       (set! running-quit? #f)))))))))))])
    (wx:application-quit-handler (make-app-handler f f)))

  (define (set-handler! who proc param arity result-filter post-set)
    (when proc
      (unless (and (procedure? proc)
		   (procedure-arity-includes? proc arity))
	(raise-argument-error who
                              (format "(or/c (procedure-arity-includes/c ~a) #f)" arity)
                              proc)))
    (let ([e (wx:current-eventspace)])
      (when (wx:main-eventspace? e)
        (param (make-app-handler
		(lambda args
		  (parameterize ([wx:current-eventspace e])
		    (wx:queue-callback
		     (lambda () (result-filter (apply proc args)))
		     wx:middle-queue-key)))
		proc))
        (post-set))))

  (define application-preferences-handler
    (case-lambda
     [() (and (wx:main-eventspace? (wx:current-eventspace))
	      (app-handler-orig (wx:application-pref-handler)))]
     [(proc)
      (set-handler! 'application-preferences-handler proc
		    wx:application-pref-handler
		    0
		    values
                    void)]))

  (define application-about-handler
    (case-lambda
     [() (or (and (wx:main-eventspace? (wx:current-eventspace))
		  (app-handler-orig (wx:application-about-handler)))
	     void)]
     [(proc)
      (set-handler! 'application-about-handler proc
		    wx:application-about-handler
		    0
		    values
                    void)]))

  (define application-quit-handler
    (case-lambda
     [() (or (and (wx:main-eventspace? (wx:current-eventspace))
		  (app-handler-orig (wx:application-quit-handler)))
	     void)]
     [(proc)
      (set-handler! 'application-quit-handler proc
		    wx:application-quit-handler
		    0
		    (lambda (v) (unless v (wx:cancel-quit)) v)
                    void)]))

  (define saved-files null)

  (define default-application-file-handler
    (entry-point
     (lambda (f)
       (let ([af (weak-box-value active-main-frame)])
	 (if af
             (queue-window-callback
              af
              (entry-point
               (lambda () (if (send af accept-drag?)
                              (send af on-drop-file f)
                              (set! saved-files (cons f saved-files))))))
             (begin
               (add-active-frame-callback! requeue-saved-files)
               (set! saved-files (cons f saved-files))))))))

  (define (requeue-saved-files)
    (as-entry
     (lambda ()
       (for-each (lambda (f)
                   (wx:queue-callback (lambda ()
                                        ((wx:application-file-handler) f))
                                      wx:middle-queue-key))
                 (reverse saved-files))
       (set! saved-files null))))

  (define (install-defh)
    (wx:application-file-handler (make-app-handler
				  default-application-file-handler
				  default-application-file-handler)))
  (install-defh)

  (define application-file-handler
    (case-lambda
     [() (or (and (wx:main-eventspace? (wx:current-eventspace))
		  (app-handler-orig (wx:application-file-handler)))
	     void)]
     [(proc)
      ;; Special case for default-application-file-handler,
      ;; because it need not be constrained to the main eventspace:
      (if (eq? proc default-application-file-handler)
	  (install-defh)
	  (set-handler! 'application-file-handler proc
			wx:application-file-handler
			1
			values
                        requeue-saved-files))]))

  (define application-start-empty-handler
    (case-lambda
     [() (or (and (wx:main-eventspace? (wx:current-eventspace))
		  (app-handler-orig (wx:application-start-empty-handler)))
	     void)]
     [(proc)
      (set-handler! 'application-start-empty-handler proc
		    wx:application-start-empty-handler
		    0
		    values
                    void)]))

  (define (current-eventspace-has-standard-menus?)
    (and (eq? 'macosx (system-type))
	 (wx:main-eventspace? (wx:current-eventspace))))

  (define (current-eventspace-has-menu-root?)
    (and (memq (system-type) '(macos macosx))
	 (wx:main-eventspace? (wx:current-eventspace))))

  (define (eventspace-handler-thread e)
    (let ([t (wx:eventspace-handler-thread e)])
      (or t
	  ;; eventspace dead, or just no thread, yet?
	  (with-handlers ([exn:fail?
			   (lambda (x)
			     (if (wx:eventspace-shutdown? e)
				 (raise-arguments-error
				  'eventspace-handler-thread
				  "eventspace is shutdown"
                                  "eventspace"
				  e)
				 (raise x)))])
	    (let ([done (make-semaphore)]
		  [t #f])
	      (parameterize ([wx:current-eventspace e])
		(wx:queue-callback
		 (lambda () 
		   (set! t (current-thread))
		   (semaphore-post done))
		 #t)
		(if (sync/timeout 1.0 done)
		    t
  Weird - no response after 1 second .   Maybe
		    ;; someone killed the handler thread before it could
		    ;; do our work? Or shutdown the eventspace? Or the
		    ;; thread is busy? In any of those cases, we'll
		    ;; succeed on the next iteration.
		    (eventspace-handler-thread e)))))))))


 An app-handler record keeps a wrapped procedure with
 its original wrappee.
 Special case for default-application-file-handler,
 because it need not be constrained to the main eventspace:
 eventspace dead, or just no thread, yet?
 someone killed the handler thread before it could
 do our work? Or shutdown the eventspace? Or the
 thread is busy? In any of those cases, we'll
 succeed on the next iteration.
(module app racket/base
  (require racket/class
           (prefix-in wx: "kernel.rkt")
           "lock.rkt"
           "helper.rkt"
           "wx.rkt"
           "wxtop.rkt")

  (provide application-preferences-handler
           application-about-handler
           application-quit-handler
           application-file-handler
           application-start-empty-handler
           current-eventspace-has-standard-menus?
           current-eventspace-has-menu-root?
           eventspace-handler-thread)

  (define-values (struct:app-handler
		  make-app-handler
		  app-handler?
		  app-handler-ref
		  app-handler-set!)
    (make-struct-type 'app-handler
		      #f 2 0
		      #f null (current-inspector)
		      0))
  (define (app-handler-orig ah)
    (app-handler-ref ah 1))

  (let* ([running-quit? #f]
	 [f (entry-point
	     (lambda ()
	       (unless running-quit?
		 (let ([af (weak-box-value active-main-frame)])
		   (when af
		     (set! running-quit? #t)
		     (queue-window-callback
		      af
		      (entry-point
		       (lambda ()
			 (dynamic-wind
			     void
			     (lambda ()
                               (as-exit (lambda ()
                                          (send af on-exit)))
			       (unless (null? (wx:get-top-level-windows))
				 (wx:cancel-quit)))
			     (lambda () 
			       (set! running-quit? #f)))))))))))])
    (wx:application-quit-handler (make-app-handler f f)))

  (define (set-handler! who proc param arity result-filter post-set)
    (when proc
      (unless (and (procedure? proc)
		   (procedure-arity-includes? proc arity))
	(raise-argument-error who
                              (format "(or/c (procedure-arity-includes/c ~a) #f)" arity)
                              proc)))
    (let ([e (wx:current-eventspace)])
      (when (wx:main-eventspace? e)
        (param (make-app-handler
		(lambda args
		  (parameterize ([wx:current-eventspace e])
		    (wx:queue-callback
		     (lambda () (result-filter (apply proc args)))
		     wx:middle-queue-key)))
		proc))
        (post-set))))

  (define application-preferences-handler
    (case-lambda
     [() (and (wx:main-eventspace? (wx:current-eventspace))
	      (app-handler-orig (wx:application-pref-handler)))]
     [(proc)
      (set-handler! 'application-preferences-handler proc
		    wx:application-pref-handler
		    0
		    values
                    void)]))

  (define application-about-handler
    (case-lambda
     [() (or (and (wx:main-eventspace? (wx:current-eventspace))
		  (app-handler-orig (wx:application-about-handler)))
	     void)]
     [(proc)
      (set-handler! 'application-about-handler proc
		    wx:application-about-handler
		    0
		    values
                    void)]))

  (define application-quit-handler
    (case-lambda
     [() (or (and (wx:main-eventspace? (wx:current-eventspace))
		  (app-handler-orig (wx:application-quit-handler)))
	     void)]
     [(proc)
      (set-handler! 'application-quit-handler proc
		    wx:application-quit-handler
		    0
		    (lambda (v) (unless v (wx:cancel-quit)) v)
                    void)]))

  (define saved-files null)

  (define default-application-file-handler
    (entry-point
     (lambda (f)
       (let ([af (weak-box-value active-main-frame)])
	 (if af
             (queue-window-callback
              af
              (entry-point
               (lambda () (if (send af accept-drag?)
                              (send af on-drop-file f)
                              (set! saved-files (cons f saved-files))))))
             (begin
               (add-active-frame-callback! requeue-saved-files)
               (set! saved-files (cons f saved-files))))))))

  (define (requeue-saved-files)
    (as-entry
     (lambda ()
       (for-each (lambda (f)
                   (wx:queue-callback (lambda ()
                                        ((wx:application-file-handler) f))
                                      wx:middle-queue-key))
                 (reverse saved-files))
       (set! saved-files null))))

  (define (install-defh)
    (wx:application-file-handler (make-app-handler
				  default-application-file-handler
				  default-application-file-handler)))
  (install-defh)

  (define application-file-handler
    (case-lambda
     [() (or (and (wx:main-eventspace? (wx:current-eventspace))
		  (app-handler-orig (wx:application-file-handler)))
	     void)]
     [(proc)
      (if (eq? proc default-application-file-handler)
	  (install-defh)
	  (set-handler! 'application-file-handler proc
			wx:application-file-handler
			1
			values
                        requeue-saved-files))]))

  (define application-start-empty-handler
    (case-lambda
     [() (or (and (wx:main-eventspace? (wx:current-eventspace))
		  (app-handler-orig (wx:application-start-empty-handler)))
	     void)]
     [(proc)
      (set-handler! 'application-start-empty-handler proc
		    wx:application-start-empty-handler
		    0
		    values
                    void)]))

  (define (current-eventspace-has-standard-menus?)
    (and (eq? 'macosx (system-type))
	 (wx:main-eventspace? (wx:current-eventspace))))

  (define (current-eventspace-has-menu-root?)
    (and (memq (system-type) '(macos macosx))
	 (wx:main-eventspace? (wx:current-eventspace))))

  (define (eventspace-handler-thread e)
    (let ([t (wx:eventspace-handler-thread e)])
      (or t
	  (with-handlers ([exn:fail?
			   (lambda (x)
			     (if (wx:eventspace-shutdown? e)
				 (raise-arguments-error
				  'eventspace-handler-thread
				  "eventspace is shutdown"
                                  "eventspace"
				  e)
				 (raise x)))])
	    (let ([done (make-semaphore)]
		  [t #f])
	      (parameterize ([wx:current-eventspace e])
		(wx:queue-callback
		 (lambda () 
		   (set! t (current-thread))
		   (semaphore-post done))
		 #t)
		(if (sync/timeout 1.0 done)
		    t
  Weird - no response after 1 second .   Maybe
		    (eventspace-handler-thread e)))))))))

