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))
(λ () (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 (unsaved-warning-mixin %)
(class %
@ -265,39 +266,41 @@
'(default=2 caution))
2
#:dialog-mixin (if (equal? (system-type) 'macosx)
unsaved-warning-mixin
values)))
(compose unsaved-warning-mixin dialog-mixin)
dialog-mixin)))
(or key-closed
(case mb-res
[(1) 'save]
[(2) 'cancel]
[(3) 'continue])))
(define get-choice
(lambda (message
true-choice
false-choice
(title (string-constant warning))
(default-result 'disallow-close)
(parent #f)
(style 'app)
(checkbox-proc #f)
(checkbox-label (string-constant dont-ask-again)))
(let* ([check? (and checkbox-proc (checkbox-proc))]
[style (if (eq? style 'app) `(default=1) `(default=1 ,style))]
[style (if (eq? 'disallow-close default-result)
(cons 'disallow-close style) style)]
[style (if check? (cons 'checked style) style)]
[return (λ (mb-res) (case mb-res [(1) #t] [(2) #f] [else mb-res]))])
(if checkbox-proc
(let-values ([(mb-res checked)
(message+check-box/custom title message checkbox-label
true-choice false-choice #f
parent style default-result)])
(checkbox-proc checked)
(return mb-res))
(return (message-box/custom title message true-choice false-choice #f
parent style default-result))))))
(define (get-choice message
true-choice
false-choice
[title (string-constant warning)]
[default-result 'disallow-close]
[parent #f]
[style 'app]
[checkbox-proc #f]
[checkbox-label (string-constant dont-ask-again)]
#:dialog-mixin [dialog-mixin values])
(let* ([check? (and checkbox-proc (checkbox-proc))]
[style (if (eq? style 'app) `(default=1) `(default=1 ,style))]
[style (if (eq? 'disallow-close default-result)
(cons 'disallow-close style) style)]
[style (if check? (cons 'checked style) style)]
[return (λ (mb-res) (case mb-res [(1) #t] [(2) #f] [else mb-res]))])
(if checkbox-proc
(let-values ([(mb-res checked)
(message+check-box/custom title message checkbox-label
true-choice false-choice #f
parent style default-result
#:dialog-mixin dialog-mixin)])
(checkbox-proc checked)
(return mb-res))
(return (message-box/custom title message true-choice false-choice #f
parent style default-result
#:dialog-mixin dialog-mixin)))))
;; manual renaming
(define gui-utils:trim-string trim-string)
@ -490,12 +493,14 @@
(or/c false/c
(is-a?/c frame%)
(is-a?/c dialog%))
boolean?)
boolean?
#:dialog-mixin (make-mixin-contract dialog%))
(symbols 'continue 'save 'cancel))
((filename action)
((can-save-now? #f)
(parent #f)
(cancel? #t)))
(cancel? #t)
(dialog-mixin values)))
@{This displays a dialog that warns the user of a unsaved file.
@ -511,6 +516,10 @@
in the dialog and the result may be @racket['cancel]. If it
is @racket[#f], then there is no cancel button, and @racket['cancel]
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.}]
})
@ -525,7 +534,8 @@
(symbols 'app 'caution 'stop)
(or/c false/c (case-> (boolean? . -> . void?)
(-> boolean?)))
string?)
string?
#:dialog-mixin (make-mixin-contract dialog%))
any/c)
((message true-choice false-choice)
((title (string-constant warning))
@ -533,7 +543,8 @@
(parent #f)
(style 'app)
(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
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
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
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
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 cancel)
(string-constant warning)
#f)
#f
#:dialog-mixin frame:focus-table-mixin)
(with-handlers ([exn:fail?
(λ (exn)
(message-box

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

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

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

@ -6,7 +6,8 @@
"../gui-utils.rkt"
mred/mred-sig)
(import mred^)
(import mred^
[prefix frame: framework:frame^])
(export (rename framework:exit^
(-exit exit)))
@ -60,7 +61,8 @@
'app
(case-lambda
[() (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))
(define (-exit)

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

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

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

@ -1,4 +1,4 @@
#lang scheme/unit
#lang racket/base
(require string-constants
racket/class
@ -6,8 +6,17 @@
"../preferences.rkt"
"../gui-utils.rkt"
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^
[prefix application: framework:application^]
[prefix frame: framework:frame^]
@ -268,14 +277,16 @@
(or (not (preferences:get 'framework:exit-when-no-frames))
(exit:exiting?)
(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))))
(define (on-close-action)
(when (preferences:get 'framework:exit-when-no-frames)
(unless (exit:exiting?)
(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)))))
(define (choose-a-frame parent)
@ -349,4 +360,4 @@
(internal-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
(string-constant save-as-plain-text)
(string-constant yes)
(string-constant no))))
(string-constant no)
#:dialog-mixin frame:focus-table-mixin)))
(set-file-format 'text)]
[(and (not all-strings?)
(eq? format 'same)
@ -2263,7 +2264,8 @@
(gui-utils:get-choice
(string-constant save-in-drs-format)
(string-constant yes)
(string-constant no))))
(string-constant no)
#:dialog-mixin frame:focus-table-mixin)))
(set-file-format 'standard)]
[else (void)]))
(inner (void) on-save-file name format))

2
gui-lib/info.rkt
View File

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

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

@ -1,7 +1,12 @@
#lang racket/base
(require "test-suite-utils.rkt")
(module test 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"
@ -9,180 +14,163 @@
(if (eq? (system-type) 'macosx)
(list* "Minimize" "Zoom" 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 ()
[(car* x) (if (pair? x)
(car x)
(error 'car* "got a non-pair for ~s" 'x))])))
[(car* x-expr)
(let ([x x-expr])
(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
;; 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))))))
(define the-first-frame #f)
;; after the first test, we should have one frame that will always
;; be in the group.
(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"))
(test
'one-frame-registered
(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)))))
;; after the first test, we should have one frame
;; that will always be in the group.
(test
'two-frames-registered
(lambda (x) (equal? x (list "test2" "test1" "first")))
(lambda ()
(queue-sexp-to-mred
'(send (make-object frame:basic% "test1") show #t))
(wait-for-frame "test1")
(queue-sexp-to-mred
'(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))))))
(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"))
(test
'one-frame-unregistered
(lambda (x) (equal? x (list "test1" "first")))
(lambda ()
(queue-sexp-to-mred
'(send (make-object frame:basic% "test1") show #t))
(wait-for-frame "test1")
(queue-sexp-to-mred
'(send (make-object frame:basic% "test2") show #t))
(wait-for-frame "test2")
(queue-sexp-to-mred
`(send (get-top-level-focus-window) close))
(queue-sexp-to-mred
`(let ([frames (send (group:get-the-frame-group) get-frames)])
(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)))))
(map (lambda (x) (send x get-label)) frames))
(list "test2" "test1" "first")))
(when (eq? (system-type) 'macosx)
(test
'windows-menu
(lambda (x)
(equal? x (append windows-menu-prefix (list "first" "test"))))
(λ ()
(queue-sexp-to-mred
'(let ([frame (make-object frame:basic% "test")])
(send frame show #t)))
(wait-for-frame "test")
(queue-sexp-to-mred
'(let ([mb (send (get-top-level-focus-window) get-menu-bar)])
(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 (get-top-level-focus-window) close)
labels))))
(test
'windows-menu-unshown
(lambda (x)
(equal? x (append windows-menu-prefix (list "first" "test"))))
(lambda ()
(queue-sexp-to-mred
'(let ([frame1 (make-object frame:basic% "test")]
[frame2 (make-object frame:basic% "test-not-shown")])
(send frame1 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)
(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
'windows-menu-sorted1
(lambda (x)
(equal? x (append windows-menu-prefix (list "aaa" "bbb" "first"))))
(lambda ()
(queue-sexp-to-mred
'(let ([frame (make-object frame:basic% "aaa")])
(send frame show #t)))
(wait-for-frame "aaa")
(queue-sexp-to-mred
'(let ([frame (make-object frame:basic% "bbb")])
(send frame show #t)))
(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
'windows-menu-sorted2
(lambda (x)
(equal? x (append windows-menu-prefix (list "aaa" "bbb" "first"))))
(lambda ()
(queue-sexp-to-mred
'(let ([frame (make-object frame:basic% "bbb")])
(send frame show #t)))
(wait-for-frame "bbb")
(queue-sexp-to-mred
'(let ([frame (make-object frame:basic% "aaa")])
(send frame show #t)))
(wait-for-frame "aaa")
(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)))))))
(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))