Restoring, for now.
svn: r5221
This commit is contained in:
Eli Barzilay
parent
301e6e9ecb
commit
5cc51c18dd
14
collects/test-suite/extension.ss
Normal file
14
collects/test-suite/extension.ss
Normal file
|
|
@ -0,0 +1,14 @@
|
|||
|
||||
(module extension mzscheme
|
||||
(provide add-test-suite-extension
|
||||
test-suite-extensions)
|
||||
|
||||
(define (add-test-suite-extension button icon callback)
|
||||
(test-suite-extensions (append
|
||||
(test-suite-extensions)
|
||||
(list (list button icon callback)))))
|
||||
|
||||
(define test-suite-extensions (make-parameter null)))
|
||||
|
||||
|
||||
|
||||
6
collects/test-suite/info.ss
Normal file
6
collects/test-suite/info.ss
Normal file
|
|
@ -0,0 +1,6 @@
|
|||
(module info (lib "infotab.ss" "setup")
|
||||
(define name "Test Suite")
|
||||
(define tools '(("tool.ss")))
|
||||
(define tool-names (list "The Test Suite Tool"))
|
||||
(define tool-icons (list '("question-mark.png" "test-suite" "private" "icons")))
|
||||
)
|
||||
38
collects/test-suite/private/convert-to-string.ss
Normal file
38
collects/test-suite/private/convert-to-string.ss
Normal file
|
|
@ -0,0 +1,38 @@
|
|||
#| This module provides a mixin that gives a snip a method called convert-to-string.
|
||||
This method finds the editor that contains the snip and if it's a text it replaces
|
||||
the snip with a string in that editor.
|
||||
|#
|
||||
|
||||
(module convert-to-string mzscheme
|
||||
|
||||
(require
|
||||
(lib "class.ss")
|
||||
(lib "mred.ss" "mred")
|
||||
(lib "framework.ss" "framework")
|
||||
(lib "embedded-gui.ss" "embedded-gui")
|
||||
(lib "contract.ss"))
|
||||
|
||||
(provide/contract
|
||||
(convert-to-string-mixin mixin-contract)
|
||||
(convert-to-string<%> interface?))
|
||||
|
||||
(define convert-to-string<%>
|
||||
(interface ()
|
||||
convert-to-string))
|
||||
|
||||
(define convert-to-string-mixin
|
||||
(mixin ((class->interface snip%)) (convert-to-string<%>)
|
||||
(inherit get-admin get-text)
|
||||
|
||||
(define/public (convert-to-string str)
|
||||
(let ([to-ed (snip-parent this)])
|
||||
(when (is-a? to-ed text%)
|
||||
(let ([this-pos (send to-ed get-snip-position this)])
|
||||
(when this-pos
|
||||
(send to-ed begin-edit-sequence)
|
||||
(send to-ed delete this-pos (add1 this-pos))
|
||||
(send to-ed insert (string-length str) str this-pos)
|
||||
(send to-ed end-edit-sequence))))))
|
||||
|
||||
(super-new)))
|
||||
)
|
||||
38
collects/test-suite/private/doc/ChangeLog
Normal file
38
collects/test-suite/private/doc/ChangeLog
Normal file
|
|
@ -0,0 +1,38 @@
|
|||
2003/12/18
|
||||
* Fixed the bug where fixed width lables didn't fit in their extents.
|
||||
* Made the test-box take the caret when inserted.
|
||||
* Made error reporting for out of context test-cases highlight the box.
|
||||
* Made tabbing work.
|
||||
|
||||
2003/12/16
|
||||
* Made the aligned-pasteboards work
|
||||
|
||||
2003/11/17
|
||||
* Made event handling of the pasteboards work differently
|
||||
|
||||
2003/11/13
|
||||
* Added tabbing.
|
||||
* Corrected the handling of multiple values in test case boxes.
|
||||
* Made the empty test case error hightlight the full test case. It'd be
|
||||
better to have it highlight just the part of the test case that is empty
|
||||
but this is not possible with the current error highlighting system.
|
||||
|
||||
2003/10/??
|
||||
* Changed the test-suite tool to make test-case-boxes.
|
||||
|
||||
2003/04/23
|
||||
* Added code highlighting to the "Too many expressions in a test box
|
||||
error message
|
||||
|
||||
2003/04/16
|
||||
* Added a ChangeLog
|
||||
* Added a seperator to the language menu
|
||||
* Removed model and window directories from private
|
||||
* Added an open button which opens the program being tested in drscheme. If
|
||||
the file is already open in a drscheme window, it uses the existing one.
|
||||
* Fixed tabbing so that snips that are off screen are scrolled to when
|
||||
they are tabbed to.
|
||||
* Made the save button appear when the program to test box gets modified.
|
||||
* Made the save button not appear when the test-suite is just loaded.
|
||||
* Documented aligned-snip-mixin and click-forwarding-mixin in the doc.txt
|
||||
of the mrlib collection.
|
||||
59
collects/test-suite/private/doc/TODO
Normal file
59
collects/test-suite/private/doc/TODO
Normal file
|
|
@ -0,0 +1,59 @@
|
|||
;;;;;;;;;;
|
||||
;; Todo ;;
|
||||
;;;;;;;;;;
|
||||
|
||||
multiview:
|
||||
It'd be cool to allow multiple views of the test suite
|
||||
|
||||
errorboxes: future
|
||||
Need to have boxes that handle errors.
|
||||
|
||||
output:
|
||||
need to handle output (side effect) of test calls. Maybe not.
|
||||
|
||||
stepper: future
|
||||
allow easy addition of break points and stepping of the testcases.
|
||||
|
||||
language-pref: future
|
||||
Make a language level preference to execute or not execute the test cases.
|
||||
Maybe just do it in debug mode? Actually, probablly just have a preference
|
||||
to remember wether or not they have enabled or disabled test cases by
|
||||
default.
|
||||
|
||||
disable: future
|
||||
add a button to disable a test case.
|
||||
|
||||
error-no-stop:
|
||||
when a test cases raises exception don't stop at all even it is not expected
|
||||
just make it fail or even flag it as raising an error. This could be a
|
||||
preference really.
|
||||
|
||||
project:
|
||||
want to be able to run a lot of test-suites from the command line. Also sould
|
||||
have a digest of number of tests failed or succeed at the end of a run.
|
||||
|
||||
scheme-unit:
|
||||
integrate with scheme unit
|
||||
|
||||
;;;;;;;;;;
|
||||
;; Bugs ;;
|
||||
;;;;;;;;;;
|
||||
|
||||
namespace: robby
|
||||
Adding the test-case macro to the top-level require makes test-cases in
|
||||
modules not see the macro and fail to execute. Test-cases don't work in
|
||||
beginner level because require makes no sence.
|
||||
|
||||
mouse-cursor: important
|
||||
If you mouse down on a text box and mouse up in another, the cursor
|
||||
appears in the second text box.
|
||||
|
||||
mouse-off: important, robby
|
||||
If you mouse down on a button snip and move the mouse off, the button
|
||||
stays depressed.
|
||||
|
||||
This may be the same as what you describe below, but when I type this:
|
||||
(let loop () (loop)) into a test case window and then type more close
|
||||
parens after that, things vibrate in a strange way.
|
||||
|
||||
test-suite entry boxes are not locked when the program is executing
|
||||
160
collects/test-suite/private/doc/old-todo
Normal file
160
collects/test-suite/private/doc/old-todo
Normal file
|
|
@ -0,0 +1,160 @@
|
|||
######################################################################
|
||||
Immediate TODO list:
|
||||
######################################################################
|
||||
To highlight test-cases that are currently selected, use the same method
|
||||
as in test-text. Only color the snip though, not the editor. This will
|
||||
fill in the places in the snip that don't have children snips on it.
|
||||
--------------
|
||||
To enable and disable the delete snip button use the on-focus or on
|
||||
not-focus of the test-cases. do something clever to avoid the blinking of
|
||||
the delete button between off-focus and on-focus.
|
||||
--------------
|
||||
make GUI-monkey test-suite for test-suite
|
||||
--------------
|
||||
make a better test-suite window using editor-mixin
|
||||
and derive a controller from it, not the way I
|
||||
am currently doing it. (this will give undo/redo)
|
||||
--------------
|
||||
figure out the problem with resized overloading
|
||||
and a clean way to fix it.
|
||||
--------------
|
||||
override on-default-event of the pasteboard if it's not needed
|
||||
so that all the funny selection and movement doesn't happen.
|
||||
-------------------
|
||||
On Mon, Nov 18, 2002 at 03:03:49PM -0600, Robert Bruce Findler wrote:
|
||||
> Make deletion actually set the focus to another one of the snips, so I
|
||||
> can keep deleting.
|
||||
-------------------
|
||||
> Also, it may look better to remove the outer box entirely and just have
|
||||
> lines between the test case items (or even not, if you can figure out
|
||||
> the background colors)
|
||||
-------------------
|
||||
* There's a problem with handling mouse-button releases. They seem to
|
||||
be handled like clicks. For example, drag a selection in "Expected",
|
||||
but release the mouse in "Call". The selection will move to "Call".
|
||||
|
||||
Matthew
|
||||
-------------------
|
||||
- after xcuting and receiving checks for all tests, edit an expected value
|
||||
and see whether you get a save button
|
||||
------------------
|
||||
|
||||
######################################################################
|
||||
Nonimmediate TODO:
|
||||
######################################################################
|
||||
disable the open button when there is no program to test in the text box
|
||||
-------------------
|
||||
make undo/redo work
|
||||
-------------------
|
||||
have the 'special' menu in the test-suite tool so that
|
||||
one might add xml boxes to test-suites for instance.
|
||||
-------------------
|
||||
Disable the open button when there is nothing in the program to test box
|
||||
-------------------
|
||||
Refactor languaged frame unit so that it does not depend on the model but
|
||||
instread stores the language and teachpacks in it's own fields and may be
|
||||
used by DrScheme as a general mixin to add language support to windows.
|
||||
-------------------
|
||||
add support for the test definitions boxes.
|
||||
-------------------
|
||||
One thing I noticed about your tester: it doesn't seem to use Robby's
|
||||
string-constants system. So all the menus and buttons and stuff you
|
||||
have will always be in English, which will look weird to people who
|
||||
use DrScheme with another language.
|
||||
|
||||
Philippe
|
||||
-------------------
|
||||
Give better error message on bad file loading.(message box?)
|
||||
disallow newlines in program to file box
|
||||
-------------------
|
||||
It'd also be really nice to have a Stepper associated with individual
|
||||
test cases -- this is currently a pain with the stepper (I have to
|
||||
step through old runs to get to new ones, or putz around with
|
||||
commenting code). With the testing facility you have just the right
|
||||
interface to make the stepper highly usable!
|
||||
----------------
|
||||
Programs aren't associated with the buffer that is open (like the REPL) They
|
||||
are associated with the saved file. This is confusing when you change a
|
||||
program and expect it's test to behave differently in the test window.
|
||||
Currently you must save it. Should there either be an "out of syn" warning
|
||||
or a way to read straight from the buffer?
|
||||
-----------------
|
||||
I think that there is too much whitespace around the boxes, too. It'd
|
||||
be nicer to use color to separate the lines and get back some screen
|
||||
"real estate".
|
||||
|
||||
Robby
|
||||
-----------------
|
||||
make the test-suite not halt on a failure?
|
||||
-----------------
|
||||
- we need to be able to associate a test suite with more than one
|
||||
definitions window (say we reimplement a module to improve its
|
||||
performance. it should pass the same functionality tests)
|
||||
------------------
|
||||
Pls add a checkbox so that you can turn off individual tests
|
||||
or skip tests that fail. -- Matthias
|
||||
------------------
|
||||
|
||||
######################################################################
|
||||
Unknown:
|
||||
######################################################################
|
||||
I've done a first cut of io in the test suite. It doesn't do everything
|
||||
-- here are some TODOs for you:
|
||||
|
||||
- hide last newline (like in value printer)
|
||||
- remove IO boxes when executing
|
||||
- fix the `(lambda () (send this ...)' hack
|
||||
|
||||
The last one needs some re-organization, I believe. I'll let you think
|
||||
about it.
|
||||
|
||||
Also, I noticed that execute doesn't shutdown the old custodian, so
|
||||
frames and things created in previous tests are still around in the new
|
||||
test. (This also means that there is a memory leak!)
|
||||
|
||||
That's already on your list, right?
|
||||
|
||||
Robby
|
||||
-----------------
|
||||
For your TODO list, please. :)
|
||||
|
||||
It would be nice if there was a little turn down triangle in the test
|
||||
cases that would collapse the entire case to just the triangle. If
|
||||
adjacent test cases were collapsed, they would sit next to each other
|
||||
horizontally (ie, leave more vertical room). When executing, if the
|
||||
test case passes and it was closed, it stays closed, but if it fails
|
||||
and it was closed, it pops open.
|
||||
|
||||
What do you think?
|
||||
-----------------
|
||||
When I create a new case, the tester installs a huge big question
|
||||
mark. It's cute [so are the cross and check -- these will probably be
|
||||
a big hit with kids -- whoever designed them did a great job!], but
|
||||
(a) I think they're too large; and (b) I think the ? is misleading.
|
||||
Something about ?'s shape, size and location makes me think it must be
|
||||
a button. (Location, especially -- it's exactly where I would expect
|
||||
the "Submit" button on a Web form.) I clicked on it a few times, but
|
||||
nothing happened. Then I remembered that there'd been an Execute
|
||||
button at the top, clicked on it, and saw the outcome. In other
|
||||
words, I expected ? to play the role of Execute.
|
||||
-sk
|
||||
-------------------
|
||||
The box under Actual surprised me multiple times. After entering a
|
||||
value for Call and for Expected, I was surprised to find tabbing and
|
||||
typing do nothing. The color change just tells me "this is special"
|
||||
(eg, where you enter your SSN on a govt form); the box still tells me
|
||||
"this is a place you enter text". Can you remove the box entirely
|
||||
from below Actual? In fact, if Actual and the output never appeared
|
||||
until you executed the program, that may be even better.
|
||||
-sk
|
||||
----------------
|
||||
BUG: I wanted to make the second test case buggy (but not lose the
|
||||
subsequent ones). So I clicked on the box around the first one, which
|
||||
showed me little highlight points around the box. I tried to move it,
|
||||
but nothing happened. Then I went to the scroll bar and tried to
|
||||
scroll somewhere in that region, but got a MrEd toolbox method error,
|
||||
and now the screen won't redraw. I'll try to reproduce it. ... Okay,
|
||||
did so successfully, I'll send in a bug report. Anyway, it'd be nice
|
||||
to reorder cases. It'd be especially neat the reorder by
|
||||
success/failure.
|
||||
-------------------
|
||||
38
collects/test-suite/private/find-scheme-menu.ss
Normal file
38
collects/test-suite/private/find-scheme-menu.ss
Normal file
|
|
@ -0,0 +1,38 @@
|
|||
;; This code is duplicated from the servelt-builder.ss file
|
||||
(module find-scheme-menu mzscheme
|
||||
|
||||
(provide find-scheme-menu)
|
||||
|
||||
(require
|
||||
(lib "class.ss")
|
||||
(lib "mred.ss" "mred")
|
||||
(lib "string-constant.ss" "string-constants"))
|
||||
|
||||
; : menu% -> (U menu% #f)
|
||||
; to crawl up and down the menu hierarcy to find the scheme menu
|
||||
; This attempts to work even if
|
||||
; a) the menus and menu items are in a different langauge
|
||||
; b) the menus are in Philippe's language where they are all blank (and hence the same)
|
||||
; It starts by selecting the menu by position to avoid problem b).
|
||||
; Just to be paranoid, it looks in other positions, too.
|
||||
; The scheme menu must have "Create Executable..." in some language as a menu item.
|
||||
(define (find-scheme-menu special-menu)
|
||||
(let* ([bar (send special-menu get-parent)]
|
||||
[menus (send bar get-items)]
|
||||
[ordered-menus (if (< (length menus) 5)
|
||||
menus
|
||||
(cons (car (cddddr menus)) menus))])
|
||||
(ormap (lambda (m)
|
||||
(and (string=? (label->plain-label (string-constant scheme-menu-name))
|
||||
(send m get-plain-label))
|
||||
(ormap is-create-executable-item? (send m get-items))
|
||||
m))
|
||||
ordered-menus)))
|
||||
|
||||
|
||||
; menu-item% -> bool
|
||||
(define (is-create-executable-item? item)
|
||||
(and (is-a? item labelled-menu-item<%>)
|
||||
(string=? (string-constant create-executable-menu-item-label)
|
||||
(send item get-label))))
|
||||
)
|
||||
BIN
collects/test-suite/private/icons/check-mark.jpeg
Normal file
BIN
collects/test-suite/private/icons/check-mark.jpeg
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 718 B |
BIN
collects/test-suite/private/icons/checkbox_enabled_checked.gif
Normal file
BIN
collects/test-suite/private/icons/checkbox_enabled_checked.gif
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 856 B |
Binary file not shown.
|
After Width: | Height: | Size: 846 B |
BIN
collects/test-suite/private/icons/cross.jpeg
Normal file
BIN
collects/test-suite/private/icons/cross.jpeg
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 813 B |
BIN
collects/test-suite/private/icons/empty.jpeg
Normal file
BIN
collects/test-suite/private/icons/empty.jpeg
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 284 B |
BIN
collects/test-suite/private/icons/question-mark.jpeg
Normal file
BIN
collects/test-suite/private/icons/question-mark.jpeg
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 737 B |
BIN
collects/test-suite/private/icons/question-mark.png
Normal file
BIN
collects/test-suite/private/icons/question-mark.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 1.3 KiB |
BIN
collects/test-suite/private/icons/small-check-mark.jpeg
Normal file
BIN
collects/test-suite/private/icons/small-check-mark.jpeg
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 412 B |
BIN
collects/test-suite/private/icons/small-cross.jpeg
Normal file
BIN
collects/test-suite/private/icons/small-cross.jpeg
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 433 B |
BIN
collects/test-suite/private/icons/small-empty.gif
Normal file
BIN
collects/test-suite/private/icons/small-empty.gif
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 46 B |
BIN
collects/test-suite/private/icons/small-no.gif
Normal file
BIN
collects/test-suite/private/icons/small-no.gif
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 139 B |
2
collects/test-suite/private/info.ss
Normal file
2
collects/test-suite/private/info.ss
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
(module info (lib "infotab.ss" "setup")
|
||||
(define name "Test Suite private"))
|
||||
36
collects/test-suite/private/make-snipclass.ss
Normal file
36
collects/test-suite/private/make-snipclass.ss
Normal file
|
|
@ -0,0 +1,36 @@
|
|||
(module make-snipclass mzscheme
|
||||
|
||||
(require
|
||||
(lib "etc.ss")
|
||||
(lib "mred.ss" "mred")
|
||||
(lib "class.ss")
|
||||
(lib "contract.ss"))
|
||||
|
||||
(define read-proc? (class? (is-a?/c editor-stream-in%) . -> . object?))
|
||||
|
||||
(provide/contract
|
||||
(make-snipclass ((class? string?) (read-proc?) . opt-> . (is-a?/c snip-class%)))
|
||||
(send-read-from-file read-proc?))
|
||||
|
||||
;; Creats a snipclass and registers it with the snip class list
|
||||
(define make-snipclass
|
||||
(opt-lambda (class% classname (read-proc send-read-from-file))
|
||||
(let* ([abstract-snip-class%
|
||||
(class snip-class%
|
||||
#;((is-a?/c editor-stream-in%) . -> . (is-a?/c interactions-box%))
|
||||
;; Produces an interaction box from the given file stream
|
||||
(define/override (read f)
|
||||
(read-proc class% f))
|
||||
(super-new))]
|
||||
[sc (new abstract-snip-class%)])
|
||||
(send sc set-classname classname)
|
||||
(send sc set-version 2)
|
||||
(send (get-the-snip-class-list) add sc)
|
||||
sc)))
|
||||
|
||||
;; Returns an object of class after reading its contents from the given stream
|
||||
(define (send-read-from-file class% f)
|
||||
(let ([object (new class%)])
|
||||
(send object read-from-file f)
|
||||
object))
|
||||
)
|
||||
62
collects/test-suite/private/print-to-text.ss
Normal file
62
collects/test-suite/private/print-to-text.ss
Normal file
|
|
@ -0,0 +1,62 @@
|
|||
(module print-to-text mzscheme
|
||||
|
||||
(require
|
||||
(lib "list.ss")
|
||||
(lib "etc.ss")
|
||||
(lib "class.ss")
|
||||
(lib "contract.ss")
|
||||
(lib "unit.ss")
|
||||
(lib "mred.ss" "mred")
|
||||
(lib "framework.ss" "framework")
|
||||
(lib "tool.ss" "drscheme"))
|
||||
|
||||
(provide print-to-text^
|
||||
print-to-text@)
|
||||
|
||||
(define-signature print-to-text^
|
||||
(print-to-text))
|
||||
|
||||
(define-unit print-to-text@
|
||||
|
||||
(import drscheme:tool^)
|
||||
(export print-to-text^)
|
||||
;; Using the current languages print operations, print the list of values to the text
|
||||
(define (print-to-text atext vals)
|
||||
(unless (empty? vals)
|
||||
(send* atext
|
||||
(begin-edit-sequence)
|
||||
(erase))
|
||||
(let ([port
|
||||
(make-output-port
|
||||
'set-actuals
|
||||
always-evt
|
||||
(lambda (s start end block? enable-breaks?)
|
||||
(send atext insert
|
||||
(list->string
|
||||
(map integer->char
|
||||
(bytes->list (subbytes s start end)))))
|
||||
(- end start))
|
||||
void
|
||||
(lambda (v block? enable-breaks?)
|
||||
(if (v . is-a? . snip%)
|
||||
(send atext insert v)
|
||||
(send atext insert (format "~s" v)))
|
||||
#t))])
|
||||
(define (print-one v)
|
||||
(let* ([language-settings
|
||||
(preferences:get
|
||||
(drscheme:language-configuration:get-settings-preferences-symbol))]
|
||||
[language
|
||||
(drscheme:language-configuration:language-settings-language
|
||||
language-settings)]
|
||||
[settings
|
||||
(drscheme:language-configuration:language-settings-settings
|
||||
language-settings)])
|
||||
(send language render-value v settings port)))
|
||||
(print-one (first vals))
|
||||
(for-each
|
||||
(lambda (val)
|
||||
(newline port)
|
||||
(print-one val))
|
||||
(rest vals)))
|
||||
(send atext end-edit-sequence)))))
|
||||
586
collects/test-suite/private/test-case-box.ss
Normal file
586
collects/test-suite/private/test-case-box.ss
Normal file
|
|
@ -0,0 +1,586 @@
|
|||
#| Note: Test cases have a lot of state like the to-test, predicate, etc. I need to find a way
|
||||
to not have to maintain this list of state in many places. It's not as simple as a global
|
||||
list, however, because they need to be instantiation variables, etc.
|
||||
|#
|
||||
(module test-case-box mzscheme
|
||||
|
||||
(provide test-case-box^ test-case-box@)
|
||||
|
||||
(require
|
||||
(lib "class.ss")
|
||||
(lib "list.ss")
|
||||
(lib "mred.ss" "mred")
|
||||
(lib "unit.ss")
|
||||
(lib "tool.ss" "drscheme")
|
||||
(lib "etc.ss")
|
||||
(lib "match.ss")
|
||||
(lib "framework.ss" "framework")
|
||||
(lib "readerr.ss" "syntax")
|
||||
(lib "string-constant.ss" "string-constants")
|
||||
(lib "embedded-gui.ss" "embedded-gui")
|
||||
(lib "shared.ss" "stepper" "private")
|
||||
"make-snipclass.ss"
|
||||
"convert-to-string.ss"
|
||||
"text-syntax-object.ss"
|
||||
"print-to-text.ss"
|
||||
"test-case.ss"
|
||||
(only (lib "teachprims.ss" "lang" "private") beginner-equal?))
|
||||
|
||||
(define-signature test-case-box^ extends drscheme:tool-exports^ (test-case-box%))
|
||||
(define-unit test-case-box@
|
||||
(import drscheme:tool^ text->syntax-object^ print-to-text^)
|
||||
(export test-case-box^)
|
||||
(define test-case:program-editor% false)
|
||||
|
||||
(define (phase1) (void))
|
||||
(define (phase2)
|
||||
(set! test-case:program-editor%
|
||||
(init-text-mixin
|
||||
(tabbable-text-mixin
|
||||
((drscheme:unit:get-program-editor-mixin)
|
||||
scheme:text%)))))
|
||||
|
||||
;; The test case box that is inserted into the drscheme frame
|
||||
(define test-case-box%
|
||||
(class* (on-show-editor-snip-mixin
|
||||
(convert-to-string-mixin
|
||||
(decorated-editor-snip-mixin editor-snip%))) (readable-snip<%>)
|
||||
(inherit get-admin convert-to-string)
|
||||
|
||||
;; A text that will uncollapse the test case when it is highlighted for an error
|
||||
(define error-alert-text%
|
||||
(class test-case:program-editor%
|
||||
(define/override highlight-range
|
||||
(opt-lambda (start end color (bitmap false) (caret-space false) (priority 'low))
|
||||
(when collapsed? (collapse false))
|
||||
(super highlight-range start end color bitmap caret-space priority)))
|
||||
(super-new)))
|
||||
|
||||
(init-field
|
||||
[enabled? true]
|
||||
[actual-show? false]
|
||||
[collapsed? false]
|
||||
[show-right-pane? false]
|
||||
[error-box? false]
|
||||
[to-test (new error-alert-text%)]
|
||||
[expected (new error-alert-text%)]
|
||||
[predicate (new error-alert-text% (text ""))]
|
||||
[should-raise (new error-alert-text% (text ""))]
|
||||
[error-message (new error-alert-text%)])
|
||||
|
||||
#;(any? (union integer? false?) (union integer? false?) (union integer? false?) . -> . any?)
|
||||
;; Called by the execution to get a syntax object that represents this box.
|
||||
(define/public read-special
|
||||
(opt-lambda (source (line false) (column false) (position false))
|
||||
#;((is-a?/c text%) . -> . syntax-object?)
|
||||
;; Creates a single syntax object out of the text or raises read-error
|
||||
(define (text->syntax-object text default-content)
|
||||
(match (text->syntax-objects text default-content)
|
||||
[() (raise-read-error (string-constant test-case-empty-error)
|
||||
source line false position 1)]
|
||||
[(stx) stx]
|
||||
[(stx next rest-stx ...)
|
||||
(raise-read-error (string-constant test-case-too-many-expressions-error)
|
||||
text
|
||||
(syntax-line next)
|
||||
(syntax-column next)
|
||||
(syntax-position next)
|
||||
(syntax-span next))]))
|
||||
(syntax-property
|
||||
(if enabled?
|
||||
(with-syntax ([to-test-stx (stepper-syntax-property (text->syntax-object to-test #f)
|
||||
'stepper-test-suite-hint
|
||||
true)]
|
||||
[update-stx (lambda (x) (update x))] ; eta public method
|
||||
[set-actuals-stx set-actuals]
|
||||
[w printf])
|
||||
(if error-box?
|
||||
(with-syntax ([exn-pred-stx (text->syntax-object should-raise #'exn:fail?)]
|
||||
[exn-handler-stx
|
||||
(if (empty-text? error-message)
|
||||
#'(lambda (v) true)
|
||||
#`(lambda (v)
|
||||
(equal? (exn-message v)
|
||||
#,(text->syntax-object
|
||||
error-message
|
||||
#f))))])
|
||||
(syntax/loc (datum->syntax-object
|
||||
false 'ignored (list source line column position 1))
|
||||
(test-error-case to-test-stx
|
||||
exn-pred-stx
|
||||
exn-handler-stx
|
||||
update-stx
|
||||
set-actuals-stx)))
|
||||
(with-syntax ([exp-stx (text->syntax-object expected #f)]
|
||||
[pred-stx (text->syntax-object predicate beginner-equal?)])
|
||||
(syntax/loc (datum->syntax-object
|
||||
false 'ignored (list source line column position 1))
|
||||
(test-case pred-stx
|
||||
to-test-stx
|
||||
exp-stx
|
||||
update-stx
|
||||
set-actuals-stx)))))
|
||||
(stepper-syntax-property #'(define-values () (values))
|
||||
'stepper-skip-completely
|
||||
true))
|
||||
'test-case-box #t)))
|
||||
|
||||
#;(boolean? . -> . void?)
|
||||
;; sets the test case to the proper result bassed on if it was correct
|
||||
(define/public (update pass?)
|
||||
(send result update (if pass? 'pass 'fail)))
|
||||
|
||||
#;(-> void?)
|
||||
;; resets the state of the test case
|
||||
(define/public (reset)
|
||||
(send pb lock-alignment true)
|
||||
(send* actual
|
||||
(lock false)
|
||||
(erase)
|
||||
(lock true))
|
||||
(when enabled?
|
||||
(send result update 'unknown))
|
||||
(send pb lock-alignment false))
|
||||
|
||||
#;(boolean? . -> . void?)
|
||||
;; enables or disables the test case
|
||||
(define/public (enable enable?)
|
||||
(unless (boolean=? enabled? enable?)
|
||||
(if enable?
|
||||
(begin (set! enabled? true)
|
||||
(send result update 'unknown))
|
||||
(begin (set! enabled? false)
|
||||
(reset)
|
||||
(send result update 'disabled)))))
|
||||
|
||||
#;(-> void)
|
||||
;; tells the test-box to take the caret
|
||||
(define/public (take-caret)
|
||||
(send pb set-caret-owner
|
||||
(send (send to-test get-admin) get-snip)
|
||||
'display))
|
||||
|
||||
#;(-> string)
|
||||
;; The textual representation of this test-case
|
||||
;; STATUS: Begginner language doesn't have with-handlers
|
||||
;; STATUS: Pretty printing not here yet.
|
||||
(define (get-string)
|
||||
(if error-box?
|
||||
"Not yet implemented. What to do in beginner?"
|
||||
(format "(~a ~a ~a)"
|
||||
(send predicate get-text)
|
||||
(send to-test get-text)
|
||||
(send expected get-text))))
|
||||
|
||||
#;((is-a?/c expand-program%) (listof any?) . -> . void?)
|
||||
;; set the text in the actual field to the value given
|
||||
;; STATUS: Ensure the edit-sequence is needed.
|
||||
(define (set-actuals vals)
|
||||
(send (send (get-admin) get-editor) begin-edit-sequence)
|
||||
(send actual lock false)
|
||||
(print-to-text actual vals)
|
||||
(send actual lock true)
|
||||
(send (send (get-admin) get-editor) end-edit-sequence))
|
||||
|
||||
;;;;;;;;;;
|
||||
;; Saving and Copying
|
||||
|
||||
#;(-> (is-a?/c test-case-box%))
|
||||
;; Called by drscheme to copy and paste this test-case
|
||||
(define/override (copy)
|
||||
(let ([new-to-test (new error-alert-text%)]
|
||||
[new-expected (new error-alert-text%)]
|
||||
[new-predicate (new error-alert-text%)]
|
||||
[new-should-raise (new error-alert-text%)]
|
||||
[new-error-message (new error-alert-text%)])
|
||||
(send to-test copy-self-to new-to-test)
|
||||
(send expected copy-self-to new-expected)
|
||||
(send predicate copy-self-to new-predicate)
|
||||
(send should-raise copy-self-to new-should-raise)
|
||||
(send error-message copy-self-to new-error-message)
|
||||
(new test-case-box%
|
||||
(enabled? enabled?)
|
||||
(actual-show? actual-show?)
|
||||
(collapsed? collapsed?)
|
||||
(show-right-pane? show-right-pane?)
|
||||
(error-box? error-box?)
|
||||
(to-test new-to-test)
|
||||
(expected new-expected)
|
||||
(predicate predicate)
|
||||
(should-raise should-raise)
|
||||
(error-message error-message))))
|
||||
|
||||
#;((is-a?/c editor-stream-out%) . -> . void?)
|
||||
;; Writes this test case box to the given file.
|
||||
(define/override (write f)
|
||||
(send to-test write-to-file f)
|
||||
(send expected write-to-file f)
|
||||
(send predicate write-to-file f)
|
||||
(send should-raise write-to-file f)
|
||||
(send error-message write-to-file f)
|
||||
(send f put (if enabled? 1 0))
|
||||
(send f put (if collapsed? 1 0))
|
||||
(send f put (if error-box? 1 0)))
|
||||
|
||||
|
||||
#;((is-a?/c editor-stream-in%) . -> . void?)
|
||||
;; Reads the state of the box in from the given stream
|
||||
(define/public (read-from-file f)
|
||||
(let ([enabled?-box (box 0)]
|
||||
[collapsed?-box (box 0)]
|
||||
[error-box?-box (box 0)])
|
||||
(let ([vers (send tcb-sc reading-version f)])
|
||||
(case vers
|
||||
[(1)
|
||||
;; Discard comment:
|
||||
(send (new text%) read-from-file f)
|
||||
(send* to-test (erase) (read-from-file f))
|
||||
(send* expected (erase) (read-from-file f))
|
||||
;; Nothing else is in the stream in version 1,
|
||||
;; so leave the defaults
|
||||
]
|
||||
[(2)
|
||||
(send* to-test (erase) (read-from-file f))
|
||||
(send* expected (erase) (read-from-file f))
|
||||
(send* predicate (erase) (read-from-file f))
|
||||
(send* should-raise (erase) (read-from-file f))
|
||||
(send* error-message (erase) (read-from-file f))
|
||||
(send f get enabled?-box)
|
||||
(send f get collapsed?-box)
|
||||
(send f get error-box?-box)
|
||||
(enable (= (unbox enabled?-box) 1))
|
||||
;; Presently this is poking a bug in the embedded-gui.
|
||||
;; I'll leaving it commented til I reduce the bug.
|
||||
#;(collapse (= (unbox collapsed?-box) 1))
|
||||
(toggle-error-box (= (unbox error-box?-box) 1))]))))
|
||||
|
||||
;;;;;;;;;;
|
||||
;; Layout
|
||||
|
||||
#;(-> (is-a?/c bitmap%))
|
||||
;; The bitmap to use for the top corner of the box.
|
||||
(define/override (get-corner-bitmap)
|
||||
(if error-box?
|
||||
(make-object bitmap% (icon "scheme-box.jpg"))
|
||||
(make-object bitmap% (icon "scheme-box.jpg"))))
|
||||
|
||||
#;(-> (symbols 'top-right 'top-left 'bottom-left 'bottom-right))
|
||||
;; The location of the corner bitmap
|
||||
(define/override (get-position) 'top-right)
|
||||
|
||||
#;(-> (union string? (is-a?/c color%)))
|
||||
;; The color of the border of this box
|
||||
(define/override (get-color) (if error-box? "red" "purple"))
|
||||
|
||||
#;(-> (is-a?/c popup-menu%))
|
||||
;; The popup menu used for the top corner of this box
|
||||
(define/override (get-menu)
|
||||
(let ([the-menu (new popup-menu% (title (string-constant test-case-menu-title)))])
|
||||
(define (make-toggle label f init)
|
||||
(letrec ([item (new checkable-menu-item%
|
||||
(parent the-menu)
|
||||
(label label)
|
||||
(checked init)
|
||||
(callback (lambda (m e)
|
||||
(f (send item is-checked?)))))])
|
||||
item))
|
||||
(new menu-item%
|
||||
(label (if error-box?
|
||||
(string-constant test-case-switch-to-nonerror-box)
|
||||
(string-constant test-case-switch-to-error-box)))
|
||||
(parent the-menu)
|
||||
(callback (lambda (m e)
|
||||
(toggle-error-box (not error-box?)))))
|
||||
(make-toggle
|
||||
(string-constant test-case-collapse)
|
||||
collapse collapsed?)
|
||||
(make-toggle
|
||||
(string-constant test-case-show-actual)
|
||||
show-actual actual-show?)
|
||||
(make-toggle
|
||||
(string-constant test-case-enable)
|
||||
(lambda (b) (enable b)) enabled?) ; eta public method
|
||||
(make-toggle
|
||||
(if error-box?
|
||||
(string-constant test-case-show-error-message)
|
||||
(string-constant test-case-show-predicate))
|
||||
show-right-pane show-right-pane?)
|
||||
(new menu-item%
|
||||
(label (string-constant test-case-convert-to-text))
|
||||
(parent the-menu)
|
||||
(callback
|
||||
(lambda (m e)
|
||||
(convert-to-string (get-string)))))
|
||||
the-menu))
|
||||
|
||||
#;(-> void)
|
||||
;; Hide and show the boxes that differ between error and now and
|
||||
;; poke the snip-parent to display the new boarder color
|
||||
(define (toggle-error-box bool)
|
||||
(set! error-box? bool)
|
||||
(send pb lock-alignment true)
|
||||
(send should-be-pane show (not error-box?))
|
||||
(send should-raise-pane show error-box?)
|
||||
(send predicate-pane show (not error-box?))
|
||||
(send error-message-pane show error-box?)
|
||||
(send pb lock-alignment false)
|
||||
(if error-box?
|
||||
(set-tabbing to-test should-raise)
|
||||
(set-tabbing to-test expected))
|
||||
(>>= (snip-parent this)
|
||||
(lambda (admin)
|
||||
(send admin resized this true))))
|
||||
|
||||
#;(boolean? . -> . void)
|
||||
;; Shows or hides the actual box
|
||||
(define (show-actual show?)
|
||||
(set! actual-show? show?)
|
||||
(send pb lock-alignment true)
|
||||
(send show-actual-button set-state
|
||||
(boolean->show-actual-btn-state show?))
|
||||
(send to-test-pane stretchable-height show?)
|
||||
(send actual-pane show show?)
|
||||
(send pb lock-alignment false))
|
||||
|
||||
#;(boolean? . -> . void)
|
||||
;; Toggles the test-case between a collapsed minimal state and one with entry boxes.
|
||||
(define (collapse bool)
|
||||
(set! collapsed? bool)
|
||||
(send collapse-button set-state
|
||||
(boolean->collapse-btn-state bool))
|
||||
(send body show (not bool)))
|
||||
|
||||
#;(booean? . -> . void)
|
||||
;; Shows or hides the predicate box
|
||||
(define (show-right-pane show?)
|
||||
(set! show-right-pane? show?)
|
||||
(send right-pane show show-right-pane?))
|
||||
|
||||
;;;;;;;;;;
|
||||
;; Box layout
|
||||
|
||||
(field
|
||||
[pb (new aligned-pasteboard%)]
|
||||
[main (new horizontal-alignment% (parent pb))])
|
||||
|
||||
;;;;;;;;;;
|
||||
;; The button bar w/ result check mark box
|
||||
|
||||
(field
|
||||
[button-pane (new vertical-alignment% (parent main))]
|
||||
[result (new result-snip% (status (if enabled? 'unknown 'disabled)))])
|
||||
(snip-wrap button-pane result)
|
||||
(field
|
||||
[collapse-button
|
||||
(new turn-button%
|
||||
(parent button-pane)
|
||||
(state (boolean->collapse-btn-state collapsed?))
|
||||
(turn-off (lambda (b e) (collapse true)))
|
||||
(turn-on (lambda (b e) (collapse false))))]
|
||||
[show-actual-button
|
||||
(new turn-button%
|
||||
(parent button-pane)
|
||||
(state (boolean->show-actual-btn-state actual-show?))
|
||||
(turn-off (lambda (b e) (show-actual false)))
|
||||
(turn-on (lambda (b e) (show-actual true))))])
|
||||
|
||||
;;;;;;;;;;
|
||||
;; The text boxes
|
||||
|
||||
(field
|
||||
[body (new horizontal-alignment% (parent main) (show? (not collapsed?)))]
|
||||
[to-test-pane
|
||||
(new labeled-text-field%
|
||||
(parent body)
|
||||
(label (string-constant test-case-to-test))
|
||||
(text to-test))]
|
||||
|
||||
[result-pane (new vertical-alignment% (parent body))]
|
||||
[should-be-pane
|
||||
(new labeled-text-field%
|
||||
(parent result-pane)
|
||||
(show? (not error-box?))
|
||||
(label (string-constant test-case-expected))
|
||||
(text expected))]
|
||||
[should-raise-pane
|
||||
(new labeled-text-field%
|
||||
(parent result-pane)
|
||||
(show? error-box?)
|
||||
(label (string-constant test-case-should-raise))
|
||||
(text should-raise))]
|
||||
[actual (new actual-text%)]
|
||||
[actual-pane
|
||||
(new labeled-text-field%
|
||||
(parent result-pane)
|
||||
(label (string-constant test-case-actual))
|
||||
(show? actual-show?)
|
||||
(snip-class (grey-editor-snip-mixin stretchable-editor-snip%))
|
||||
(text actual))]
|
||||
|
||||
[right-pane (new vertical-alignment% (parent body) (show? show-right-pane?))]
|
||||
[predicate-pane
|
||||
(new labeled-text-field%
|
||||
(parent right-pane)
|
||||
(show? (not error-box?))
|
||||
(label (string-constant test-case-predicate))
|
||||
(text predicate))]
|
||||
[error-message-pane
|
||||
(new labeled-text-field%
|
||||
(parent right-pane)
|
||||
(show? error-box?)
|
||||
(label (string-constant test-case-error-message))
|
||||
(text error-message))])
|
||||
|
||||
(super-new (editor pb))
|
||||
|
||||
(set-tabbing to-test expected predicate)
|
||||
(set-tabbing should-raise error-message)
|
||||
|
||||
;;;;;;;;;;
|
||||
;; Snip class
|
||||
|
||||
(inherit set-snipclass)
|
||||
(set-snipclass tcb-sc)))
|
||||
|
||||
;;;;;;;;;;
|
||||
;; Snip class
|
||||
|
||||
;; A snip-class for the test case box
|
||||
(define tcb-sc
|
||||
(make-snipclass
|
||||
test-case-box%
|
||||
"test-case-box%"
|
||||
#;
|
||||
(lambda (class% f)
|
||||
(let ([enabled?-box (box 0)]
|
||||
[collapsed?-box (box 0)]
|
||||
[error-box?-box (box 0)]
|
||||
[to-test (new test-case:program-editor%)]
|
||||
[expected (new test-case:program-editor%)]
|
||||
[predicate (new test-case:program-editor%)]
|
||||
[should-raise (new test-case:program-editor%)]
|
||||
[error-message (new test-case:program-editor%)])
|
||||
(send to-test read-from-file f)
|
||||
(send expected read-from-file f)
|
||||
(send predicate read-from-file f)
|
||||
(send should-raise read-from-file f)
|
||||
(send error-message read-from-file f)
|
||||
(send f get enabled?-box)
|
||||
(send f get collapsed?-box)
|
||||
(send f get error-box?-box)
|
||||
(new class%
|
||||
(enabled? (= (unbox enabled?-box) 1))
|
||||
(collapsed? (= (unbox collapsed?-box) 1))
|
||||
(error-box? (= (unbox error-box?-box) 1))
|
||||
(to-test to-test)
|
||||
(expected expected)
|
||||
(predicate predicate)
|
||||
(should-raise should-raise)
|
||||
(error-message error-message))))))
|
||||
)
|
||||
|
||||
#;((-> void?) (-> void?) (symbols 'up 'down) . -> . snip%)
|
||||
;; a snip which acts as a toggle button for rolling a window up and down
|
||||
;; STATUS : Change this to derive embedded-toggle-button%
|
||||
(define turn-button%
|
||||
(class embedded-toggle-button%
|
||||
(super-new
|
||||
(images-off (cons (icon "turn-down.png") (icon "turn-down-click.png")))
|
||||
(images-on (cons (icon "turn-up.png") (icon "turn-up-click.png"))))))
|
||||
|
||||
;; a snip which will display a pass/fail result
|
||||
(define result-snip%
|
||||
(class image-snip%
|
||||
(inherit set-bitmap)
|
||||
(init-field [status 'unknown])
|
||||
;; ((symbols 'pass 'fail 'unknown 'disabled) . -> . void?)
|
||||
;; updates the image with the icon representing one of three results
|
||||
(define/public (update value)
|
||||
(set-bitmap
|
||||
(memoize value
|
||||
(lambda ()
|
||||
(make-object bitmap%
|
||||
(test-icon
|
||||
(case value
|
||||
[(pass) "small-check-mark.jpeg"]
|
||||
[(fail) "small-cross.jpeg"]
|
||||
[(unknown) "small-empty.gif"]
|
||||
[(disabled) "small-no.gif"])))))))
|
||||
|
||||
(super-new)
|
||||
(update status)))
|
||||
|
||||
(define memory (make-hash-table 'equal))
|
||||
(define (memoize k thunk)
|
||||
(hash-table-get memory k (lambda ()
|
||||
(let ([v (thunk)])
|
||||
(hash-table-put! memory k v)
|
||||
v))))
|
||||
|
||||
#;(string? . -> . string?)
|
||||
;; A path to the icon given a file name
|
||||
(define (icon str)
|
||||
(build-path (collection-path "icons") str))
|
||||
|
||||
#;(string? . -> . string?)
|
||||
;; A path to the icon in the test-suite given a file name
|
||||
(define (test-icon str)
|
||||
(build-path (collection-path "test-suite") "private" "icons" str))
|
||||
|
||||
;; a locked text hightlighted to show that it is inactive
|
||||
(define actual-text%
|
||||
(class (grey-editor-mixin
|
||||
(text:hide-caret/selection-mixin scheme:text%))
|
||||
(inherit hide-caret lock)
|
||||
(super-new)
|
||||
(hide-caret true)
|
||||
(lock true)))
|
||||
|
||||
;; a text mixin that gives the text an init arg of an initial contents
|
||||
(define init-text-mixin
|
||||
(mixin ((class->interface text%)) ()
|
||||
(inherit insert)
|
||||
(init [text ""])
|
||||
(super-new)
|
||||
(insert text)))
|
||||
|
||||
#;(boolean? . -> . (symbols 'on 'off))
|
||||
;; converts a boolean to the value expected by the collapse button
|
||||
(define (boolean->collapse-btn-state bool)
|
||||
(if bool 'on 'off))
|
||||
|
||||
#;(boolean? . -> . (symbols 'on 'off))
|
||||
;; converts a boolean to the value expected by the show actual button
|
||||
(define (boolean->show-actual-btn-state bool)
|
||||
(if bool 'off 'on))
|
||||
|
||||
#;((is-a?/c text%) . -> . boolean?)
|
||||
;; True if the given text is empty
|
||||
(define (empty-text? t)
|
||||
(let ([str (send t get-text)])
|
||||
(string=? str "")))
|
||||
|
||||
;;;;;;;;;;
|
||||
;; Eaiser syntax for embedded-gui
|
||||
(define (snip-wrap p snip)
|
||||
(new snip-wrapper% (parent p) (snip snip)))
|
||||
|
||||
;; Inserts a label and a text field into the given alignment
|
||||
(define labeled-text-field%
|
||||
(class vertical-alignment%
|
||||
(init label text (snip-class stretchable-editor-snip%))
|
||||
(super-new (stretchable-height false))
|
||||
(new embedded-message% (parent this) (label label))
|
||||
(new snip-wrapper%
|
||||
(parent this)
|
||||
(snip (new snip-class
|
||||
(editor text)
|
||||
(min-width 80))))))
|
||||
|
||||
#;((union any? false?) (any? . -> . any?) . -> . (union any? false?))
|
||||
;; Send the value to the function unless it 'fails' by returning false. Like haskell's bind operator.
|
||||
(define (>>= value function)
|
||||
(cond
|
||||
[value => function]
|
||||
[else false]))
|
||||
)
|
||||
77
collects/test-suite/private/test-case.ss
Normal file
77
collects/test-suite/private/test-case.ss
Normal file
|
|
@ -0,0 +1,77 @@
|
|||
#|
|
||||
This module provides a test-case macro for the test-case-box to expand into.
|
||||
The test-case box does not immediatly expand into the body of the macro itself
|
||||
because the macro is able to check the (syntax-local-context) of the invocation
|
||||
to give better error messages when the test-case is not at the top level.
|
||||
|#
|
||||
|
||||
(module test-case mzscheme
|
||||
|
||||
(require-for-syntax (lib "shared.ss" "stepper" "private"))
|
||||
(provide test-case test-error-case)
|
||||
|
||||
;; STATUS : Abstract these two syntaxes and use string constant for the error
|
||||
(define-syntax (test-case stx)
|
||||
(syntax-case stx ()
|
||||
[(_ test to-test-stx exp-stx record set-actuals)
|
||||
(case (syntax-local-context)
|
||||
[(module top-level)
|
||||
(stepper-syntax-property
|
||||
#`(define-values ()
|
||||
(let ([to-test-values (call-with-values
|
||||
(lambda () #,(stepper-syntax-property #`to-test-stx
|
||||
'stepper-test-suite-hint
|
||||
#t))
|
||||
list)]
|
||||
[exp-values (call-with-values (lambda () exp-stx) list)])
|
||||
(record (and (= (length to-test-values) (length exp-values))
|
||||
(andmap test to-test-values exp-values)))
|
||||
(set-actuals to-test-values)
|
||||
(values)))
|
||||
'stepper-skipto
|
||||
(append
|
||||
;; define-values->body
|
||||
skipto/third
|
||||
;; rhs of first binding of let-values:
|
||||
skipto/second
|
||||
skipto/first
|
||||
skipto/second
|
||||
;; 2nd arg of call-with-values application:
|
||||
skipto/cdr
|
||||
skipto/second
|
||||
;; first (only) body of lambda:
|
||||
skipto/cddr
|
||||
skipto/first))]
|
||||
[else (raise-syntax-error #f
|
||||
"test case not at toplevel"
|
||||
(syntax/loc stx (test-case to-test-stx exp-stx)))])]))
|
||||
|
||||
(define-syntax (test-error-case stx)
|
||||
(syntax-case stx ()
|
||||
[(_ to-test-stx exn-pred exn-handler record set-actuals)
|
||||
(case (syntax-local-context)
|
||||
[(module top-level)
|
||||
(stepper-syntax-property
|
||||
#'(define-values ()
|
||||
(with-handlers ([exn-pred
|
||||
(lambda (v)
|
||||
(set-actuals (list v))
|
||||
(record (exn-handler v))
|
||||
(values))]
|
||||
[void
|
||||
(lambda (v)
|
||||
(set-actuals v)
|
||||
(record #f)
|
||||
(values))])
|
||||
to-test-stx
|
||||
(record #f)
|
||||
(values)))
|
||||
'stepper-skipto
|
||||
`(,@skipto/third
|
||||
;; with-handlers:
|
||||
,@skipto/fourth
|
||||
))]
|
||||
[else (raise-syntax-error #f
|
||||
"test case not at toplevel"
|
||||
(syntax/loc stx (test-case to-test-stx exp-stx)))])]))
|
||||
)
|
||||
59
collects/test-suite/private/text-syntax-object.ss
Normal file
59
collects/test-suite/private/text-syntax-object.ss
Normal file
|
|
@ -0,0 +1,59 @@
|
|||
(module text-syntax-object mzscheme
|
||||
|
||||
(require
|
||||
(lib "unit.ss")
|
||||
(lib "class.ss")
|
||||
(lib "list.ss")
|
||||
(lib "tool.ss" "drscheme")
|
||||
(lib "framework.ss" "framework")
|
||||
(lib "mred.ss" "mred"))
|
||||
|
||||
(provide text->syntax-object@
|
||||
text->syntax-object^)
|
||||
|
||||
(define top-id #'here)
|
||||
|
||||
(define-signature text->syntax-object^ (text->syntax-objects))
|
||||
|
||||
(define-unit text->syntax-object@
|
||||
|
||||
(import drscheme:tool^)
|
||||
(export text->syntax-object^)
|
||||
#;((is-a?/c text%) . -> . (listof syntax-object?))
|
||||
;; a syntax object representing the text with the color of the given object
|
||||
(define (text->syntax-objects text default-v)
|
||||
(let ([port (open-input-text-editor text)])
|
||||
#;(-> (listof syntax-object?))
|
||||
;; Reads all the syntax objects for the text%
|
||||
(define (read-all-syntax)
|
||||
(let* ([language-settings
|
||||
(preferences:get
|
||||
(drscheme:language-configuration:get-settings-preferences-symbol))]
|
||||
[language
|
||||
(drscheme:language-configuration:language-settings-language
|
||||
language-settings)]
|
||||
[settings
|
||||
(drscheme:language-configuration:language-settings-settings
|
||||
language-settings)])
|
||||
(if (drscheme:language-configuration:language-settings? language-settings)
|
||||
(let ([thunk (if (and default-v
|
||||
(zero? (send text last-position)))
|
||||
(let ([got? #f])
|
||||
(lambda ()
|
||||
(begin0
|
||||
(if got?
|
||||
eof
|
||||
default-v)
|
||||
(set! got? #t))))
|
||||
(send language front-end/interaction
|
||||
(open-input-text-editor text)
|
||||
settings
|
||||
(drscheme:teachpack:new-teachpack-cache '())))])
|
||||
(let loop ()
|
||||
(let ([expr (thunk)])
|
||||
(cond [(eof-object? expr) empty]
|
||||
[else (cons expr (loop))]))))
|
||||
(error 'text->syntax-object "Invalid language settings"))))
|
||||
(read-all-syntax)))
|
||||
))
|
||||
|
||||
175
collects/test-suite/tool.ss
Normal file
175
collects/test-suite/tool.ss
Normal file
|
|
@ -0,0 +1,175 @@
|
|||
(module tool mzscheme
|
||||
|
||||
(provide tool@)
|
||||
|
||||
(require
|
||||
(lib "etc.ss")
|
||||
(lib "class.ss")
|
||||
(lib "mred.ss" "mred")
|
||||
(lib "unit.ss")
|
||||
(lib "tool.ss" "drscheme")
|
||||
(lib "framework.ss" "framework")
|
||||
(lib "string-constant.ss" "string-constants")
|
||||
(lib "snip-lib.ss" "mrlib" "private" "aligned-pasteboard")
|
||||
"private/test-case-box.ss"
|
||||
"private/find-scheme-menu.ss"
|
||||
"private/text-syntax-object.ss"
|
||||
"private/print-to-text.ss")
|
||||
|
||||
(define-signature menu-extentions^ ())
|
||||
(define-unit menu-extentions@
|
||||
(import drscheme:tool^ test-case-box^)
|
||||
(export menu-extentions^;drscheme:tool-exports^
|
||||
)
|
||||
;; This delay is set up because reset-highlighting is called immediately
|
||||
;; after execution where I don't want the test-cases to be cleared.
|
||||
;; STATUS: It appears that the problem this flag was created to fix has been
|
||||
;; fixed and is now delaying unecessarily. I have commented out the place where
|
||||
;; it is set to true, effectively turning off the feature. I'll remove the code
|
||||
;; if no bugs creap in after sufficient usage.
|
||||
(define delay? false)
|
||||
|
||||
;; This flag ensures that the test case boxes are only reset when the need
|
||||
;; to be, which is only once after each execution of the program.
|
||||
(define needs-reset? false)
|
||||
|
||||
;; Adds the test suite tool menu to the Dr. Scheme frame
|
||||
;; Updates the needs-reset? when the the program is executed
|
||||
(define test-case-mixin
|
||||
(mixin (drscheme:unit:frame<%> top-level-window<%> (class->interface frame%)) ()
|
||||
(inherit get-definitions-text get-edit-target-object get-menu-bar
|
||||
get-special-menu)
|
||||
|
||||
#;(-> void)
|
||||
;; Called when the program is executed
|
||||
;; Overriden to rest the test-cases.
|
||||
(define/override (execute-callback)
|
||||
(send (get-definitions-text) for-each-test-case
|
||||
(lambda (case) (send case reset)))
|
||||
(super execute-callback)
|
||||
;(set! delay? true)
|
||||
(set! needs-reset? true))
|
||||
|
||||
#;(boolean . -> . void)
|
||||
;; Enable or disable all of the test-cases
|
||||
(define (enable enable?)
|
||||
(send (get-definitions-text) for-each-test-case
|
||||
(lambda (case) (send case enable enable?))))
|
||||
|
||||
#;((is-a?/c menu-item%) . -> . void)
|
||||
;; NOTE: This function is COPIED from the drscheme/private/unit.ss file
|
||||
(define (has-editor-on-demand menu-item)
|
||||
(let ([edit (get-edit-target-object)])
|
||||
(send menu-item enable (and edit (is-a? edit editor<%>)))))
|
||||
|
||||
(super-new)
|
||||
|
||||
;; Create the new menu items.
|
||||
(field
|
||||
[test-cases-enabled? true]
|
||||
[insert-menu-item
|
||||
(new menu-item%
|
||||
(label (string-constant test-case-insert))
|
||||
(parent (get-special-menu))
|
||||
(callback
|
||||
(lambda (menu event)
|
||||
(let ([test-box (new test-case-box% (enabled? test-cases-enabled?))]
|
||||
[text (get-edit-target-object)])
|
||||
(when text
|
||||
(send text begin-edit-sequence)
|
||||
(send text insert test-box)
|
||||
(send test-box take-caret)
|
||||
(send text end-edit-sequence)))))
|
||||
(demand-callback has-editor-on-demand))])
|
||||
(let ([parent (find-scheme-menu (get-special-menu))])
|
||||
(and parent
|
||||
(new menu-item%
|
||||
(parent parent)
|
||||
(label (string-constant test-case-disable-all))
|
||||
(callback
|
||||
(lambda (menu event)
|
||||
(set! test-cases-enabled? (not test-cases-enabled?))
|
||||
(if test-cases-enabled?
|
||||
(send menu set-label (string-constant test-case-disable-all))
|
||||
(send menu set-label (string-constant test-case-enable-all)))
|
||||
(send (get-definitions-text) for-each-test-case
|
||||
(lambda (tc) (send tc enable test-cases-enabled?))))))))))
|
||||
|
||||
(drscheme:get/extend:extend-unit-frame test-case-mixin)
|
||||
|
||||
;; Adds a hook in the reset-highlighting to clear all of the test-case results when
|
||||
;; the appropriate
|
||||
;; STATUS: It's better to override reset-highlighting but this after-insert/delete works
|
||||
;; for now.
|
||||
(define clear-results-mixin
|
||||
(mixin (editor<%>) ()
|
||||
(inherit find-first-snip)
|
||||
|
||||
;#;(case-> (-> boolean?) (boolean? . -> . void))
|
||||
;;; Get or set the delay-reset field
|
||||
;(define/public delay-reset
|
||||
; (case-lambda
|
||||
; [() delay?]
|
||||
; [(v) (set! delay? v)]))
|
||||
|
||||
#;(-> void)
|
||||
;; set all of the test-case-boxes in the definitions text to an unevaluated state
|
||||
(define/public (reset-test-case-boxes)
|
||||
(when needs-reset?
|
||||
(set! needs-reset? false)
|
||||
(for-each-test-case (lambda (snip) (send snip reset)))))
|
||||
|
||||
#;(((is-a?/c test-case-box%) . -> . void) . -> . void)
|
||||
;; executes the given function on each test-case-box
|
||||
(define/public (for-each-test-case f)
|
||||
(for-each-snip
|
||||
(lambda (snip)
|
||||
(when (is-a? snip test-case-box%)
|
||||
(f snip)))
|
||||
(find-first-snip)))
|
||||
|
||||
(super-new)))
|
||||
|
||||
(drscheme:get/extend:extend-definitions-text clear-results-mixin)
|
||||
|
||||
;; Require the test-case macro into every new namespace when a program is run.
|
||||
(define require-macro-mixin
|
||||
(mixin ((class->interface drscheme:rep:text%)) ()
|
||||
(inherit get-user-namespace get-definitions-text)
|
||||
|
||||
#;((is-a?/c area<%>) . -> . (is-a?/c frame%))
|
||||
;; The frame containing the given area
|
||||
(define (find-frame area)
|
||||
(let ([parent (send area get-parent)])
|
||||
(if parent
|
||||
(find-frame parent)
|
||||
area)))
|
||||
|
||||
#;(-> void)
|
||||
;; Called to indicate that the program annotations should be cleared.
|
||||
;; Overriden to reset test case boxes
|
||||
(define/override (reset-highlighting)
|
||||
(super reset-highlighting)
|
||||
(let ([defs-text (get-definitions-text)])
|
||||
;(if (send text delay-reset)
|
||||
; (send text delay-reset false)
|
||||
; (send text reset-test-case-boxes))))
|
||||
(send defs-text reset-test-case-boxes)))
|
||||
|
||||
#;(-> void)
|
||||
;; Called when the program is execute to reset the rep:text
|
||||
;; Overriden to require the test case macro into any program that is executed.
|
||||
(define/override (reset-console)
|
||||
(super reset-console)
|
||||
(parameterize ([current-namespace (get-user-namespace)])
|
||||
(namespace-require '(lib "test-case.ss" "test-suite" "private"))))
|
||||
(super-new)))
|
||||
|
||||
(drscheme:get/extend:extend-interactions-text require-macro-mixin))
|
||||
|
||||
(define tool@
|
||||
(compound-unit/infer
|
||||
(import drscheme:tool^)
|
||||
(export drscheme:tool-exports^)
|
||||
(link menu-extentions@ test-case-box@ text->syntax-object@ print-to-text@)))
|
||||
)
|
||||
Loading…
Reference in New Issue
Block a user