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

made the check syntax tests more drdr friendly

Browse Source 
svn: r17928
This commit is contained in:
Robby Findler 2010-02-01 17:46:17 +00:00
parent 402886bc18
commit 102b03311e
3 changed files with 87 additions and 64 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/tests/drscheme/README.ss
View File

@ -52,6 +52,4 @@ the function, all tests will be run.
Tests the teachpacks Tests the teachpacks
|# syncheck-test.ss #|
|#))) |#)))

47
collects/tests/drscheme/drscheme-test-util.ss
View File

@ -11,7 +11,8 @@
[use-get/put-dialog (-> (-> any) path? void?)] [use-get/put-dialog (-> (-> any) path? void?)]
[set-module-language! (->* () (boolean?) void?)]) [set-module-language! (->* () (boolean?) void?)])
(provide save-drscheme-window-as (provide fire-up-drscheme
save-drscheme-window-as
do-execute do-execute
test-util-error test-util-error
poll-until poll-until
@ -93,22 +94,19 @@
(define (drscheme-frame? frame) (define (drscheme-frame? frame)
(method-in-interface? 'get-execute-button (object-interface frame))) (method-in-interface? 'get-execute-button (object-interface frame)))
(define wait-for-drscheme-frame (define (wait-for-drscheme-frame [print-message? #f])
(case-lambda (let ([wait-for-drscheme-frame-pred
[() (wait-for-drscheme-frame #t)] (lambda ()
[(print-message?) (let ([active (get-top-level-focus-window)])
(let ([wait-for-drscheme-frame-pred (if (and active
(lambda () (drscheme-frame? active))
(let ([active (get-top-level-focus-window)]) active
(if (and active #f)))])
(drscheme-frame? active)) (or (wait-for-drscheme-frame-pred)
active (begin
#f)))]) (when print-message?
(or (wait-for-drscheme-frame-pred) (printf "Select DrScheme frame~n"))
(begin (poll-until wait-for-drscheme-frame-pred)))))
(when print-message?
(printf "Select DrScheme frame~n"))
(poll-until wait-for-drscheme-frame-pred))))]))
;; wait-for-new-frame : frame [(listof eventspace) = null] -> frame ;; wait-for-new-frame : frame [(listof eventspace) = null] -> frame
;; returns the newly opened frame, waiting until old-frame ;; returns the newly opened frame, waiting until old-frame
@ -619,3 +617,18 @@
(if raised-exn? (if raised-exn?
(raise exn) (raise exn)
(apply values anss)))) (apply values anss))))
;; this is assumed to not open an windows or anything like that
;; but just to print and return.
(define orig-display-handler (error-display-handler))
(define (fire-up-drscheme)
(dynamic-require 'drscheme #f)
;; reset the uncaught exception handler to be sure we kill everything (drscheme sets it)
(uncaught-exception-handler
(λ (x)
(if (exn? x)
(orig-display-handler (exn-message x) x)
(fprintf (current-error-port) "uncaught exception ~s\n" x))
(exit 1))))

100
collects/tests/drscheme/syncheck-test.ss
View File

@ -5,20 +5,20 @@ tests involving object% are commented out, since they
trigger runtime errors in check syntax. trigger runtime errors in check syntax.
|# |#
#lang scheme/base
(module syncheck-test mzscheme
(require "drscheme-test-util.ss" (require "drscheme-test-util.ss"
string-constants/string-constant
tests/utils/gui tests/utils/gui
mzlib/etc scheme/path
mzlib/class scheme/class
mzlib/list scheme/list
mzlib/file scheme/file
mred mred
framework framework
mrlib/text-string-style-desc) mrlib/text-string-style-desc)
(provide run-test) (provide main)
;; type str/ann = (list (union symbol string) symbol) ;; type str/ann = (list (union symbol string) symbol)
;; type test = (make-test string ;; type test = (make-test string
@ -28,7 +28,7 @@ trigger runtime errors in check syntax.
(define-struct (dir-test test) ()) (define-struct (dir-test test) ())
(define build-test (define build-test
(opt-lambda (input expected [arrow-table '()]) (λ (input expected [arrow-table '()])
(make-test input expected arrow-table))) (make-test input expected arrow-table)))
;; tests : (listof test) ;; tests : (listof test)
@ -191,7 +191,6 @@ trigger runtime errors in check syntax.
("))" default-color)) ("))" default-color))
(list '((7 8) (19 20)))) (list '((7 8) (19 20))))
#;
(build-test "object%" (build-test "object%"
'(("object%" imported-syntax))) ; used to be lexically-bound-variable '(("object%" imported-syntax))) ; used to be lexically-bound-variable
(build-test "unbound-id" (build-test "unbound-id"
@ -600,7 +599,6 @@ trigger runtime errors in check syntax.
(")" default-color)) (")" default-color))
(list '((5 6) (10 11) (12 13)))) (list '((5 6) (10 11) (12 13))))
#;
(build-test "(class object% this)" (build-test "(class object% this)"
'(("(" default-color) '(("(" default-color)
("class" imported-syntax) ("class" imported-syntax)
@ -850,19 +848,29 @@ trigger runtime errors in check syntax.
("1))" default-color)) ("1))" default-color))
(list '((27 33) (19 26) (36 49) (53 59) (64 66)))))) (list '((27 33) (19 26) (36 49) (53 59) (64 66))))))
(define (run-test) (define (main)
(check-language-level #rx"Pretty") (let ([s (make-semaphore 0)])
(let* ([drs (wait-for-drscheme-frame)] (thread
[defs (send drs get-definitions-text)] (λ ()
[filename (make-temporary-file "syncheck-test~a")]) (let ([drs (wait-for-drscheme-frame)])
(let-values ([(dir _1 _2) (split-path filename)]) (set-language-level! (list "Pretty Big"))
(send defs save-file filename) (do-execute drs)
(preferences:set 'framework:coloring-active #f) (let* ([defs (send drs get-definitions-text)]
(for-each (run-one-test (normalize-path dir)) tests) [filename (make-temporary-file "syncheck-test~a")])
(preferences:set 'framework:coloring-active #t) (let-values ([(dir _1 _2) (split-path filename)])
(send defs save-file) ;; clear out autosave (send defs save-file filename)
(send defs set-filename #f) (preferences:set 'framework:coloring-active #f)
(delete-file filename)))) (for-each (run-one-test (normalize-path dir)) tests)
(preferences:set 'framework:coloring-active #t)
(send defs save-file) ;; clear out autosave
(send defs set-filename #f)
(delete-file filename)
;; let the app die.
(semaphore-post s))))))
(fire-up-drscheme)
(yield s)
(printf "Tests complete.\n")
(exit)))
(define ((run-one-test save-dir) test) (define ((run-one-test save-dir) test)
(let* ([drs (wait-for-drscheme-frame)] (let* ([drs (wait-for-drscheme-frame)]
@ -885,8 +893,9 @@ trigger runtime errors in check syntax.
(error 'syncheck-test.ss "still in edit sequence for ~s" input)) (error 'syncheck-test.ss "still in edit sequence for ~s" input))
(when (send drs syncheck:error-report-visible?) (when (send drs syncheck:error-report-visible?)
(printf "FAILED ~s\n error report window is visible\n" (fprintf (current-error-port)
input)) "FAILED ~s\n error report window is visible\n"
input))
;; need to check for syntax error here ;; need to check for syntax error here
(let ([got (get-annotated-output drs)]) (let ([got (get-annotated-output drs)])
@ -940,41 +949,42 @@ trigger runtime errors in check syntax.
(define (compare-arrows test-exp expected raw-actual) (define (compare-arrows test-exp expected raw-actual)
(when expected (when expected
(let () (let ()
(define already-checked (make-hash-table 'equal)) (define already-checked (make-hash))
(define actual-ht (make-hash-table 'equal)) (define actual-ht (make-hash))
(define stupid-internal-define-syntax1 (define stupid-internal-define-syntax1
(hash-table-for-each raw-actual (hash-for-each raw-actual
(lambda (k v) (lambda (k v)
(hash-table-put! actual-ht (cdr k) (hash-set! actual-ht (cdr k)
(sort (map cdr v) (sort (map cdr v)
(lambda (x y) (< (car x) (car y)))))))) (lambda (x y) (< (car x) (car y))))))))
(define expected-ht (make-hash-table 'equal)) (define expected-ht (make-hash))
(define stupid-internal-define-syntax2 (define stupid-internal-define-syntax2
(for-each (lambda (binding) (hash-table-put! expected-ht (car binding) (cdr binding))) (for-each (lambda (binding) (hash-set! expected-ht (car binding) (cdr binding)))
expected)) expected))
;; binding-in-ht? : hash-table (list number number) (listof (list number number)) -> boolean ;; binding-in-ht? : hash-table (list number number) (listof (list number number)) -> boolean
(define (test-binding expected? ht) (define (test-binding expected? ht)
(lambda (pr) (lambda (pr)
(let ([frm (car pr)] (let ([frm (car pr)]
[to (cdr pr)]) [to (cdr pr)])
(hash-table-get (hash-ref
already-checked already-checked
frm frm
(lambda () (lambda ()
(hash-table-put! already-checked frm #t) (hash-set! already-checked frm #t)
(let ([ht-ent (hash-table-get ht frm (lambda () 'nothing-there))]) (let ([ht-ent (hash-ref ht frm (lambda () 'nothing-there))])
(unless (equal? ht-ent to) (unless (equal? ht-ent to)
(printf (if expected? (fprintf (current-error-port)
"FAILED arrow test ~s from ~s\n expected ~s\n actual ~s\n" (if expected?
"FAILED arrow test ~s from ~s\n actual ~s\n expected ~s\n") "FAILED arrow test ~s from ~s\n expected ~s\n actual ~s\n"
"FAILED arrow test ~s from ~s\n actual ~s\n expected ~s\n")
test-exp test-exp
frm frm
ht-ent ht-ent
to)))))))) to))))))))
(for-each (test-binding #t expected-ht) (hash-table-map actual-ht cons)) (for-each (test-binding #t expected-ht) (hash-map actual-ht cons))
(for-each (test-binding #f actual-ht) (hash-table-map expected-ht cons))))) (for-each (test-binding #f actual-ht) (hash-map expected-ht cons)))))
(define (compare-output raw-expected got arrows arrows-got input) (define (compare-output raw-expected got arrows arrows-got input)
(let ([expected (collapse-and-rename raw-expected)]) (let ([expected (collapse-and-rename raw-expected)])
@ -982,8 +992,9 @@ trigger runtime errors in check syntax.
[(equal? got expected) [(equal? got expected)
(compare-arrows input arrows arrows-got)] (compare-arrows input arrows arrows-got)]
[else [else
(printf "FAILED: ~s\n expected: ~s\n got: ~s\n" (fprintf (current-error-port)
input expected got)]))) "FAILED: ~s\n expected: ~s\n got: ~s\n"
input expected got)])))
;; get-annotate-output : drscheme-frame -> (listof str/ann) ;; get-annotate-output : drscheme-frame -> (listof str/ann)
(define (get-annotated-output drs) (define (get-annotated-output drs)
@ -991,5 +1002,6 @@ trigger runtime errors in check syntax.
(queue-callback (queue-callback
(λ () (λ ()
(channel-put chan (get-string/style-desc (send drs get-definitions-text))))) (channel-put chan (get-string/style-desc (send drs get-definitions-text)))))
(channel-get chan)))) (channel-get chan)))
(main)