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

...

Browse Source 
original commit: c77b722631d483cb8dcf7df518f2366d6cbd9c78
This commit is contained in:
Robby Findler 1998-11-17 12:55:42 +00:00
parent 3e2fd130a4
commit bba6468988
5 changed files with 102 additions and 55 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/framework/framework.ss
View File

@ -2,7 +2,7 @@
(compile-allow-cond-fallthrough #t)
(compile-allow-set!-undefined #t)
(require-library "mred-interfaces.ss" "framework")
(require-library "framework.ss" "framework")
(require-library "frameworks.ss" "framework")
(invoke-open-unit/sig
(compound-unit/sig
(import)

41
collects/framework/guiutils.ss
View File

@ -107,42 +107,33 @@
(define get-choice
(opt-lambda (message true-choice false-choice [title "Warning"])
(let* ([result (void)]
[choice-dialog%
(class dialog% ()
(inherit show center)
(private
(letrec ([result (void)]
[dialog (make-object dialog% title)]
[on-true
(lambda args
(set! result #t)
(show #f))]
(send dialog show #f))]
[on-false
(lambda rags
(set! result #f)
(show #f))])
(sequence
(super-init () title #t -1 -1)
(let* ([messages
(send dialog show #f))]
[vp (make-object vertical-panel% dialog)]
[hp (make-object horizontal-panel% dialog)])
(let loop ([m message])
(let ([match (regexp-match (format "([^~n]*)~n(.*)")
(let ([match (regexp-match (format "^([^~n]*)~n(.*)")
m)])
(if match
(cons (cadr match)
(begin (make-object message% (cadr match) vp)
(loop (caddr match)))
(list m))))]
[msgs (map
(lambda (message)
(begin0
(make-object message% this message)))
messages)])
(make-object message% m vp))))
(send (make-object button% true-choice this on-true) focus)
(make-object button% false-choice this on-false)
(center 'both)
(show #t))))])
(make-object choice-dialog%)
(send vp set-alignment 'left 'center)
(send hp set-alignment 'right 'top)
(send (make-object button% true-choice hp on-true) focus)
(make-object button% false-choice hp on-false)
(send dialog center 'both)
(send dialog show #t)
result)))
(define read-snips/chars-from-buffer

8
collects/tests/framework/README
View File

@ -11,6 +11,14 @@ There will be a main mzscheme process which will start up a new mred
as necessary for the test suites. Since some tests actually require
mred to exit in order to pass, this governor is required.
To run a test use:
framework-test <test.ss> ...
where or <test.ss> is the name of one of the tests
below. Alternatively, pass no command-line arguments to run all of the
tests.
- exit: |# exit.ss #|
| This tests that exit:exit really exits and that the exit callbacks

24
collects/tests/framework/exit.ss
View File

@ -1,7 +1,17 @@
(send-sexp-to-mred '(exit:exit))
(let loop ()
(sleep 3)
(when (mred-running?)
(printf "still running~n")
(loop)))
(printf "not running~n")
(test 'exit:exit
(lambda (x) (not (and (eq? x 'passed)
(not (mred-running?)))))
(lambda ()
(with-handlers ([eof-result? (lambda (x) 'passed)])
(send-sexp-to-mred '(preferences:set 'framework:verify-exit #f))
(send-sexp-to-mred '(exit:exit))
'failed)))
(test 'exit:exit
(lambda (x) (not (and (eq? x 'passed)
(not (mred-running?)))))
(lambda ()
(with-handlers ([eof-result? (lambda (x) 'passed)])
(send-sexp-to-mred '(preferences:set 'framework:verify-exit #t))
(send-sexp-to-mred '(exit:exit))
'failed)))

54
collects/tests/framework/main.ss
View File

@ -27,6 +27,8 @@
(lambda (port)
(write 6012 port))))
(define-struct eof-result ())
(define-values (shutdown-listener shutdown-mred mred-running? send-sexp-to-mred)
(let ([listener
(let loop ()
@ -69,9 +71,14 @@
(set! in-port #f)
(set! in-port #f)))
(lambda ()
(not (eof-object? (peek-char in-port))))
(if (char-ready? in-port)
(not (eof-object? (peek-char in-port)))
#t))
(lambda (sexp)
(unless (and in-port out-port)
(unless (and in-port
out-port
(or (not (char-ready? in-port))
(not (eof-object? (peek-char in-port)))))
(restart-mred))
(write sexp out-port)
(newline out-port)
@ -89,13 +96,17 @@
(loop))
null))))))])
(read in-port))])
(unless (and (list? answer)
(= 2 (length answer)))
(error 'framework-test-suite "unpected result from mred: ~s~n" answer))
(unless (or (eof-object? answer)
(and (list? answer)
(= 2 (length answer))))
(error 'send-sexp-to-mred "unpected result from mred: ~s~n" answer))
(if (eof-object? answer)
(raise (make-eof-result))
(case (car answer)
[(error) (error 'mred (format "~a; input: ~s" (second answer) sexp))]
[(error)
(error 'send-sexp-to-mred (format "mred raised \"~a\" with input: ~s" (second answer) sexp))]
[(cant-read) (error 'mred/cant-parse (second answer))]
[(normal) (second answer)])))))))
[(normal) (second answer)]))))))))
(define section-jump void)
@ -107,7 +118,10 @@
(if (exn? x)
(exn-message x)
x))])
(failed? (eval (send-sexp-to-mred test))))])
(failed?
(if (procedure? test)
(test)
(eval (send-sexp-to-mred test)))))])
(when failed
(printf "FAILED ~a: ~a~n" test-name failed)
(case jump
@ -115,6 +129,22 @@
[(continue) (void)]
[else (jump)])))))
(define preferences-file (build-path (find-system-path 'pref-dir)
(case (system-type)
[(macos) "MrEd Preferences"]
[(windows) "mred.pre"]
[(unix) ".mred.prefs"])))
(define old-preferences-file (let-values ([(base name _2) (split-path preferences-file)])
(build-path base (string-append name ".save"))))
(when (file-exists? preferences-file)
(printf "saving preferences file ~s to ~s~n" preferences-file old-preferences-file)
(when (file-exists? old-preferences-file)
(error 'framework-test "backup preferences file exists, aborting"))
(printf "saved preferences file~n")
(copy-file preferences-file old-preferences-file))
(let ([all-files (map symbol->string (load-relative "README"))])
(for-each (lambda (x)
(when (member x all-files)
@ -130,5 +160,13 @@
(if (equal? (vector) argv)
all-files
(vector->list argv))))
(printf "restoring preferences file ~s to ~s~n" old-preferences-file preferences-file)
(when (file-exists? preferences-file)
(unless (file-exists? old-preferences-file)
(error 'framework-test "lost preferences file backup!"))
(delete-file preferences-file)
(copy-file old-preferences-file preferences-file)
(delete-file old-preferences-file))
(printf "restored preferences file~n")
(shutdown-listener)