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)

63
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
[on-true
(lambda args
(set! result #t)
(show #f))]
[on-false
(lambda rags
(set! result #f)
(show #f))])
(sequence
(super-init () title #t -1 -1)
(let* ([messages
(let loop ([m message])
(let ([match (regexp-match (format "([^~n]*)~n(.*)")
m)])
(if match
(cons (cadr match)
(loop (caddr match)))
(list m))))]
[msgs (map
(lambda (message)
(begin0
(make-object message% this message)))
messages)])
(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%)
(letrec ([result (void)]
[dialog (make-object dialog% title)]
[on-true
(lambda args
(set! result #t)
(send dialog show #f))]
[on-false
(lambda rags
(set! result #f)
(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(.*)")
m)])
(if match
(begin (make-object message% (cadr match) vp)
(loop (caddr match)))
(make-object message% m vp))))
(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

10
collects/tests/framework/README
View File

@ -9,7 +9,15 @@ All of these tests reside in PLTHOME/tests/framework/
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.
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 #|

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)))

58
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))
(case (car answer)
[(error) (error 'mred (format "~a; input: ~s" (second answer) sexp))]
[(cant-read) (error 'mred/cant-parse (second answer))]
[(normal) (second 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 '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)]))))))))
(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)