diff --git a/collects/test-box-recovery/doc.txt b/collects/test-box-recovery/doc.txt new file mode 100644 index 0000000000..f008fc0d09 --- /dev/null +++ b/collects/test-box-recovery/doc.txt @@ -0,0 +1,17 @@ + +Test Box Recovery Tool +---------------------- + +This tool allows DrScheme v370 and later to read programs created +using v360 and earlier that include test-case boxes. + +When opened using this tool, test-case boxes rae turned into +`check-expect' forms that work with the "testing.ss" teachpack. + +Test boxes plain-text tests and expected results are converted to +plain-text `check-expect' forms. + +If either the test or espected-result expression contains non-text +(e.g., an image), the converted form is a comment box containing a +`check-expect' form. The box should be easy to remove using the +"Uncomment" menu item in DrScheme. diff --git a/collects/test-box-recovery/info.ss b/collects/test-box-recovery/info.ss new file mode 100644 index 0000000000..e2e1a3033f --- /dev/null +++ b/collects/test-box-recovery/info.ss @@ -0,0 +1,10 @@ + +(module info (lib "infotab.ss" "setup") + (define doc.txt "doc.txt") + (define name "Test Box Recovery") + (define blurb '("Tool for v370 and later to open old programs with test-case boxes")) + (define categories '(devtools)) + (define required-core-version "370") + (define tools (list '("tool.ss"))) + (define tool-names (list "Test Box Recovery"))) + diff --git a/collects/test-box-recovery/tool.ss b/collects/test-box-recovery/tool.ss new file mode 100644 index 0000000000..b42064cb88 --- /dev/null +++ b/collects/test-box-recovery/tool.ss @@ -0,0 +1,108 @@ + +(module tool mzscheme + (require (lib "tool.ss" "drscheme") + (lib "mred.ss" "mred") + (lib "class.ss") + (lib "unit.ss") + (lib "framework.ss" "framework")) + + (provide tool@) + + (define tool@ + (unit + (import drscheme:tool^) + (export drscheme:tool-exports^) + + (define test-box-recovery-snipclass% + (class snip-class% + + (inherit reading-version) + + (define/private (strings? e) + (not (send e find-next-non-string-snip #f))) + + (define/private (extract-text e) + (regexp-replace* #rx"\r\n" (send e get-flattened-text) " ")) + + (define (make-string-snip s) + (make-object string-snip% s)) + + (define (make-comment-box . elems) + (let* ([s (new comment-box:snip%)] + [e (send s get-editor)]) + (for-each (lambda (elem) + (cond + [(string? elem) (send e insert elem)] + [(elem . is-a? . text%) + (let loop () + (let ([s (send elem find-first-snip)]) + (when s + (send elem release-snip s) + (send e insert s) + (loop))))] + [else (void)])) + elems) + s)) + + (define/override (read f) + (let ([enabled?-box (box 0)] + [collapsed?-box (box 0)] + [error-box?-box (box 0)] + [to-test (new text%)] + [expected (new text%)] + [predicate (new text%)] + [should-raise (new text%)] + [error-message (new text%)]) + (let ([vers (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)])) + (if (zero? (unbox error-box?-box)) + (if (and (strings? to-test) + (strings? expected)) + (make-string-snip + (format "(check-expect ~a ~a)" + (extract-text to-test) + (extract-text expected))) + (make-comment-box "(check-expect " + to-test + " " + expected + ")")) + (if (strings? to-test) + (make-string-snip + (format "(check-error ~a ~s)" + (extract-text to-test) + (extract-text error-message))) + (make-comment-box "(check-error " + to-test + " " + (extract-text error-message) + ")"))))) + + (super-new))) + + (define (phase1) + (let ([sc (new test-box-recovery-snipclass%)]) + (send sc set-classname "test-case-box%") + (send sc set-version 2) + (send (get-the-snip-class-list) add sc))) + + (define (phase2) + (void))))) +