suzanne.soy/gui
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

adjust various things so that the group test can be run in

Browse Source 
a single process and without (I believe) depending on the 
OS's idea of which frame has the focus
This commit is contained in:
Robby Findler 2017-01-15 18:28:09 -06:00
parent 97b23af4b1
commit 1b10e27b5d
9 changed files with 238 additions and 213 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

84
gui-lib/framework/gui-utils.rkt
View File

@ -230,7 +230,8 @@
(λ () (thunk)) (λ () (thunk))
(λ () (cursor-off))))]))) (λ () (cursor-off))))])))
(define (unsaved-warning filename action-anyway [can-save-now? #f] [parent #f] [cancel? #t]) (define (unsaved-warning filename action-anyway [can-save-now? #f] [parent #f] [cancel? #t]
#:dialog-mixin [dialog-mixin values])
(define key-closed #f) (define key-closed #f)
(define (unsaved-warning-mixin %) (define (unsaved-warning-mixin %)
(class % (class %
@ -265,39 +266,41 @@
'(default=2 caution)) '(default=2 caution))
2 2
#:dialog-mixin (if (equal? (system-type) 'macosx) #:dialog-mixin (if (equal? (system-type) 'macosx)
unsaved-warning-mixin (compose unsaved-warning-mixin dialog-mixin)
values))) dialog-mixin)))
(or key-closed (or key-closed
(case mb-res (case mb-res
[(1) 'save] [(1) 'save]
[(2) 'cancel] [(2) 'cancel]
[(3) 'continue]))) [(3) 'continue])))
(define get-choice (define (get-choice message
(lambda (message true-choice
true-choice false-choice
false-choice [title (string-constant warning)]
(title (string-constant warning)) [default-result 'disallow-close]
(default-result 'disallow-close) [parent #f]
(parent #f) [style 'app]
(style 'app) [checkbox-proc #f]
(checkbox-proc #f) [checkbox-label (string-constant dont-ask-again)]
(checkbox-label (string-constant dont-ask-again))) #:dialog-mixin [dialog-mixin values])
(let* ([check? (and checkbox-proc (checkbox-proc))] (let* ([check? (and checkbox-proc (checkbox-proc))]
[style (if (eq? style 'app) `(default=1) `(default=1 ,style))] [style (if (eq? style 'app) `(default=1) `(default=1 ,style))]
[style (if (eq? 'disallow-close default-result) [style (if (eq? 'disallow-close default-result)
(cons 'disallow-close style) style)] (cons 'disallow-close style) style)]
[style (if check? (cons 'checked style) style)] [style (if check? (cons 'checked style) style)]
[return (λ (mb-res) (case mb-res [(1) #t] [(2) #f] [else mb-res]))]) [return (λ (mb-res) (case mb-res [(1) #t] [(2) #f] [else mb-res]))])
(if checkbox-proc (if checkbox-proc
(let-values ([(mb-res checked) (let-values ([(mb-res checked)
(message+check-box/custom title message checkbox-label (message+check-box/custom title message checkbox-label
true-choice false-choice #f true-choice false-choice #f
parent style default-result)]) parent style default-result
(checkbox-proc checked) #:dialog-mixin dialog-mixin)])
(return mb-res)) (checkbox-proc checked)
(return (message-box/custom title message true-choice false-choice #f (return mb-res))
parent style default-result)))))) (return (message-box/custom title message true-choice false-choice #f
parent style default-result
#:dialog-mixin dialog-mixin)))))
;; manual renaming ;; manual renaming
(define gui-utils:trim-string trim-string) (define gui-utils:trim-string trim-string)
@ -490,12 +493,14 @@
(or/c false/c (or/c false/c
(is-a?/c frame%) (is-a?/c frame%)
(is-a?/c dialog%)) (is-a?/c dialog%))
boolean?) boolean?
#:dialog-mixin (make-mixin-contract dialog%))
(symbols 'continue 'save 'cancel)) (symbols 'continue 'save 'cancel))
((filename action) ((filename action)
((can-save-now? #f) ((can-save-now? #f)
(parent #f) (parent #f)
(cancel? #t))) (cancel? #t)
(dialog-mixin values)))
@{This displays a dialog that warns the user of a unsaved file. @{This displays a dialog that warns the user of a unsaved file.
@ -512,6 +517,10 @@
is @racket[#f], then there is no cancel button, and @racket['cancel] is @racket[#f], then there is no cancel button, and @racket['cancel]
will not be the result of the function. will not be the result of the function.
The @racket[dialog-mixin] argument is passed to @racket[message-box/custom].
@history[#:changed "1.29" @elem{Added the @racket[dialog-mixin] argument.}]
}) })
(proc-doc/names (proc-doc/names
@ -525,7 +534,8 @@
(symbols 'app 'caution 'stop) (symbols 'app 'caution 'stop)
(or/c false/c (case-> (boolean? . -> . void?) (or/c false/c (case-> (boolean? . -> . void?)
(-> boolean?))) (-> boolean?)))
string?) string?
#:dialog-mixin (make-mixin-contract dialog%))
any/c) any/c)
((message true-choice false-choice) ((message true-choice false-choice)
((title (string-constant warning)) ((title (string-constant warning))
@ -533,7 +543,8 @@
(parent #f) (parent #f)
(style 'app) (style 'app)
(checkbox-proc #f) (checkbox-proc #f)
(checkbox-label (string-constant dont-ask-again)))) (checkbox-label (string-constant dont-ask-again))
(dialog-mixin values)))
@{Opens a dialog that presents a binary choice to the user. The user is @{Opens a dialog that presents a binary choice to the user. The user is
forced to choose between these two options, ie cancelling or closing the forced to choose between these two options, ie cancelling or closing the
@ -565,7 +576,14 @@
(defaults to the @racket[dont-ask-again] string constant), and that (defaults to the @racket[dont-ask-again] string constant), and that
checkbox value will be sent to the @racket[checkbox-proc] when the dialog checkbox value will be sent to the @racket[checkbox-proc] when the dialog
is closed. Note that the dialog will always pop-up --- it is the is closed. Note that the dialog will always pop-up --- it is the
caller's responsibility to avoid the dialog if not needed.}) caller's responsibility to avoid the dialog if not needed.
The @racket[dialog-mixin] argument is passed to @racket[message-box/custom]
or @racket[message+check-box/custom].
@history[#:changed "1.29" @elem{Added the @racket[dialog-mixin] argument.}]
})
(proc-doc/names (proc-doc/names
gui-utils:get-clicked-clickback-delta gui-utils:get-clicked-clickback-delta

3
gui-lib/framework/private/autosave.rkt
View File

@ -256,7 +256,8 @@
(string-constant autosave-delete-title) (string-constant autosave-delete-title)
(string-constant cancel) (string-constant cancel)
(string-constant warning) (string-constant warning)
#f) #f
#:dialog-mixin frame:focus-table-mixin)
(with-handlers ([exn:fail? (with-handlers ([exn:fail?
(λ (exn) (λ (exn)
(message-box (message-box

6
gui-lib/framework/private/editor.rkt
View File

@ -154,7 +154,8 @@
(string-constant cancel) (string-constant cancel)
(string-constant warning) (string-constant warning)
#f #f
(get-top-level-window)) (get-top-level-window)
#:dialog-mixin frame:focus-table-mixin)
#t) #t)
#t) #t)
(inner #t can-save-file? filename format))) (inner #t can-save-file? filename format)))
@ -585,7 +586,8 @@
#t #t
(or (get-top-level-window) (or (get-top-level-window)
(get-can-close-parent)) (get-can-close-parent))
allow-cancel?) allow-cancel?
#:dialog-mixin frame:focus-table-mixin)
[(continue) #t] [(continue) #t]
[(save) (save-file)] [(save) (save-file)]
[else #f]))) [else #f])))

6
gui-lib/framework/private/exit.rkt
View File

@ -6,7 +6,8 @@
"../gui-utils.rkt" "../gui-utils.rkt"
mred/mred-sig) mred/mred-sig)
(import mred^) (import mred^
[prefix frame: framework:frame^])
(export (rename framework:exit^ (export (rename framework:exit^
(-exit exit))) (-exit exit)))
@ -60,7 +61,8 @@
'app 'app
(case-lambda (case-lambda
[() (not (preferences:get 'framework:verify-exit))] [() (not (preferences:get 'framework:verify-exit))]
[(new) (preferences:set 'framework:verify-exit (not new))])) [(new) (preferences:set 'framework:verify-exit (not new))])
#:dialog-mixin frame:focus-table-mixin)
#t)) #t))
(define (-exit) (define (-exit)

3
gui-lib/framework/private/frame.rkt
View File

@ -1509,7 +1509,8 @@
(string-constant no) (string-constant no)
(string-constant are-you-sure-revert-title) (string-constant are-you-sure-revert-title)
#f #f
this)) this
#:dialog-mixin focus-table-mixin))
(revert)))) (revert))))
#t)) #t))

21
gui-lib/framework/private/group.rkt
View File

@ -1,4 +1,4 @@
#lang scheme/unit #lang racket/base
(require string-constants (require string-constants
racket/class racket/class
@ -6,8 +6,17 @@
"../preferences.rkt" "../preferences.rkt"
"../gui-utils.rkt" "../gui-utils.rkt"
mred/mred-sig mred/mred-sig
racket/path) racket/path
racket/unit)
;; for use in the test suite
(define pay-attention-to-current-eventspace-has-standard-menus?
(make-parameter #t))
(provide pay-attention-to-current-eventspace-has-standard-menus?
group@)
(define-unit group@
(import mred^ (import mred^
[prefix application: framework:application^] [prefix application: framework:application^]
[prefix frame: framework:frame^] [prefix frame: framework:frame^]
@ -268,14 +277,16 @@
(or (not (preferences:get 'framework:exit-when-no-frames)) (or (not (preferences:get 'framework:exit-when-no-frames))
(exit:exiting?) (exit:exiting?)
(not (= 1 number-of-frames)) (not (= 1 number-of-frames))
(current-eventspace-has-standard-menus?) (and (pay-attention-to-current-eventspace-has-standard-menus?)
(current-eventspace-has-standard-menus?))
(exit:user-oks-exit)))) (exit:user-oks-exit))))
(define (on-close-action) (define (on-close-action)
(when (preferences:get 'framework:exit-when-no-frames) (when (preferences:get 'framework:exit-when-no-frames)
(unless (exit:exiting?) (unless (exit:exiting?)
(when (and (null? (send (get-the-frame-group) get-frames)) (when (and (null? (send (get-the-frame-group) get-frames))
(not (current-eventspace-has-standard-menus?))) (not (and (pay-attention-to-current-eventspace-has-standard-menus?)
(current-eventspace-has-standard-menus?))))
(exit:exit))))) (exit:exit)))))
(define (choose-a-frame parent) (define (choose-a-frame parent)
@ -349,4 +360,4 @@
(internal-get-the-frame-group))) (internal-get-the-frame-group)))
(define (get-the-frame-group) (define (get-the-frame-group)
(internal-get-the-frame-group)) (internal-get-the-frame-group)))

6
gui-lib/framework/private/text.rkt
View File

@ -2254,7 +2254,8 @@
(gui-utils:get-choice (gui-utils:get-choice
(string-constant save-as-plain-text) (string-constant save-as-plain-text)
(string-constant yes) (string-constant yes)
(string-constant no)))) (string-constant no)
#:dialog-mixin frame:focus-table-mixin)))
(set-file-format 'text)] (set-file-format 'text)]
[(and (not all-strings?) [(and (not all-strings?)
(eq? format 'same) (eq? format 'same)
@ -2263,7 +2264,8 @@
(gui-utils:get-choice (gui-utils:get-choice
(string-constant save-in-drs-format) (string-constant save-in-drs-format)
(string-constant yes) (string-constant yes)
(string-constant no)))) (string-constant no)
#:dialog-mixin frame:focus-table-mixin)))
(set-file-format 'standard)] (set-file-format 'standard)]
[else (void)])) [else (void)]))
(inner (void) on-save-file name format)) (inner (void) on-save-file name format))

2
gui-lib/info.rkt
View File

@ -30,4 +30,4 @@
(define pkg-authors '(mflatt robby)) (define pkg-authors '(mflatt robby))
(define version "1.28") (define version "1.29")

310
gui-test/framework/tests/group-test.rkt
View File

@ -1,7 +1,12 @@
#lang racket/base #lang racket/base
(require "test-suite-utils.rkt") (require "private/here-util.rkt"
"private/gui.rkt"
(module test racket/base) 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 (define windows-menu-prefix
(let ([basics (list "Bring Frame to Front…" "Most Recent Window" (let ([basics (list "Bring Frame to Front…" "Most Recent Window"
@ -9,180 +14,163 @@
(if (eq? (system-type) 'macosx) (if (eq? (system-type) 'macosx)
(list* "Minimize" "Zoom" basics) (list* "Minimize" "Zoom" basics)
basics))) basics)))
(send-sexp-to-mred
'(define-syntax car* (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 () (syntax-rules ()
[(car* x) (if (pair? x) [(car* x-expr)
(car x) (let ([x x-expr])
(error 'car* "got a non-pair for ~s" 'x))]))) (if (pair? x)
(car x)
(begin
(eprintf "car* called with ~s\n" 'x-expr)
(car x))))]))
;; this test uses a new eventspace so that the gracket function (define the-first-frame #f)
;; current-eventspace-has-standard-menus? returns #f and thus
;; all of the platforms behave the same way.
(test
'exit-on
(lambda (x) (equal? x '("first")))
(lambda ()
(send-sexp-to-mred `(define new-eventspace (make-eventspace)))
(send-sexp-to-mred
'(begin (parameterize ([current-eventspace new-eventspace])
(send (make-object frame:basic% "first") show #t))
(preferences:set 'framework:verify-exit #t)))
(wait-for-frame "first" 'new-eventspace)
(send-sexp-to-mred
`(queue-callback (lambda ()
(parameterize ([current-eventspace new-eventspace])
(send (get-top-level-focus-window) close)))))
(wait-for-frame "Warning" 'new-eventspace)
(send-sexp-to-mred
`(parameterize ([current-eventspace new-eventspace])
(test:button-push "Cancel")))
(wait-for-frame "first" 'new-eventspace)
(send-sexp-to-mred
`(parameterize ([current-eventspace new-eventspace])
(map (lambda (x) (send x get-label))
(send (group:get-the-frame-group) get-frames))))))
;; after the first test, we should have one frame that will always (yield
;; be in the group. (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"))
(test ;; after the first test, we should have one frame
'one-frame-registered ;; that will always be in the group.
(lambda (x) (equal? x (list "test" "first")))
(lambda ()
(queue-sexp-to-mred
`(send (make-object frame:basic% "test") show #t))
(wait-for-frame "test")
(queue-sexp-to-mred
`(begin0 (map (lambda (x) (send x get-label))
(send (group:get-the-frame-group) get-frames))
(send (get-top-level-focus-window) close)))))
(test (check-equal?
'two-frames-registered (let ()
(lambda (x) (equal? x (list "test2" "test1" "first"))) (send (make-object frame:basic% "test") show #t)
(lambda () (define ans (map (lambda (x) (send x get-label))
(queue-sexp-to-mred (send (group:get-the-frame-group) get-frames)))
'(send (make-object frame:basic% "test1") show #t)) (send (test:get-active-top-level-window) close)
(wait-for-frame "test1") ans)
(queue-sexp-to-mred (list "test" "first"))
'(send (make-object frame:basic% "test2") show #t))
(wait-for-frame "test2")
(queue-sexp-to-mred
`(begin0 (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))))))
(test
'one-frame-unregistered (begin
(lambda (x) (equal? x (list "test1" "first"))) (yield
(lambda () (thread
(queue-sexp-to-mred (λ ()
'(send (make-object frame:basic% "test1") show #t)) (queue-callback
(wait-for-frame "test1") (λ () (send (make-object frame:basic% "test1") show #t)))
(queue-sexp-to-mred (wait-for-frame "test1")
'(send (make-object frame:basic% "test2") show #t)) (queue-callback
(wait-for-frame "test2") (λ () (send (make-object frame:basic% "test2") show #t)))
(queue-sexp-to-mred (wait-for-frame "test2"))))
`(send (get-top-level-focus-window) close)) (check-equal?
(queue-sexp-to-mred (let ([frames (send (group:get-the-frame-group) get-frames)])
`(let ([frames (send (group:get-the-frame-group) get-frames)])
(for-each (lambda (x) (for-each (lambda (x)
(unless (equal? (send x get-label) "first") (unless (equal? (send x get-label) "first")
(send x close))) (send x close)))
frames) frames)
(map (lambda (x) (send x get-label)) frames))))) (map (lambda (x) (send x get-label)) frames))
(list "test2" "test1" "first")))
(when (eq? (system-type) 'macosx) (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")))
(test
'windows-menu (when (eq? (system-type) 'macosx)
(lambda (x)
(equal? x (append windows-menu-prefix (list "first" "test")))) (check-equal?
(λ () (begin
(queue-sexp-to-mred (send (make-object frame:basic% "test") show #t)
'(let ([frame (make-object frame:basic% "test")]) (let ([mb (send (test:get-active-top-level-window) get-menu-bar)])
(send frame show #t)))
(wait-for-frame "test")
(queue-sexp-to-mred
'(let ([mb (send (get-top-level-focus-window) get-menu-bar)])
(send mb on-demand) (send mb on-demand)
(define labels (define labels
(for/list ([x (send (car* (send mb get-items)) get-items)]) (for/list ([x (send (car* (send mb get-items)) get-items)])
(and (is-a? x labelled-menu-item<%>) (send x get-label)))) (and (is-a? x labelled-menu-item<%>) (send x get-label))))
(send (get-top-level-focus-window) close) (send (test:get-active-top-level-window) close)
labels)))) labels))
(append windows-menu-prefix (list "first" "test")))
(test (check-equal?
'windows-menu-unshown (let ()
(lambda (x) (define frame1 (make-object frame:basic% "test"))
(equal? x (append windows-menu-prefix (list "first" "test")))) (define frame2 (make-object frame:basic% "test-not-shown"))
(lambda () (send frame1 show #t)
(queue-sexp-to-mred (define mb (send (test:get-active-top-level-window) get-menu-bar))
'(let ([frame1 (make-object frame:basic% "test")] (send mb on-demand)
[frame2 (make-object frame:basic% "test-not-shown")]) (define items
(send frame1 show #t))) (for/list ([x (send (car* (send mb get-items)) get-items)])
(wait-for-frame "test") (and (is-a? x labelled-menu-item<%>) (send x get-label))))
(queue-sexp-to-mred (send (test:get-active-top-level-window) close)
'(let ([mb (send (get-top-level-focus-window) get-menu-bar)]) items)
(send mb on-demand) (append windows-menu-prefix (list "first" "test")))
(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 (get-top-level-focus-window) close)
items))))
(test (define (get-label-and-close-non-first)
'windows-menu-sorted1 (define frames (send (group:get-the-frame-group) get-frames))
(lambda (x) (define mb (send (car* frames) get-menu-bar))
(equal? x (append windows-menu-prefix (list "aaa" "bbb" "first")))) (send mb on-demand)
(lambda () (define ans
(queue-sexp-to-mred (for/list ([x (in-list (send (car* (send mb get-items))
'(let ([frame (make-object frame:basic% "aaa")]) get-items))])
(send frame show #t))) (and (is-a? x labelled-menu-item<%>) (send x get-label))))
(wait-for-frame "aaa") (for ([x (in-list frames)])
(queue-sexp-to-mred (unless (equal? (send x get-label) "first")
'(let ([frame (make-object frame:basic% "bbb")]) (send x close)))
(send frame show #t))) ans)
(wait-for-frame "bbb")
(queue-sexp-to-mred
`(let ([frames (send (group:get-the-frame-group) get-frames)])
(define mb (send (car* frames) get-menu-bar))
(send mb on-demand)
(begin0 (map (lambda (x)
(and (is-a? x labelled-menu-item<%>) (send x get-label)))
(send (car* (send mb get-items))
get-items))
(for-each (lambda (x)
(unless (equal? (send x get-label) "first")
(send x close)))
frames))))))
(test (check-equal?
'windows-menu-sorted2 (let ()
(lambda (x) (define aaa-frame (make-object frame:basic% "aaa"))
(equal? x (append windows-menu-prefix (list "aaa" "bbb" "first")))) (send aaa-frame show #t)
(lambda () (define bbb-frame (make-object frame:basic% "bbb"))
(queue-sexp-to-mred (send bbb-frame show #t)
'(let ([frame (make-object frame:basic% "bbb")]) (get-label-and-close-non-first))
(send frame show #t))) (append windows-menu-prefix (list "aaa" "bbb" "first")))
(wait-for-frame "bbb")
(queue-sexp-to-mred (check-equal?
'(let ([frame (make-object frame:basic% "aaa")]) (let ()
(send frame show #t))) (define bbb-frame (make-object frame:basic% "bbb"))
(wait-for-frame "aaa") (send bbb-frame show #t)
(queue-sexp-to-mred (define aaa-frame (make-object frame:basic% "aaa"))
`(let ([frames (send (group:get-the-frame-group) get-frames)]) (send aaa-frame show #t)
(define mb (send (car* frames) get-menu-bar)) (get-label-and-close-non-first))
(send mb on-demand) (append windows-menu-prefix (list "aaa" "bbb" "first"))))
(begin0 (map (lambda (x)
(and (is-a? x labelled-menu-item<%>) (send x get-label))) ;; close that original frame so the test suite can exit if run from `racket`
(send (car* (send mb get-items)) (send the-first-frame show #f))
get-items))
(for-each (lambda (x)
(unless (equal? (send x get-label) "first")
(send x close)))
frames)))))))