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

modernize preferences test suite

Browse Source
This commit is contained in:
Robby Findler 2017-01-22 15:37:03 -06:00
parent 66660791da
commit 13be85d623
2 changed files with 99 additions and 137 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
gui-test/framework/tests/README
View File

@ -36,7 +36,7 @@ signal failures when there aren't any.
| This tests that exit:exit really exits and that the exit callbacks
| are actually run.
- preferences: |# prefs.rkt #|
- preferences: prefs.rkt -- now runs directly via raco test
| This tests that preferences are saved and restored correctly, both
| immediately and across reboots of gracket.

234
gui-test/framework/tests/prefs.rkt
View File

@ -1,141 +1,103 @@
#lang racket/base
(require "test-suite-utils.rkt")
(require framework/preferences
racket/format
rackunit)
(module test racket/base)
(define ((check-equal? x) y) (equal? x y))
(define pref-sym 'plt:not-a-real-preference)
(define marshalling-pref-sym 'plt:not-a-real-preference-marshalling)
(define default-test-sym 'plt:not-a-real-preference-default-test)
(shutdown-mred)
(test
'preference-unbound
(check-equal? 'passed)
`(with-handlers ([exn:unknown-preference?
(lambda (x)
'passed)])
(preferences:get ',pref-sym)))
(test 'preference-set-default/get
(check-equal? 'passed)
`(begin (preferences:set-default ',pref-sym 'passed symbol?)
(preferences:get ',pref-sym)))
(test 'preference-set/get
(check-equal? 'new-pref)
`(begin (preferences:set ',pref-sym 'new-pref)
(preferences:get ',pref-sym)))
;(define ((check-equal? x) y) (equal? x y))
(define pref-sym 'plt:not-a-real-preference)
(define marshalling-pref-sym 'plt:not-a-real-preference-marshalling)
(define default-test-sym 'plt:not-a-real-preference-default-test)
(test 'preference-marshalling
(check-equal? 'the-answer)
`(begin (preferences:set-default ',marshalling-pref-sym (lambda () 'the-answer) procedure?)
(preferences:set-un/marshall ',marshalling-pref-sym
(lambda (f) (f))
(lambda (v) (lambda () v)))
(begin0 ((preferences:get ',marshalling-pref-sym))
(preferences:set ',marshalling-pref-sym (lambda () 2)))))
(shutdown-mred)
(test 'preference-marshalling
(check-equal? 2)
`(begin (preferences:set-default ',marshalling-pref-sym (lambda () 'the-answer) procedure?)
(preferences:set-un/marshall ',marshalling-pref-sym
(lambda (f) (f))
(lambda (v) (lambda () v)))
((preferences:get ',marshalling-pref-sym))))
(with-handlers ([eof-result? (lambda (x) (void))])
(send-sexp-to-mred '(begin (preferences:set 'framework:verify-exit #f)
(exit:exit)
;; do this yield here so that exit:exit
;; actually exits on this interaction.
;; right now, exit:exit queue's a new event to exit
;; instead of just exiting immediately.
(yield (make-semaphore 0)))))
(test 'preference-get-after-restart
(check-equal? 'new-pref)
`(begin (preferences:set-default ',pref-sym 'passed symbol?)
(preferences:get ',pref-sym)))
(define the-prefs-table (make-hash))
(parameterize ([preferences:low-level-put-preferences
(λ (syms vals)
(for ([sym (in-list syms)]
[val (in-list vals)])
(hash-set! the-prefs-table sym val)))]
[preferences:low-level-get-preference
(λ (sym [fail void])
(hash-ref the-prefs-table sym fail))])
(test 'preference-no-set-default-stage1
(check-equal? 'stage1)
`(begin (preferences:set-default ',default-test-sym 'default symbol?)
(preferences:set ',default-test-sym 'new-value)
'stage1))
(shutdown-mred)
(test 'preference-no-set-default-stage2
(check-equal? 'stage2)
`(begin 'stage2))
(shutdown-mred)
(test 'preference-no-set-default-stage3
(check-equal? 'new-value)
`(begin (preferences:set-default ',default-test-sym 'default symbol?)
(preferences:get ',default-test-sym)))
(check-exn
exn:unknown-preference?
(λ ()
(preferences:get pref-sym)))
(check-equal?
(begin
(preferences:set-default pref-sym 'passed symbol?)
(preferences:get pref-sym))
'passed)
(check-equal?
(begin (preferences:set pref-sym 'new-pref)
(preferences:get pref-sym))
'new-pref)
(check-equal?
(begin (preferences:set-default marshalling-pref-sym (lambda () 'the-answer) procedure?)
(preferences:set-un/marshall marshalling-pref-sym
(lambda (f) (f))
(lambda (v) (lambda () v)))
(begin0 ((preferences:get marshalling-pref-sym))
(preferences:set marshalling-pref-sym (lambda () 2))))
'the-answer)
(check-equal? ((preferences:get marshalling-pref-sym)) 2)
(test 'preference-add-callback
(check-equal? 2)
`(begin
(let ([x 1])
(define remove-it (preferences:add-callback ',default-test-sym (λ (a b) (set! x (+ x 1)))))
(preferences:set ',default-test-sym 'xyz)
(remove-it)
(preferences:set ',default-test-sym 'pdq)
x)))
(test 'preference-add-weak-callback
(check-equal? 2)
`(begin
(let ([x 1])
(define f (λ (a b) (set! x (+ x 1))))
(define remove-it (preferences:add-callback ',default-test-sym f #t))
(preferences:set ',default-test-sym 'xyz)
(remove-it)
(preferences:set ',default-test-sym 'pdq)
x)))
(test 'preference-add-weak-callback2
(check-equal? 3)
`(begin
(let ([x 1])
(define f (λ (a b) (set! x (+ x 1))))
(unless (zero? (random 1)) (set! f 'not-a-proc)) ;; try to stop inlining
(define remove-it (preferences:add-callback ',default-test-sym f #t))
(collect-garbage) (collect-garbage) (collect-garbage)
(preferences:set ',default-test-sym 'xyz)
(remove-it)
(preferences:set ',default-test-sym 'pdq)
(f 'a 'b) ;; make sure safe-for-space doesn't free 'f' earlier
x)))
(test 'preference-weak-callback-is-weak
(check-equal? #t)
`(begin
(let ([x 1])
(define f (λ (a b) (set! x (+ x 1))))
(define wb (make-weak-box f))
(define remove-it (preferences:add-callback ',default-test-sym f #t))
(set! f #f)
(begin0
(let loop ([n 10])
(cond
[(not (weak-box-value wb)) #t]
[(zero? n) 'f-still-alive]
[else
(collect-garbage)
(loop (- n 1))]))
(remove-it)))))
(test 'dialog-appears
(check-equal? 'passed)
(lambda ()
(queue-sexp-to-mred '(begin (send (make-object frame:basic% "frame") show #t)
(preferences:show-dialog)))
(wait-for-frame "Preferences")
(queue-sexp-to-mred '(begin (preferences:hide-dialog)
(let ([f (get-top-level-focus-window)])
(if f
(if (string=? "Preferences" (send f get-label))
'failed
'passed)
'passed))))))
;; make sure the preference actually got "written out"
(check-equal? (hash-ref the-prefs-table
(string->symbol (~a "plt:framework-pref:" pref-sym)))
'new-pref)
(check-equal?
(let ([x 1])
(preferences:set-default default-test-sym 'default symbol?)
(define remove-it (preferences:add-callback default-test-sym (λ (a b) (set! x (+ x 1)))))
(preferences:set default-test-sym 'xyz)
(remove-it)
(preferences:set default-test-sym 'pdq)
x)
2)
(check-equal?
(let ([x 1])
(define f (λ (a b) (set! x (+ x 1))))
(define remove-it (preferences:add-callback default-test-sym f #t))
(preferences:set default-test-sym 'xyz)
(remove-it)
(preferences:set default-test-sym 'pdq)
x)
2)
(check-equal?
(let ([x 1])
(define f (λ (a b) (set! x (+ x 1))))
(unless (zero? (random 1)) (set! f 'not-a-proc))
(define remove-it (preferences:add-callback default-test-sym f #t))
(collect-garbage) (collect-garbage) (collect-garbage)
(preferences:set default-test-sym 'xyz)
(remove-it)
(preferences:set default-test-sym 'pdq)
(f 'a 'b) ;; make sure safe-for-space doesn't free 'f' earlier
x)
3)
(check-equal?
(let ([x 1])
(define f (λ (a b) (set! x (+ x 1))))
(define wb (make-weak-box f))
(define remove-it (preferences:add-callback default-test-sym f #t))
(set! f #f)
(let loop ([n 10])
(cond
[(not (weak-box-value wb)) #t]
[(zero? n) 'f-still-alive]
[else
(collect-garbage)
(loop (- n 1))]))
(preferences:set default-test-sym 'xyz)
(remove-it)
(preferences:set default-test-sym 'pdq)
x)
1))