gui/gui-test/framework/tests/group-test.rkt

#lang racket/base
(require "private/here-util.rkt"
         "private/gui.rkt"
         rackunit
         racket/class
         racket/gui/base
         framework
         (only-in "../../../gui-lib/framework/private/group.rkt"
                  pay-attention-to-current-eventspace-has-standard-menus?))

(define windows-menu-prefix 
  (let ([basics (list "Bring Frame to Front…" "Most Recent Window"
                      #f)])
    (if (eq? (system-type) 'macosx)
        (list* "Minimize" "Zoom" basics)
        basics)))

(define pref-ht (make-hash))
(parameterize ([test:use-focus-table #t]
               [preferences:low-level-get-preference
                (λ (sym [fail (λ () #f)])
                  (hash-ref pref-ht sym fail))]
               [preferences:low-level-put-preferences
                (λ (syms vals)
                  (for ([sym (in-list syms)]
                        [val (in-list vals)])
                    (hash-set! pref-ht sym val)))]
               [pay-attention-to-current-eventspace-has-standard-menus? #f])

  (define-syntax car*
    (syntax-rules ()
      [(car* x-expr)
       (let ([x x-expr])
         (if (pair? x)
             (car x)
             (begin
               (eprintf "car* called with ~s\n" 'x-expr)
               (car x))))]))

  (define the-first-frame #f)

  (yield
   (thread
    (λ ()
      (queue-callback
       (λ ()
         (set! the-first-frame (make-object frame:basic% "first"))
         (send the-first-frame show #t)))
      (preferences:set 'framework:verify-exit #t)
      (wait-for-frame "first")
      (queue-callback
       (λ ()
         (send (test:get-active-top-level-window) close)))
      (wait-for-frame "Warning")
      (test:button-push "Cancel")
      (wait-for-frame "first"))))
  (check-equal? (map (lambda (x) (send x get-label))
                     (send (group:get-the-frame-group) get-frames))
                '("first"))

  ;; after the first test, we should have one frame
  ;; that will always be in the group.

  (check-equal?
   (let ()
     (send (make-object frame:basic% "test") show #t)
     (define ans (map (lambda (x) (send x get-label))
                      (send (group:get-the-frame-group) get-frames)))
     (send (test:get-active-top-level-window) close)
     ans)
  (list "test" "first"))


  (begin
    (yield
     (thread
      (λ ()
        (queue-callback
         (λ () (send (make-object frame:basic% "test1") show #t)))
        (wait-for-frame "test1")
        (queue-callback
         (λ () (send (make-object frame:basic% "test2") show #t)))
        (wait-for-frame "test2"))))
    (check-equal?
     (let ([frames (send (group:get-the-frame-group) get-frames)])
       (for-each (lambda (x)
                   (unless (equal? (send x get-label) "first")
                     (send x close)))
                 frames)
       (map (lambda (x) (send x get-label)) frames))
     (list "test2" "test1" "first")))

  (begin
    (yield
     (thread
      (λ ()
        (queue-callback
         (λ ()
           (send (make-object frame:basic% "test1") show #t)))
        (wait-for-frame "test1")
        (queue-callback
         (λ ()
           (send (make-object frame:basic% "test2") show #t)))
        (wait-for-frame "test2"))))
    (send (test:get-active-top-level-window) close)
    (check-equal?
     (let ([frames (send (group:get-the-frame-group) get-frames)])
       (for-each (lambda (x)
                   (unless (equal? (send x get-label) "first")
                     (send x close)))
                 frames)
       (map (lambda (x) (send x get-label)) frames))
     (list "test1" "first")))


  (when (eq? (system-type) 'macosx)

    (check-equal?
     (begin
       (send (make-object frame:basic% "test") show #t)
       (let ([mb (send (test:get-active-top-level-window) get-menu-bar)])
         (send mb on-demand)
         (define labels
           (for/list ([x (send (car* (send mb get-items)) get-items)])
             (and (is-a? x labelled-menu-item<%>) (send x get-label))))
         (send (test:get-active-top-level-window) close)
         labels))
     (append windows-menu-prefix (list "first" "test")))

    (check-equal?
     (let ()
       (define frame1 (make-object frame:basic% "test"))
       (define frame2 (make-object frame:basic% "test-not-shown"))
       (send frame1 show #t)
       (define mb (send (test:get-active-top-level-window) get-menu-bar))
       (send mb on-demand)
       (define items
         (for/list ([x (send (car* (send mb get-items)) get-items)])
           (and (is-a? x labelled-menu-item<%>) (send x get-label))))
       (send (test:get-active-top-level-window) close)
       items)
     (append windows-menu-prefix (list "first" "test")))

    (define (get-label-and-close-non-first)
      (define frames (send (group:get-the-frame-group) get-frames))
      (define mb (send (car* frames) get-menu-bar))
      (send mb on-demand)
      (define ans
        (for/list ([x (in-list (send (car* (send mb get-items))
                                     get-items))])
          (and (is-a? x labelled-menu-item<%>) (send x get-label))))
      (for ([x (in-list frames)])
        (unless (equal? (send x get-label) "first")
          (send x close)))
      ans)
    
    (check-equal?
     (let ()
       (define aaa-frame (make-object frame:basic% "aaa"))
       (send aaa-frame show #t)
       (define bbb-frame (make-object frame:basic% "bbb"))
       (send bbb-frame show #t)
       (get-label-and-close-non-first))
     (append windows-menu-prefix (list "aaa" "bbb" "first")))

    (check-equal?
     (let ()
       (define bbb-frame (make-object frame:basic% "bbb"))
       (send bbb-frame show #t)
       (define aaa-frame (make-object frame:basic% "aaa"))
       (send aaa-frame show #t)
       (get-label-and-close-non-first))
     (append windows-menu-prefix (list "aaa" "bbb" "first"))))

  ;; close that original frame so the test suite can exit if run from `racket`
  (send the-first-frame show #f))