Moving the test suite to the graveyard, RIP.
svn: r5213
This commit is contained in:
Eli Barzilay
parent
333c003382
commit
c7f03f1047
|
|
@ -1,14 +0,0 @@
|
||||||
|
|
||||||
(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)))
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -1,6 +0,0 @@
|
||||||
(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")))
|
|
||||||
)
|
|
||||||
|
|
@ -1,38 +0,0 @@
|
||||||
#| 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)))
|
|
||||||
)
|
|
||||||
|
|
@ -1,38 +0,0 @@
|
||||||
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.
|
|
||||||
|
|
@ -1,59 +0,0 @@
|
||||||
;;;;;;;;;;
|
|
||||||
;; 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
|
|
||||||
|
|
@ -1,160 +0,0 @@
|
||||||
######################################################################
|
|
||||||
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.
|
|
||||||
-------------------
|
|
||||||
|
|
@ -1,38 +0,0 @@
|
||||||
;; 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))))
|
|
||||||
)
|
|
||||||
Binary file not shown.
|
Before Width: | Height: | Size: 718 B |
Binary file not shown.
|
Before Width: | Height: | Size: 856 B |
Binary file not shown.
|
Before Width: | Height: | Size: 846 B |
Binary file not shown.
|
Before Width: | Height: | Size: 813 B |
Binary file not shown.
|
Before Width: | Height: | Size: 284 B |
Binary file not shown.
|
Before Width: | Height: | Size: 737 B |
Binary file not shown.
|
Before Width: | Height: | Size: 1.3 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 412 B |
Binary file not shown.
|
Before Width: | Height: | Size: 433 B |
Binary file not shown.
|
Before Width: | Height: | Size: 46 B |
Binary file not shown.
|
Before Width: | Height: | Size: 139 B |
|
|
@ -1,2 +0,0 @@
|
||||||
(module info (lib "infotab.ss" "setup")
|
|
||||||
(define name "Test Suite private"))
|
|
||||||
|
|
@ -1,36 +0,0 @@
|
||||||
(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))
|
|
||||||
)
|
|
||||||
|
|
@ -1,62 +0,0 @@
|
||||||
(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)))))
|
|
||||||
|
|
@ -1,586 +0,0 @@
|
||||||
#| 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]))
|
|
||||||
)
|
|
||||||
|
|
@ -1,77 +0,0 @@
|
||||||
#|
|
|
||||||
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)))])]))
|
|
||||||
)
|
|
||||||
|
|
@ -1,59 +0,0 @@
|
||||||
(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)))
|
|
||||||
))
|
|
||||||
|
|
||||||
|
|
@ -1,175 +0,0 @@
|
||||||
(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