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

take more care to not be affected by the contents of the

Browse Source 
(possibly changing on drdr!) preferences file

and add a little more to help debug keys.rkt failures
This commit is contained in:
Robby Findler 2017-01-16 21:13:45 -06:00
parent 97c30fe9e2
commit 66660791da
7 changed files with 240 additions and 232 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
gui-test/framework/tests/canvas.rkt
View File

@ -1,5 +1,5 @@
#lang racket/base
(require "private/here-util.rkt"
(require "private/util.rkt"
framework
racket/class
racket/gui/base

28
gui-test/framework/tests/frame.rkt
View File

@ -1,6 +1,6 @@
#lang racket/base
(require "private/here-util.rkt"
(require "private/util.rkt"
"private/gui.rkt"
rackunit
racket/class
@ -315,21 +315,13 @@
(check-equal? (try no-change-early-f "aaaa" "a" "bbbbbbbbbb") "abbbbbbbbbbbbbbbbbbbbbbbbbbbbbb")
(close-up-no-change-early-f no-change-early-f))))
(let ([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)))])
(define dummy (make-object frame:basic% "dummy to keep from quitting"))
(send dummy show #t)
(creation-tests)
(open-tests)
(replace-all-tests)
(frame/text-creation-tests)
(send dummy show #f)))
(with-private-prefs
(parameterize ([test:use-focus-table #t])
(define dummy (make-object frame:basic% "dummy to keep from quitting"))
(send dummy show #t)
(creation-tests)
(open-tests)
(replace-all-tests)
(frame/text-creation-tests)
(send dummy show #f)))

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

@ -1,5 +1,5 @@
#lang racket/base
(require "private/here-util.rkt"
(require "private/util.rkt"
"private/gui.rkt"
rackunit
racket/class
@ -15,162 +15,154 @@
(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])
(with-private-prefs
(parameterize ([test:use-focus-table #t]
[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-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)
(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"))
(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.
;; 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)))
(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 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"))))
(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))
;; close that original frame so the test suite can exit if run from `racket`
(send the-first-frame show #f)))

70
gui-test/framework/tests/keys.rkt
View File

@ -1,5 +1,5 @@
#lang racket/gui
(require framework rackunit)
(require framework rackunit "private/util.rkt")
(check-equal?
(let ([k (make-object keymap:aug-keymap%)])
@ -415,43 +415,41 @@
(send text get-start-position)
(send text get-end-position))))
(vector text-expect start-expect end-expect)
(~s (list key-sequence i)))))
(~s (list frame-name key-sequence i)))))
(queue-callback/wait (λ () (send f close))))
(let ([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)))])
;; needs to be inside the test:use-focus-table setting
(parameterize ([current-eventspace (make-eventspace)])
(with-private-prefs
(parameterize ([test:use-focus-table #t])
;; needs to be inside the test:use-focus-table setting
(parameterize ([current-eventspace (make-eventspace)])
;; make sure we're back to a clean preferences state
;; and the parameterize above ensure that we won't
;; look at the disk so together this should mean
;; no interference between different concurrent tests
(preferences:restore-defaults)
(define dummy #f)
(queue-callback
(λ ()
(set! dummy (make-object frame:basic% "dummy to trick frame group"))
(send dummy show #t)))
(define dummy #f)
(queue-callback
(λ ()
(set! dummy (make-object frame:basic% "dummy to trick frame group"))
(send dummy show #t)))
(preferences:set 'framework:fixup-open-parens #t)
(preferences:set 'framework:automatic-parens #f)
(test-specs "global keybindings test" frame:text% global-specs)
(test-specs "racket mode keybindings test"
(class frame:editor%
(define/override (get-editor%) racket:text%)
(super-new))
scheme-specs)
(preferences:set 'framework:fixup-open-parens #t)
(preferences:set 'framework:automatic-parens #f)
(test-specs "global keybindings test" frame:text% global-specs)
(test-specs "racket mode keybindings test"
(class frame:editor%
(define/override (get-editor%) racket:text%)
(super-new))
scheme-specs)
(preferences:set 'framework:automatic-parens #t)
(preferences:set 'framework:fixup-open-parens #f)
(test-specs "racket mode automatic-parens on keybindings test"
(class frame:editor%
(define/override (get-editor%) racket:text%)
(super-new))
automatic-scheme-specs)
(preferences:set 'framework:automatic-parens #t)
(preferences:set 'framework:fixup-open-parens #f)
(test-specs "racket mode automatic-parens on keybindings test"
(class frame:editor%
(define/override (get-editor%) racket:text%)
(super-new))
automatic-scheme-specs)
(queue-callback (λ () (send dummy show #f))))))
(queue-callback (λ () (send dummy show #f))))))

25
gui-test/framework/tests/private/here-util.rkt
View File

@ -1,25 +0,0 @@
#lang racket/base
(require framework/private/focus-table
racket/gui/base
racket/class)
(provide wait-for-frame wait-for/here)
(define (wait-for/here test)
(define timeout 10)
(define pause-time 1/2)
(let loop ([n (ceiling (/ timeout pause-time))])
(if (zero? n)
(error 'wait-for "after ~a seconds, ~s didn't come true" timeout test)
(unless (test)
(sleep pause-time)
(loop (- n 1))))))
(define (wait-for-frame name [eventspace (current-eventspace)])
(define (check-for-frame)
(for/or ([frame (in-list (frame:lookup-focus-table eventspace))])
(and (equal? name (send frame get-label))
frame)))
(wait-for/here
(procedure-rename check-for-frame
(string->symbol (format "check-for-frame-named-\"~a\"" name)))))

51
gui-test/framework/tests/private/util.rkt Normal file
View File

@ -0,0 +1,51 @@
#lang racket/base
(require framework/private/focus-table
framework/preferences
racket/gui/base
racket/class
(for-syntax racket/base))
(provide wait-for-frame wait-for/here
with-private-prefs)
(define (wait-for/here test)
(define timeout 10)
(define pause-time 1/2)
(let loop ([n (ceiling (/ timeout pause-time))])
(if (zero? n)
(error 'wait-for "after ~a seconds, ~s didn't come true" timeout test)
(unless (test)
(sleep pause-time)
(loop (- n 1))))))
(define (wait-for-frame name [eventspace (current-eventspace)])
(define (check-for-frame)
(for/or ([frame (in-list (frame:lookup-focus-table eventspace))])
(and (equal? name (send frame get-label))
frame)))
(wait-for/here
(procedure-rename check-for-frame
(string->symbol (format "check-for-frame-named-\"~a\"" name)))))
(define-syntax (with-private-prefs stx)
(syntax-case stx ()
[(_ e1 e2 ...)
#'(with-private-prefs/proc (λ () e1 e2 ...))]))
(define (with-private-prefs/proc t)
(define pref-ht (make-hash))
(parameterize ([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)))])
;; make sure we're back to a clean preferences state
;; and the parameterize above ensure that we won't
;; look at the disk so together this should mean
;; no interference between different concurrent tests
(preferences:restore-defaults)
(t)))

2
gui-test/framework/tests/text.rkt
View File

@ -1,6 +1,6 @@
#lang racket
(require "private/here-util.rkt"
(require "private/util.rkt"
"private/gui.rkt"
rackunit
racket/gui/base