From 5cc51c18ddfbfc8ca075b039afe8f1135dda7061 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 4 Jan 2007 18:00:31 +0000 Subject: [PATCH] Restoring, for now. svn: r5221 --- collects/test-suite/extension.ss | 14 + collects/test-suite/info.ss | 6 + .../test-suite/private/convert-to-string.ss | 38 ++ collects/test-suite/private/doc/ChangeLog | 38 ++ collects/test-suite/private/doc/TODO | 59 ++ collects/test-suite/private/doc/old-todo | 160 +++++ .../test-suite/private/find-scheme-menu.ss | 38 ++ .../test-suite/private/icons/check-mark.jpeg | Bin 0 -> 718 bytes .../icons/checkbox_enabled_checked.gif | Bin 0 -> 856 bytes .../icons/checkbox_enabled_notchecked.gif | Bin 0 -> 846 bytes collects/test-suite/private/icons/cross.jpeg | Bin 0 -> 813 bytes collects/test-suite/private/icons/empty.jpeg | Bin 0 -> 284 bytes .../private/icons/question-mark.jpeg | Bin 0 -> 737 bytes .../private/icons/question-mark.png | Bin 0 -> 1360 bytes .../private/icons/small-check-mark.jpeg | Bin 0 -> 412 bytes .../test-suite/private/icons/small-cross.jpeg | Bin 0 -> 433 bytes .../test-suite/private/icons/small-empty.gif | Bin 0 -> 46 bytes .../test-suite/private/icons/small-no.gif | Bin 0 -> 139 bytes collects/test-suite/private/info.ss | 2 + collects/test-suite/private/make-snipclass.ss | 36 ++ collects/test-suite/private/print-to-text.ss | 62 ++ collects/test-suite/private/test-case-box.ss | 586 ++++++++++++++++++ collects/test-suite/private/test-case.ss | 77 +++ .../test-suite/private/text-syntax-object.ss | 59 ++ collects/test-suite/tool.ss | 175 ++++++ 25 files changed, 1350 insertions(+) create mode 100644 collects/test-suite/extension.ss create mode 100644 collects/test-suite/info.ss create mode 100644 collects/test-suite/private/convert-to-string.ss create mode 100644 collects/test-suite/private/doc/ChangeLog create mode 100644 collects/test-suite/private/doc/TODO create mode 100644 collects/test-suite/private/doc/old-todo create mode 100644 collects/test-suite/private/find-scheme-menu.ss create mode 100644 collects/test-suite/private/icons/check-mark.jpeg create mode 100644 collects/test-suite/private/icons/checkbox_enabled_checked.gif create mode 100644 collects/test-suite/private/icons/checkbox_enabled_notchecked.gif create mode 100644 collects/test-suite/private/icons/cross.jpeg create mode 100644 collects/test-suite/private/icons/empty.jpeg create mode 100644 collects/test-suite/private/icons/question-mark.jpeg create mode 100644 collects/test-suite/private/icons/question-mark.png create mode 100644 collects/test-suite/private/icons/small-check-mark.jpeg create mode 100644 collects/test-suite/private/icons/small-cross.jpeg create mode 100644 collects/test-suite/private/icons/small-empty.gif create mode 100644 collects/test-suite/private/icons/small-no.gif create mode 100644 collects/test-suite/private/info.ss create mode 100644 collects/test-suite/private/make-snipclass.ss create mode 100644 collects/test-suite/private/print-to-text.ss create mode 100644 collects/test-suite/private/test-case-box.ss create mode 100644 collects/test-suite/private/test-case.ss create mode 100644 collects/test-suite/private/text-syntax-object.ss create mode 100644 collects/test-suite/tool.ss diff --git a/collects/test-suite/extension.ss b/collects/test-suite/extension.ss new file mode 100644 index 0000000000..03053b69ea --- /dev/null +++ b/collects/test-suite/extension.ss @@ -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))) + + + \ No newline at end of file diff --git a/collects/test-suite/info.ss b/collects/test-suite/info.ss new file mode 100644 index 0000000000..076ea12a71 --- /dev/null +++ b/collects/test-suite/info.ss @@ -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"))) + ) diff --git a/collects/test-suite/private/convert-to-string.ss b/collects/test-suite/private/convert-to-string.ss new file mode 100644 index 0000000000..4350d05553 --- /dev/null +++ b/collects/test-suite/private/convert-to-string.ss @@ -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))) + ) diff --git a/collects/test-suite/private/doc/ChangeLog b/collects/test-suite/private/doc/ChangeLog new file mode 100644 index 0000000000..d3602c19e6 --- /dev/null +++ b/collects/test-suite/private/doc/ChangeLog @@ -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. diff --git a/collects/test-suite/private/doc/TODO b/collects/test-suite/private/doc/TODO new file mode 100644 index 0000000000..5c1421c952 --- /dev/null +++ b/collects/test-suite/private/doc/TODO @@ -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 diff --git a/collects/test-suite/private/doc/old-todo b/collects/test-suite/private/doc/old-todo new file mode 100644 index 0000000000..99cc2dc573 --- /dev/null +++ b/collects/test-suite/private/doc/old-todo @@ -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. +------------------- diff --git a/collects/test-suite/private/find-scheme-menu.ss b/collects/test-suite/private/find-scheme-menu.ss new file mode 100644 index 0000000000..68b4626de6 --- /dev/null +++ b/collects/test-suite/private/find-scheme-menu.ss @@ -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)))) + ) \ No newline at end of file diff --git a/collects/test-suite/private/icons/check-mark.jpeg b/collects/test-suite/private/icons/check-mark.jpeg new file mode 100644 index 0000000000000000000000000000000000000000..83ff6b84644532a8db270c24d9e9016beb5fc997 GIT binary patch literal 718 zcmex=LJ%Z3brs z4mLJ+HdYRHc6Lrq4lW)MULJ049!Vi#ei2zIc{y1r85so?J#_^o9c39A4RcK$149!N z6M1z@TMHu_J!2CikRgnmoSZz|JQBRT5=M$Libf=Z{|6WZIT(}~l$jZo7?=bZnFSgD zA7PMTU}RuoW?*JO0A_YZ7FH%U4xp@|00Sd4GZQl#GbdD@k%^gwfmM)AkzL48SVYM& zaH6Plp|WvMV$#Bm2Ok2pNP^5`M3@F-F*7o;umYuI1;J9tvP?i{I0`8m8vnn=zyp+E z5@Z%+uxHp`q%9p9y7tFZz4O&Sa#xsyoRr;k$FC;7{qJg}`v%_I+-5AAAe*W;iSKsL zm5e1jW0xkke2UM~Dc$qwQrm2qQ$f2JL&}z3`@A)5K`+x486OuLYm>#RcQ>A?*ZTZO zZ%5fj-Ll!)$9F9Fv|~%n)vEN%m-a4ho23x-xcltE#rI>GH#zN#@}Ga@=hgCbg_Ehh zrSmvHFYUV*bctzKOV971rQesv^WLaAz4pSguSf4{y}rl!{op_C?M07-*T1+CrqNlt zJm5l}^OD9XeT^#ehP~fb>{ysrCAVd=X6}SD6Q(YVxEUd#{B2E!t-!aX^JWH3ir%)R zXp`H!x`}^h`R|=$u`?y=#9XU8Mi;eqc=^71a7}5;`VG0x??vbBcMLCJP)SwrKhs@F|5EO(CE=~av#8st>pmR6L zML4=TImTa}o9MHJBx{=4Dk>xk^Jzm01~;uGFZY8Cek( zuF!~L)>)3S%R(cor7T6sC0J1n7@|>$EP4=w4K!FRYYa`zi%e%~{6R|L!DT~yF? zq@5P-5yfmOQchuyJdnvYao`^jI7BsIh(;x&=zth(puy54H*IR3BQ!zc4_YcaEONyz zDrklrB1e)Y0CX`<(6}W^@<1lr#DOLZ;}F$=A(~BOp#x&Df!3U8rfF02#Ki~_f6!7{ z^KneB>)z8`C!CnqRc3YtJ*ltkW_86eM_3LAX^EbjEFA;9p!poQ65-(qs*8Gehj{)4 zZ653E=Em{M-``(vu6{c^*?V>V_R6*UZ~mNpdUC4Emwp`G`@DU(xBqbG&dKfb)9bfB UemVYouzi2{;@5|t2RHTTKXd?HN&o-= literal 0 HcmV?d00001 diff --git a/collects/test-suite/private/icons/checkbox_enabled_notchecked.gif b/collects/test-suite/private/icons/checkbox_enabled_notchecked.gif new file mode 100644 index 0000000000000000000000000000000000000000..25870c84623595e2a0c29f6460f7d30b1cdb8bb8 GIT binary patch literal 846 zcmc(eziO6Y48_m*4WDQ!#YGUDIutq_EEV@wM{(`aC3EQ&6j~G<9NcmTA}B6yos@35 z2=OKy(_fyO=(B|+=U?9U^zF&dx-ycDJUg>dLO@a+ju=)tQ~q=}ygT zR7ZA1hdVT@u6DMg?Y2N_RV!Q3a*G0Npuu99X${Z3tcogEX=tf3E2Gkt8Wl7nE26>` z8d1zT%Tab&Xk@jNr6{=sE2;rQG%Arr4`Q%^28(5lp{aS1=}e73XsIGHoT0Ic3Yw0z z)51NXm`z2>DeRF4GT9~${38N~s0IwtsALo!5Q7agSeoRfP0e$JCP@52OJ#>euGmEd z&5%RnNYVs=F2)HOw?s)E$Yh&1(1c+eq8cznvxzKpKnym}niI`5ZEBvl7(wC>S}JQk zj>&c1dz$Nn6Z5*t%&wp(^_AVMt~llh%i$m`(Q}ifV}KVlp95DSJUl`5Q14)f=U>pq z`o4Mg=Hl&@^(PF6}rMnOeST|r4lSw=>~TvNxu(8R<4n+Vq7ItP<4knUWZR9m^Pb<}H*Gt+LihT$DNn=?eUs5tNp$|QR(wTSqh*ycra~pGWL$>=} zn^0fe<#O@YqMz!)?uj?`PNX?)*s^-U#FHnM-gT{=xFWB6(zACn9xnU+R{s60jkea8 zwHhVEBQ<|LKk$-Y(|<2ZNY&NG;0txXd*aUB_r2V2>sThAzRgax(N!c^Q`&IF5`}li zE?Ay_81tWDC68zpr_;@EwKv!;S$-6rfUKrQFC-`zx|ZIXeDeCw&~23XKOA>&v_8CWE*q)ev@E_ zB4edki-;ALN4kqIf15pJ!j}`eR?qB|=Un+w7||)odpwm_f$xOGqOKExa~_qx4oMBs iDKIH8HIu&_%v){94aEpJa@0SJKJtI!W^dv5}+UK x!U!wHLs*(&E3{6dggq*yC~ZUcPQ@2--3H&DlWck`Ct3a56OGVYL@{829S^9EmmB~9 literal 0 HcmV?d00001 diff --git a/collects/test-suite/private/icons/question-mark.jpeg b/collects/test-suite/private/icons/question-mark.jpeg new file mode 100644 index 0000000000000000000000000000000000000000..4edab4cdacf4724f7c1a69757fe6aa22245976e2 GIT binary patch literal 737 zcmex=^(PF6}rMnOeST|r4lSw=>~TvNxu(8R<*g2S(fs(oc3`~qn zEG(?dtWar2CT0c}RyIK)c16QLVI{}JLJ`qMab=^Rg+S#Jj10`EMlmolv9bYWlmr~uagz2GCuHqPgtp+YD;hq1DtG25|Fymq%O|Uy$xgK0^zVsLZrNACdHd&uoICP# z&vK?)@%J2aE^62b{&Nmop~6>n-Pz}tS@8Bg-B0T?r*7THtz!6N;hci(gL0}OsU6po zk8dw{$FbU6<)hqbla;O45A1f}K5~4;JN^}`(mNuj^B?~hvF}Fv%LPHZPrckT`PS}- zM_V61vv{u*7O_~`yFRyy@!roKijGD<@&uDks>oru)Ka7`Q4=8v~*2Ub;tXC zD^-dPE>$nMerekl$>g?$Db?Q|-#xNZ@`=yx>_X#%9XH$N-am0};dI9v&DWo;yCbc0 zJ7U$QMGaOAmZ8y;jQsSQAH6KqJ*a)w$9vu7&uin%Ub!g9ZIwFfuIsg0e&_1n2`;vx zOe+{l7VTQJiA_E0!!(n$&q{M^S1elO*WmH6*MF)=_FF&eKv%O8ri-qk4)y500006VoOIv0RI60 z0RN!9r;`8x010qNS#tmY3labT3lag+-G2N4000McNliru)dmd(7YA-3*`ELa1l>tQ zK~z}7?U!4Kl~okSe{1jW%$zgh+{bY)h^C=Nffj_7LP$gpViKevy$C)eK~F&sz2sBS zQ$oEz%*Yp9K z!EO+Obzpmh6c7LwFo<79Nq`6?oK&J;AlwJ3uOm*BX30#$+d^uwp<|b2p;Ibbg}UvK ze$miqga(8;FE|GagEG$Ed+)P?SqE4w9wpR zXvMGqAq^OR@(M}`rGgRz216R58AA&~BSL_ZpiJS&k#LiQ>@f(pM4TC{sb(xo_Zzxi z3+ThpiO}TPP?VBC=_tz7pGv$R+!-*DkX|V)*ly{5+|q}k6(NNZqvT1*lF&~~|8=Fb zKIZJ;j9>y*Y%;VT2v~-p3qu2nqD+x6f+IVql-@Bc+E?aVy*oF}ri@VkUBI#pmL(XP zJ)0GjaT11zxJ<&eLuod=lxO#Y!K7FlKs*reShuAcp$G*fFT zC8?4verbbX5G;ZPQvRW(CNMGQ&pRfLC)^<6<|QTC8uDvYi%ukDpA{N1)uI<)`06{W zszKF9ay5aeo-n`1F%l|;Z84`OY5|gFW22DXZRr5gew_#?dnw3Mef@dB{XG3^o}Tcp zlyZwBdvazFo2*iKMX3MK(({y|4X`L7;Qo<>YJ1;8$seg>?U9%Z4?mj>U8{upr-i1p z(AXxVdxi8WA@iJ}wZqVbrNe7e$^)t3n8Yzc%m4`kgGzZ_%(?zqFf(1)RgnI|(1E2B zp#?*e?~+D@dO*DDR#1vw@J4ZDag2Wt;f|PdH}2n!H8azCT*zSQrK+;+7#h8n0F-fz zdT|`ZkyoX7RVn=h;inO&kIuA5&0u0K+^FOEA)%qq(2AuEA>&oHM8YHqL;VT4&B{~} z>`=(z!fY%=FiSUcLXf_yW?0{h4yEh|V(#-Y2mW|ib7f{{e(c%m@T;JdJ%}QXJdSZ7 z`s`7hUQio|_8y`BeaH9?Lo1HkD6zK|4#xyaG3S`jM*(AJ`a_1-iMhO1u%S?YO0XBf z-B2o%NZ-Q-y%yB4|=iCF|8%?}xVy<*La=i(|J&s(jQmhj)Uplhm za{?w{^-@D-i_r3dp=p_rZiYa?O)8};j>%(6;hT^nf6dwLAYf%mseEK;+iB^xhE8uU zGrs=s_?1x-ZaT-vUL|}h;cDSOuNg&l3YlG&g~rh7^`*&sl$5szg5rQs9QoDCWS|rd z&OtZHAjGOvq&j^IUiL!|BJxvt3Z(>ufM(~Uo1l2n(0mNy6-v49&c;Mj7zLa$p^#mIKXIW^@XY>yVr@^qvkmEB literal 0 HcmV?d00001 diff --git a/collects/test-suite/private/icons/small-check-mark.jpeg b/collects/test-suite/private/icons/small-check-mark.jpeg new file mode 100644 index 0000000000000000000000000000000000000000..cc2e570c73ce58195e35e2c42916fcfb8a1fbe04 GIT binary patch literal 412 zcmex=^(PF6}rMnOeST|r4lSw=>~TvNxu(8R<?K0M&`2YiD3$0Se0qGB7f;!nA^DMh0d@CP87th5v6c z@Gvt1UBE2JV9yY`cwb?-;*6XnK|L{ldy_4M-Y@*glI3=rz|ydx5wU2j@o!`M5XKJ)eBtDtUcuXuuXV!KUeg5>Cno UI%F9a>6I^(PF6}rMnOeST|r4lSw=>~TvNxu(8R<_7>10R{$EW+qlv zxD+E3Gpis23!9>&kg#E3p{P>g#DzeGqKqKVA_EpSps<1<10yptE0PpYKTx}nqG4iT z=`b^Z)TS%R(~27J>_kdx+W*{9c9_{a}#g1vA$Z@C%*prX)O+Y z6;DNj4}H7Y6JCDz*lA+(EK*`&P0%g#D4C;t%#AH|HT_S65{`dL6KB}wdr~Myf9=is-7n{_ecHd^Vg00A2^E(eV$K`*pH^@@ zAz*TZK@F%30(2OF0Hl|J#X-O$VaC?9SEtvqooLi| nVkgg3WoPiKm@fVJ^6MI=8A(CROB-EOgf}Pu;aEJGgTWdA&&NNX literal 0 HcmV?d00001 diff --git a/collects/test-suite/private/info.ss b/collects/test-suite/private/info.ss new file mode 100644 index 0000000000..6e9ce8f1ba --- /dev/null +++ b/collects/test-suite/private/info.ss @@ -0,0 +1,2 @@ +(module info (lib "infotab.ss" "setup") + (define name "Test Suite private")) diff --git a/collects/test-suite/private/make-snipclass.ss b/collects/test-suite/private/make-snipclass.ss new file mode 100644 index 0000000000..1b81372140 --- /dev/null +++ b/collects/test-suite/private/make-snipclass.ss @@ -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)) + ) \ No newline at end of file diff --git a/collects/test-suite/private/print-to-text.ss b/collects/test-suite/private/print-to-text.ss new file mode 100644 index 0000000000..61953ef031 --- /dev/null +++ b/collects/test-suite/private/print-to-text.ss @@ -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))))) diff --git a/collects/test-suite/private/test-case-box.ss b/collects/test-suite/private/test-case-box.ss new file mode 100644 index 0000000000..313609810c --- /dev/null +++ b/collects/test-suite/private/test-case-box.ss @@ -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])) + ) diff --git a/collects/test-suite/private/test-case.ss b/collects/test-suite/private/test-case.ss new file mode 100644 index 0000000000..2ad1aca124 --- /dev/null +++ b/collects/test-suite/private/test-case.ss @@ -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)))])])) + ) diff --git a/collects/test-suite/private/text-syntax-object.ss b/collects/test-suite/private/text-syntax-object.ss new file mode 100644 index 0000000000..c1139893e9 --- /dev/null +++ b/collects/test-suite/private/text-syntax-object.ss @@ -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))) + )) + diff --git a/collects/test-suite/tool.ss b/collects/test-suite/tool.ss new file mode 100644 index 0000000000..4b5dac57b0 --- /dev/null +++ b/collects/test-suite/tool.ss @@ -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@))) + )