From 3b630af6f977921f0a127344437124bff535daf4 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Sun, 21 Feb 2010 01:03:42 +0000 Subject: [PATCH 1/5] schemeunit: moved internal modules to schemeunit/private moved tests to tests/schemeunig added schemeunit/gui drscheme: fixed bug in show-backtrace-window svn: r18243 --- collects/drscheme/private/debug.ss | 2 +- collects/schemeunit/gui.ss | 18 + collects/schemeunit/info.ss | 36 +- collects/schemeunit/main.ss | 6 +- collects/schemeunit/{ => private}/base.ss | 0 .../schemeunit/{ => private}/check-info.ss | 0 collects/schemeunit/{ => private}/check.ss | 8 +- collects/schemeunit/{ => private}/counter.ss | 7 +- collects/schemeunit/{ => private}/format.ss | 23 +- collects/schemeunit/private/gui/cache-box.ss | 48 ++ collects/schemeunit/private/gui/config.ss | 45 ++ collects/schemeunit/private/gui/controller.ss | 50 ++ .../schemeunit/private/gui/drscheme-link.ss | 17 + .../schemeunit/private/gui/drscheme-ui.ss | 97 ++++ collects/schemeunit/private/gui/gui.ss | 150 ++++++ collects/schemeunit/private/gui/gvector.ss | 111 +++++ collects/schemeunit/private/gui/interfaces.ss | 63 +++ collects/schemeunit/private/gui/model.ss | 148 ++++++ collects/schemeunit/private/gui/model2rml.ss | 458 ++++++++++++++++++ .../schemeunit/private/gui/output-icon.png | Bin 0 -> 513 bytes collects/schemeunit/private/gui/rml.ss | 187 +++++++ collects/schemeunit/private/gui/view.ss | 306 ++++++++++++ .../schemeunit/{ => private}/hash-monad.ss | 0 collects/schemeunit/{ => private}/location.ss | 0 collects/schemeunit/{ => private}/monad.ss | 0 .../{ => private}/name-collector.ss | 2 +- collects/schemeunit/{ => private}/result.ss | 5 +- .../schemeunit/{ => private}/test-case.ss | 15 +- .../schemeunit/{ => private}/test-suite.ss | 13 +- collects/schemeunit/{ => private}/test.ss | 19 +- .../schemeunit/{ => private}/text-ui-util.ss | 0 collects/schemeunit/{ => private}/util.ss | 8 +- collects/schemeunit/run-tests.ss | 10 - collects/schemeunit/scribblings/base.ss | 8 +- collects/schemeunit/scribblings/ui.scrbl | 30 +- collects/schemeunit/text-ui.ss | 25 +- collects/schemeunit/tool.ss | 95 ++++ collects/tests/info.ss | 1 + .../schemeunit/all-schemeunit-tests.ss | 5 +- collects/{ => tests}/schemeunit/base-test.ss | 4 +- .../{ => tests}/schemeunit/check-info-test.ss | 4 +- collects/{ => tests}/schemeunit/check-test.ss | 19 +- .../{ => tests}/schemeunit/counter-test.ss | 10 +- .../{ => tests}/schemeunit/format-test.ss | 6 +- .../{ => tests}/schemeunit/hash-monad-test.ss | 6 +- .../{ => tests}/schemeunit/location-test.ss | 4 +- collects/{ => tests}/schemeunit/monad-test.ss | 4 +- .../{ => tests}/schemeunit/result-test.ss | 7 +- collects/tests/schemeunit/run-tests.ss | 9 + .../schemeunit/standalone-check-test.ss | 2 +- .../schemeunit/standalone-test-case-test.ss | 4 +- .../{ => tests}/schemeunit/test-case-test.ss | 10 +- .../{ => tests}/schemeunit/test-suite-test.ss | 7 +- collects/{ => tests}/schemeunit/test-test.ss | 20 +- .../{ => tests}/schemeunit/text-ui-test.ss | 7 +- .../schemeunit/text-ui-util-test.ss | 4 +- collects/{ => tests}/schemeunit/util-test.ss | 5 +- collects/tests/srfi/19/tests.ss | 2 +- collects/tests/xml/test-clark.ss | 9 +- 59 files changed, 1962 insertions(+), 197 deletions(-) create mode 100644 collects/schemeunit/gui.ss rename collects/schemeunit/{ => private}/base.ss (100%) rename collects/schemeunit/{ => private}/check-info.ss (100%) rename collects/schemeunit/{ => private}/check.ss (99%) rename collects/schemeunit/{ => private}/counter.ss (97%) rename collects/schemeunit/{ => private}/format.ss (83%) create mode 100644 collects/schemeunit/private/gui/cache-box.ss create mode 100644 collects/schemeunit/private/gui/config.ss create mode 100644 collects/schemeunit/private/gui/controller.ss create mode 100644 collects/schemeunit/private/gui/drscheme-link.ss create mode 100644 collects/schemeunit/private/gui/drscheme-ui.ss create mode 100644 collects/schemeunit/private/gui/gui.ss create mode 100644 collects/schemeunit/private/gui/gvector.ss create mode 100644 collects/schemeunit/private/gui/interfaces.ss create mode 100644 collects/schemeunit/private/gui/model.ss create mode 100644 collects/schemeunit/private/gui/model2rml.ss create mode 100644 collects/schemeunit/private/gui/output-icon.png create mode 100644 collects/schemeunit/private/gui/rml.ss create mode 100644 collects/schemeunit/private/gui/view.ss rename collects/schemeunit/{ => private}/hash-monad.ss (100%) rename collects/schemeunit/{ => private}/location.ss (100%) rename collects/schemeunit/{ => private}/monad.ss (100%) rename collects/schemeunit/{ => private}/name-collector.ss (98%) rename collects/schemeunit/{ => private}/result.ss (98%) rename collects/schemeunit/{ => private}/test-case.ss (95%) rename collects/schemeunit/{ => private}/test-suite.ss (98%) rename collects/schemeunit/{ => private}/test.ss (96%) rename collects/schemeunit/{ => private}/text-ui-util.ss (100%) rename collects/schemeunit/{ => private}/util.ss (96%) delete mode 100644 collects/schemeunit/run-tests.ss create mode 100644 collects/schemeunit/tool.ss rename collects/{ => tests}/schemeunit/all-schemeunit-tests.ss (95%) rename collects/{ => tests}/schemeunit/base-test.ss (97%) rename collects/{ => tests}/schemeunit/check-info-test.ss (98%) rename collects/{ => tests}/schemeunit/check-test.ss (97%) rename collects/{ => tests}/schemeunit/counter-test.ss (91%) rename collects/{ => tests}/schemeunit/format-test.ss (86%) rename collects/{ => tests}/schemeunit/hash-monad-test.ss (95%) rename collects/{ => tests}/schemeunit/location-test.ss (97%) rename collects/{ => tests}/schemeunit/monad-test.ss (98%) rename collects/{ => tests}/schemeunit/result-test.ss (94%) create mode 100644 collects/tests/schemeunit/run-tests.ss rename collects/{ => tests}/schemeunit/standalone-check-test.ss (97%) rename collects/{ => tests}/schemeunit/standalone-test-case-test.ss (87%) rename collects/{ => tests}/schemeunit/test-case-test.ss (85%) rename collects/{ => tests}/schemeunit/test-suite-test.ss (93%) rename collects/{ => tests}/schemeunit/test-test.ss (96%) rename collects/{ => tests}/schemeunit/text-ui-test.ss (98%) rename collects/{ => tests}/schemeunit/text-ui-util-test.ss (96%) rename collects/{ => tests}/schemeunit/util-test.ss (96%) diff --git a/collects/drscheme/private/debug.ss b/collects/drscheme/private/debug.ss index 9bc312d2cf..a60d0c792b 100644 --- a/collects/drscheme/private/debug.ss +++ b/collects/drscheme/private/debug.ss @@ -612,7 +612,7 @@ profile todo: (let ([dis (if (exn? dis/exn) (cms->srclocs (exn-continuation-marks dis/exn)) dis/exn)]) - (show-backtrace-window/edition-pairs error-text dis (map (λ (x) #f) dis/exn) defs rep))) + (show-backtrace-window/edition-pairs error-text dis (map (λ (x) #f) dis) defs rep))) (define (show-backtrace-window/edition-pairs error-text dis editions defs ints) (reset-backtrace-window) diff --git a/collects/schemeunit/gui.ss b/collects/schemeunit/gui.ss new file mode 100644 index 0000000000..325b3d8949 --- /dev/null +++ b/collects/schemeunit/gui.ss @@ -0,0 +1,18 @@ +#lang scheme/base +(require scheme/contract + (rename-in "private/base.ss") + "private/gui/gui.ss") + +(define (test/gui . tests) + (apply (make-gui-runner) tests)) + +(define test/c (or/c schemeunit-test-case? schemeunit-test-suite?)) + +(provide/contract + [test/gui + (->* () () #:rest (listof test/c) + any)] + [make-gui-runner + (-> + (->* () () #:rest (listof test/c) + any))]) diff --git a/collects/schemeunit/info.ss b/collects/schemeunit/info.ss index 6daf17b020..24ded45f9d 100644 --- a/collects/schemeunit/info.ss +++ b/collects/schemeunit/info.ss @@ -5,39 +5,9 @@ (define blurb '((p "SchemeUnit is a unit testing framework based on the " " Extreme Programming unit test frameworks"))) -(define repositories '("4.x")) -(define required-core-version "4.0.0.0") -(define categories '(devtools)) -(define can-be-loaded-with 'all) +(define scribblings '(("scribblings/schemeunit.scrbl" (multi-page) (tool)))) +(define tools '[("tool.ss")]) +(define tool-names '["SchemeUnit DrScheme integration"]) (define homepage "http://schematics.sourceforge.net/") (define url "http://schematics.sourceforge.net/") - -(define primary-file "main.ss") -(define scribblings '(("scribblings/schemeunit.scrbl" (multi-page) (tool)))) - -(define release-notes - '((p "Correctly handle arbitrary expressions in test suites and fix Scribble errors."))) - -;; -;; The data below applies to the graphical UI. It is kept -;; around for when the GUI is ported to the current -;; SchemeUnit -;; - -;; (define tools '[("drscheme-ui-tool.ss" "plt" "gui")]) -;; (define tool-names '["SchemeUnit DrScheme integration"]) - - ;; Information about SchemeUnit tests for package - -;; (define schemeunit:test-name 'all-schemeunit-tests) -;; (define schemeunit:test-module "all-schemeunit-tests.ss") - - ;; Information about distribution - -;; (define distribution-method 'planet) -;; (define distribution-package-spec '("schematics" "schemeunit.plt" 3 0)) - - - - diff --git a/collects/schemeunit/main.ss b/collects/schemeunit/main.ss index 7b994f1f17..c0f7b440ed 100644 --- a/collects/schemeunit/main.ss +++ b/collects/schemeunit/main.ss @@ -27,7 +27,5 @@ ;; Commentary: #lang scheme/base - -(require "test.ss") - -(provide (all-from-out "test.ss")) +(require "private/test.ss") +(provide (all-from-out "private/test.ss")) diff --git a/collects/schemeunit/base.ss b/collects/schemeunit/private/base.ss similarity index 100% rename from collects/schemeunit/base.ss rename to collects/schemeunit/private/base.ss diff --git a/collects/schemeunit/check-info.ss b/collects/schemeunit/private/check-info.ss similarity index 100% rename from collects/schemeunit/check-info.ss rename to collects/schemeunit/private/check-info.ss diff --git a/collects/schemeunit/check.ss b/collects/schemeunit/private/check.ss similarity index 99% rename from collects/schemeunit/check.ss rename to collects/schemeunit/private/check.ss index ab5d381064..a9fddae8e2 100644 --- a/collects/schemeunit/check.ss +++ b/collects/schemeunit/private/check.ss @@ -1,11 +1,9 @@ #lang scheme/base (require (for-syntax scheme/base - "location.ss")) - -(require srfi/1) - -(require "base.ss" + "location.ss") + srfi/1 + "base.ss" "check-info.ss" "format.ss" "location.ss") diff --git a/collects/schemeunit/counter.ss b/collects/schemeunit/private/counter.ss similarity index 97% rename from collects/schemeunit/counter.ss rename to collects/schemeunit/private/counter.ss index aa56f6444d..208d599b77 100644 --- a/collects/schemeunit/counter.ss +++ b/collects/schemeunit/private/counter.ss @@ -28,10 +28,9 @@ #lang scheme/base -(require - (file "base.ss") - (file "monad.ss") - (file "hash-monad.ss")) +(require "base.ss" + "monad.ss" + "hash-monad.ss") (provide display-counter update-counter! diff --git a/collects/schemeunit/format.ss b/collects/schemeunit/private/format.ss similarity index 83% rename from collects/schemeunit/format.ss rename to collects/schemeunit/private/format.ss index 88dbe4894e..0e4fd5dbd0 100644 --- a/collects/schemeunit/format.ss +++ b/collects/schemeunit/private/format.ss @@ -1,20 +1,19 @@ #lang scheme/base (require scheme/match - srfi/13) + srfi/13 + "check-info.ss") -(require "check-info.ss") +(provide display-check-info-name-value + display-check-info + display-check-info-stack + display-test-name + display-exn + + display-delimiter + display-failure + display-error) -(provide - display-check-info-name-value - display-check-info - display-check-info-stack - display-test-name - display-exn - - display-delimiter - display-failure - display-error) ;; name-width : integer ;; ;; Number of characters we reserve for the check-info name column diff --git a/collects/schemeunit/private/gui/cache-box.ss b/collects/schemeunit/private/gui/cache-box.ss new file mode 100644 index 0000000000..6d5230a5be --- /dev/null +++ b/collects/schemeunit/private/gui/cache-box.ss @@ -0,0 +1,48 @@ +#lang scheme/base +(require scheme/contract) + +;; Add a new kind of promise instead? + +;; FIXME: handle exceptions like promises? + +(define (make-cache* thunk) + (make-cache thunk #f)) + +(define (cache-ref cb) + (let ([result (cache-result cb)]) + (if result + (apply values result) + (call-with-values (cache-thunk cb) + (lambda result + (set-cache-result! cb result) + (apply values result)))))) + +(define (cache-invalidate! cb) + (set-cache-result! cb #f)) + +(define (cache-printer cb port write?) + (let ([result (cache-result cb)]) + (if result + (fprintf port + (if write? "#" "#") + (if (and (pair? result) (null? (cdr result))) + (car result) + (cons 'values result))) + (fprintf port "#")))) + +(define-struct cache (thunk [result #:mutable]) + #:property prop:custom-write cache-printer) + +(define-syntax-rule (cache* expr) + (make-cache* (lambda () expr))) + +(provide (rename-out [cache* cache])) +(provide/contract + [rename make-cache* make-cache + (-> (-> any) cache?)] + [cache? + (-> any/c boolean?)] + [cache-ref + (-> cache? any)] + [cache-invalidate! + (-> cache? any)]) diff --git a/collects/schemeunit/private/gui/config.ss b/collects/schemeunit/private/gui/config.ss new file mode 100644 index 0000000000..3c2c899160 --- /dev/null +++ b/collects/schemeunit/private/gui/config.ss @@ -0,0 +1,45 @@ +#lang scheme/base +(require framework + unstable/gui/prefs) +(provide (all-defined-out)) + +;; Frame size preferences + +(preferences:set-default 'schemeunit:frame:width 400 exact-positive-integer?) +(preferences:set-default 'schemeunit:frame:height 400 exact-positive-integer?) +(define pref:width (pref:get/set 'schemeunit:frame:width)) +(define pref:height (pref:get/set 'schemeunit:frame:height)) + +;; CONSTANTS +;; Some of these are obsolete, given the preferences above. + +(define DETAILS-CANVAS-INIT-WIDTH 400) +(define FRAME-LABEL "SchemeUnit") +(define FRAME-INIT-HEIGHT 400) +(define TREE-INIT-WIDTH 240) +(define TREE-COLORIZE-CASES #t) +(define DIALOG-ERROR-TITLE "SchemeUnit: Error") +(define STATUS-SUCCESS 'success) +(define STATUS-FAILURE 'failure) +(define STATUS-ERROR 'error) +(define STATUS-UNEXECUTED 'unexecuted) +(define VIEW-PANE-PERCENTS + (let [(total (+ DETAILS-CANVAS-INIT-WIDTH TREE-INIT-WIDTH))] + (list (/ TREE-INIT-WIDTH total) (/ DETAILS-CANVAS-INIT-WIDTH total)))) + +;; Conventional assertion-info keys. +;; These must be kept in sync with assert-base.ss. +(define prop:failure-assertion 'name) +(define prop:failure-parameters 'params) +(define prop:failure-location 'location) +(define prop:failure-message 'message) +(define prop:test-case-location 'test-case-location) + +;; / CONSTANTS + +(define (known-property? s) + (case s + ((name params location message test-case-location) #t) + ((actual expected) #t) + ((expression) #t) + (else #f))) diff --git a/collects/schemeunit/private/gui/controller.ss b/collects/schemeunit/private/gui/controller.ss new file mode 100644 index 0000000000..c89d3d9e9e --- /dev/null +++ b/collects/schemeunit/private/gui/controller.ss @@ -0,0 +1,50 @@ +#lang scheme/base +(require scheme/class + unstable/class-iop + unstable/gui/notify + "../base.ss" + "interfaces.ss" + "model.ss" + "view.ss") +(provide controller%) + +(define controller% + (class* object% (controller<%>) + (init display-window) + (super-new) + + ;; model-shown : (notify-box (U model<%> #f)) + ;; The model currently displayed in the Details view, of #f is none. + (define-notify selected-model (new notify-box% (value #f))) + + (define view + (new view% + (controller this) + (parent (send display-window get-area-container)))) + + ;; create-model : test suite<%>/#f -> result<%> + (define/public (create-model test parent) + (define result + (cond [(schemeunit-test-case? test) + (new case-result% + (controller this) + (test test) + (name (or (schemeunit-test-case-name test) + "")) + (parent parent))] + [(schemeunit-test-suite? test) + (new suite-result% + (controller this) + (test test) + (name (or (schemeunit-test-suite-name test) + "")) + (parent parent))])) + (send/i view view<%> create-view-link result parent) + result) + + ;; on-model-status-change : model<%> -> void + (define/public (on-model-status-change model) + (send view queue-for-update model) + (let [(parent (send model get-parent))] + (when parent (send parent on-child-status-change model)))) + )) diff --git a/collects/schemeunit/private/gui/drscheme-link.ss b/collects/schemeunit/private/gui/drscheme-link.ss new file mode 100644 index 0000000000..ecdc54579b --- /dev/null +++ b/collects/schemeunit/private/gui/drscheme-link.ss @@ -0,0 +1,17 @@ +;; Written in #%kernel to avoid adding any module-attachment +;; dependencies. Initialized by the DrScheme integration tool. + +(module drscheme-link '#%kernel + (#%provide link) + + #| + + If initialized (has non-#f value), the box should contain a vector + of the following procedures: + + (vector get-errortrace-backtrace + show-backtrace + show-source) + |# + + (define-values (link) (box #f))) diff --git a/collects/schemeunit/private/gui/drscheme-ui.ss b/collects/schemeunit/private/gui/drscheme-ui.ss new file mode 100644 index 0000000000..92ab07313c --- /dev/null +++ b/collects/schemeunit/private/gui/drscheme-ui.ss @@ -0,0 +1,97 @@ +#lang scheme/base +(require scheme/list + scheme/string + mzlib/etc + "drscheme-link.ss") + +;; Procedures which *may* be overridden by DrScheme to do useful things. +;; Or they may not be. + +(provide has-backtrace? + has-errortrace-backtrace? + has-primitive-backtrace? + show-errortrace-backtrace + show-primitive-backtrace + can-show-source? + show-source) + +;; A Backtrace is one of +;; - exn +;; - (listof srcloc) + +(define USE-PRIMITIVE-STACKTRACE? #f) + +;; has-backtrace? : exn -> boolean +(define (has-backtrace? exn) + (or (has-errortrace-backtrace? exn) + (has-primitive-backtrace? exn))) + +;; has-errortrace-backtrace? : exn -> boolean +(define (has-errortrace-backtrace? exn) + (not (null? (get-errortrace-backtrace exn)))) + +;; has-primitive-backtrace? : exn -> boolean +(define (has-primitive-backtrace? exn) + (and USE-PRIMITIVE-STACKTRACE? + (pair? (get-primitive-backtrace exn)))) + +;; get-errortrace-backtrace : exn -> Backtrace +(define (get-errortrace-backtrace exn) + ((get-errortrace-backtrace*) exn)) + +;; get-primitive-backtrace : exn -> Backtrace +(define (get-primitive-backtrace exn) + (let* ([ctx (continuation-mark-set->context + (exn-continuation-marks exn))] + [srclocs (map cdr ctx)]) + (filter (lambda (s) + (and (srcloc? s) + (let ([src (srcloc-source s)]) + (and (path? src) + (not (regexp-match? + (regexp-quote + (path->string + (this-expression-source-directory))) + (path->string src))))))) + srclocs))) + +;; show-errortrace-backtrace : exn -> void +(define (show-errortrace-backtrace exn) + ((show-backtrace*) + (exn-message exn) + (get-errortrace-backtrace exn))) + +;; show-primitive-backtrace : exn -> void +(define (show-primitive-backtrace exn) + ((show-backtrace*) + (exn-message exn) + (get-primitive-backtrace exn))) + +;; can-show-source? : -> boolean +(define (can-show-source?) + (can-show-source?*)) + +;; show-source : source number number -> void +(define (show-source src pos span) + ((show-source*) src pos span)) + +;; ---- + +(define (get-link n) + (let ([v (unbox link)]) + (and (vector? v) (vector-ref v n)))) + +(define (get-errortrace-backtrace*) + (or (get-link 0) + (lambda (exn) null))) + +(define (show-backtrace*) + (or (get-link 1) + void)) + +(define (show-source*) + (or (get-link 2) + void)) + +(define (can-show-source?*) + (vector? (unbox link))) diff --git a/collects/schemeunit/private/gui/gui.ss b/collects/schemeunit/private/gui/gui.ss new file mode 100644 index 0000000000..efb4289c46 --- /dev/null +++ b/collects/schemeunit/private/gui/gui.ss @@ -0,0 +1,150 @@ +#lang scheme/base +(require scheme/class + unstable/class-iop + scheme/gui + "../base.ss" + "../result.ss" + "../check-info.ss" + "interfaces.ss" + "controller.ss" + "view.ss") +(provide make-gui-runner) + +(define (make-gui-runner) + (define frame + (parameterize ((current-eventspace (make-eventspace))) + (make-view-frame))) + (define controller + (new controller% + (display-window frame))) + (lambda tests + (for ([test (in-list tests)]) + (run test controller)))) + +(define (run test controller) + ;; state = parent result<%> + + (define (for-suite-entry suite name before after state) + (define model + (send/i controller controller<%> create-model suite state)) + (before) + model) + + (define (for-suite-exit suite name before after state kid-state) + (after) + (send/i kid-state suite<%> finish!) + state) + + (define (for-case case name action state) + (define model + (send/i controller controller<%> create-model case state)) + (run-case case model) + state) + + (foldts for-suite-entry for-suite-exit for-case + #f test)) + +;; From old suite-runner: +#| +(define/public (run) + (let ([custodian (make-custodian)] + [before (schemeunit-test-suite-before test)] + [after (schemeunit-test-suite-after test)]) + (parameterize [(current-custodian custodian)] + (dynamic-wind + before + (lambda () + (for-each (lambda (c) (send c run)) (get-children)) + (custodian-shutdown-all custodian)) + after))) + (on-child-status-change #f)) +|# + +;; ---- + +(define (run-case test model) + (define primerr (current-error-port)) + (define iport (open-input-string "")) + (define super-cust (current-custodian)) + (define cust (make-custodian)) + (define-values (oport errport get-output) + (make-output-ports)) + (let-values ([(test-result timing) + (parameterize [(current-input-port iport) + (current-output-port oport) + (current-error-port errport) + (current-custodian cust)] + (run/time-test test))]) + ;;(set! timing times) + (define trash + (map (lambda (x) (format "~s" x)) + (custodian-managed-list cust super-cust))) + (cond [(test-success? test-result) + (send/i model case<%> update + test-result + (test-success-result test-result) + null + timing + (get-output) + trash)] + [(test-failure? test-result) + (let* ([exn (test-failure-result test-result)] + [property-stack (exn:test:check-stack exn)]) + (send/i model case<%> update + test-result + (test-failure-result test-result) + (for/list ([pp property-stack]) + (cons (check-info-name pp) (check-info-value pp))) + timing + (get-output) + trash))] + [(test-error? test-result) + (send/i model case<%> update + test-result + (test-error-result test-result) + null + timing + (get-output) + trash)]))) + +(define (run/time-test test) + (let-values ([(results cputime realtime gctime) + (call-with-continuation-prompt + (lambda () + (time-apply run-test-case + (list (schemeunit-test-case-name test) + (schemeunit-test-case-action test)))))]) + (values (car results) (list cputime realtime gctime)))) + +(define (make-output-ports) + (define output null) + (define output-sema (make-semaphore 1)) + (define (make-output-collector tag) + (define (do-write-out buf start end) + (define subbuf (subbytes buf start end)) + (if (and (pair? output) + (eq? (car (car output)) tag)) + ;; Coalesce + (let ([prev (cdr (car output))]) + (set! output + (cons (cons tag (cons subbuf prev)) (cdr output)))) + (set! output (cons (list tag subbuf) output))) + (- end start)) + (define name #f) + (define evt output-sema) + (define (write-out buf start end buffer? enable-break?) + ((if enable-break? sync/enable-break sync) output-sema) + (begin0 (do-write-out buf start end) (semaphore-post output-sema))) + (define (close) (void)) + (define (get-write-evt buf start end) + (wrap-evt output-sema + (lambda (_) + (begin0 (write-out buf start end #f #f) + (semaphore-post output-sema))))) + (make-output-port name evt write-out close #f + get-write-evt #f)) + (values (make-output-collector 'output) + (make-output-collector 'error) + (lambda () output))) + + diff --git a/collects/schemeunit/private/gui/gvector.ss b/collects/schemeunit/private/gui/gvector.ss new file mode 100644 index 0000000000..cf3c3433ac --- /dev/null +++ b/collects/schemeunit/private/gui/gvector.ss @@ -0,0 +1,111 @@ +#lang scheme/base +(require scheme/contract + scheme/dict) + +(define (make-gvector* #:capacity [capacity 10]) + (make-gvector (make-vector capacity #f) 0)) + +(define (check-index who index n) + (unless (exact-nonnegative-integer? index) + (raise-type-error who "exact nonnegative integer" index)) + (unless (< index n) + (if (zero? n) + (error who "index out of range for empty gvector: ~s" index) + (error who "index out of range [0,~s]: ~s" (sub1 n) index)))) + +(define ((bad-index-error who index)) + (raise-mismatch-error who "index out of range" index)) + +(define (gvector-add! gv item) + (let ([n (gvector-n gv)] + [v (gvector-vec gv)]) + (cond [(< n (vector-length v)) + (vector-set! v n item) + (set-gvector-n! gv (add1 n))] + [else + (let ([nv (make-vector (* 2 n) #f)]) + (vector-copy! nv 0 v) + (vector-set! nv n item) + (set-gvector-vec! gv nv) + (set-gvector-n! gv (add1 n)))]))) + +;; SLOW! +(define (gvector-remove! gv index) + (let ([n (gvector-n gv)] + [v (gvector-vec gv)]) + (check-index 'gvector-remove! index n) + (set-gvector-n! gv (sub1 n)) + (vector-copy! v index v (add1 index) n) + (vector-set! v (sub1 n) #f))) + +(define (gvector-count gv) + (gvector-n gv)) + +(define (gvector-ref gv index + [default (bad-index-error 'gvector-ref index)]) + (unless (exact-nonnegative-integer? index) + (raise-type-error 'gvector-ref "exact nonnegative integer" index)) + (if (< index (gvector-n gv)) + (vector-ref (gvector-vec gv) index) + (if (procedure? default) + (default) + default))) + +(define (gvector-set! gv index item) + (check-index 'gvector-set! index (gvector-n gv)) + (vector-set! (gvector-vec gv) index item)) + +;; Iteration methods + +(define (gvector-iterate-first gv) + (and (positive? (gvector-n gv)) 0)) + +(define (gvector-iterate-next gv iter) + (check-index 'gvector-iterate-next iter (gvector-n gv)) + (let ([n (gvector-n gv)]) + (and (< (add1 iter) n) + (add1 iter)))) + +(define (gvector-iterate-key gv iter) + (check-index 'gvector-iterate-key iter (gvector-n gv)) + iter) + +(define (gvector-iterate-value gv iter) + (check-index 'gvector-iterate-value iter (gvector-n gv)) + (gvector-ref gv iter)) + +(define (in-gvector gv) + (unless (gvector? gv) + (raise-type-error 'in-gvector "gvector" gv)) + (in-dict-values gv)) + +(define-struct gvector (vec n) + #:mutable + #:property prop:dict + (vector gvector-ref + gvector-set! + #f ;; set + gvector-remove! + #f ;; remove + gvector-count + gvector-iterate-first + gvector-iterate-next + gvector-iterate-key + gvector-iterate-value) + #:property prop:sequence in-gvector) + +(provide/contract + [rename make-gvector* make-gvector + (->* () (#:capacity exact-positive-integer?) any)] + [gvector-ref + (-> gvector? exact-nonnegative-integer? any)] + [gvector-set! + (-> gvector? exact-nonnegative-integer? any/c any)] + [gvector-add! + (-> gvector? any/c any)] + [gvector-remove! + (-> gvector? exact-nonnegative-integer? any)] + [gvector-count + (-> gvector? any)] + [in-gvector + (-> gvector? sequence?)]) diff --git a/collects/schemeunit/private/gui/interfaces.ss b/collects/schemeunit/private/gui/interfaces.ss new file mode 100644 index 0000000000..b48007a9c7 --- /dev/null +++ b/collects/schemeunit/private/gui/interfaces.ss @@ -0,0 +1,63 @@ +#lang scheme/base +(require scheme/class + unstable/class-iop) +(provide (all-defined-out)) + +;; controller +;; Manages the model and view. +;; Propagates status changes from model to view. +(define-interface controller<%> () + (get-selected-model + set-selected-model + listen-selected-model + + create-model + on-model-status-change)) + +;; result +;; Represents a test (case or suite) together with the state associated +;; with the last run of that test. +(define-interface result<%> () + (get-test + get-parent + get-name + get-controller + + finished? + success? + failure? + error? + has-output? + has-trash? + + get-total-cases + get-total-successes + get-total-failures)) + +(define-interface case<%> (result<%>) + (update + get-result + get-timing + get-output + get-trash + get-property + get-property-set + get-all-properties)) + +(define-interface suite<%> (result<%>) + (get-children + add-child + finish! + on-child-status-change)) + + +;; view +;; Presents a graphical interface for inspecting and running tests. +(define-interface view<%> () + (create-view-link + queue-for-update)) + +;; style-map +;; Maps symbolic style names ('bold, 'red) to MrEd styles. +(define-interface style-map<%> () + (get-style)) diff --git a/collects/schemeunit/private/gui/model.ss b/collects/schemeunit/private/gui/model.ss new file mode 100644 index 0000000000..aaee04c5a3 --- /dev/null +++ b/collects/schemeunit/private/gui/model.ss @@ -0,0 +1,148 @@ +#lang scheme/base +(require scheme/class + unstable/class-iop + scheme/list + "gvector.ss" + "../base.ss" + "interfaces.ss" + "cache-box.ss") +(provide case-result% + suite-result%) + +(define result% + (class* object% () + (super-new) + + (init-field parent + controller + name + test) + + (when parent + (send/i parent suite<%> add-child this)) + + (define/public (get-parent) parent) + (define/public (get-name) name) + (define/public (get-controller) controller) + (define/public (get-test) test) + )) + +;; case-result% +(define case-result% + (class* result% (case<%>) + (super-new) + + (inherit get-name + get-parent + get-controller) + + ;; *result : #f or test-result + ;; #f means not finished executing + (define *result #f) + + (define result #f) + (define properties #f) + (define timing #f) + (define output null) + (define trash null) + + (define/public (update *result* result* properties* timing* output* trash*) + (set! *result *result*) + (set! result result*) + (set! properties properties*) + (set! timing timing*) + (set! output output*) + (set! trash trash*) + (send/i (get-controller) controller<%> on-model-status-change this)) + + (define/public (finished?) (and *result #t)) + (define/public (success?) (test-success? *result)) + (define/public (failure?) (test-failure? *result)) + (define/public (error?) (test-error? *result)) + + (define/public (get-total-cases) 1) + (define/public (get-total-successes) + (if (success?) 1 0)) + (define/public (get-total-failures) + (if (or (failure?) (error?)) 1 0)) + + (define/public (get-result) result) + (define/public (get-timing) timing) + (define/public (get-trash) trash) + (define/public (has-trash?) (pair? trash)) + (define/public (get-property p) + (let [(v (assq p properties))] + (and v (cdr v)))) + (define/public (get-property-set p) + (map cdr (filter (lambda (kv) (eq? (car kv) p)) properties))) + (define/public (get-all-properties) + properties) + + (define/public (get-output) (reverse output)) + (define/public (has-output?) (pair? output)))) + + +;; suite-result% +(define suite-result% + (class* result% (suite<%>) + (super-new) + (inherit get-name + get-parent + get-controller) + + (define done? #f) + (define children (make-gvector)) + + ;; get-children : -> (listof result<%>) + (define/public (get-children) + (for/list ([x (in-gvector children)]) x)) + + (define/public (add-child c) + (gvector-add! children c)) + + (define/public (finish!) + (set! done? #t) + (send/i (get-controller) controller<%> on-model-status-change this)) + + (define children-cache + (cache (for/fold ([cs 0] [ss 0] [fs 0] [out? #f] [trash? #f]) + ([c (in-gvector children)]) + (values (+ cs (send/i c result<%> get-total-cases)) + (+ ss (send/i c result<%> get-total-successes)) + (+ fs (send/i c result<%> get-total-failures)) + (or out? (send/i c result<%> has-output?)) + (or trash? (send/i c result<%> has-trash?)))))) + + (define/public (finished?) + done?) + (define/public (get-total-cases) + (define-values (c _s _f _o _t) (cache-ref children-cache)) + c) + (define/public (get-total-successes) + (define-values (_c s _f _o _t) (cache-ref children-cache)) + s) + (define/public (get-total-failures) + (define-values (_c _s f _o _t) (cache-ref children-cache)) + f) + (define/public (has-output?) + (define-values (_c _s _f o _t) (cache-ref children-cache)) + o) + (define/public (has-trash?) + (define-values (_c _s _f _o t) (cache-ref children-cache)) + t) + + (define/public (success?) + (and (finished?) (zero? (get-total-failures)))) + (define/public (failure?) + (positive? (get-total-failures))) + (define/public (error?) #f) + + ;; on-child-status-change : model<%> -> void + (define/public (on-child-status-change child) + (let ([result + (call-with-values (lambda () (cache-ref children-cache)) list)]) + (cache-invalidate! children-cache) + (let ([new-result + (call-with-values (lambda () (cache-ref children-cache)) list)]) + (unless (equal? new-result result) + (send/i (get-controller) controller<%> on-model-status-change this))))))) diff --git a/collects/schemeunit/private/gui/model2rml.ss b/collects/schemeunit/private/gui/model2rml.ss new file mode 100644 index 0000000000..c9f48fe4b6 --- /dev/null +++ b/collects/schemeunit/private/gui/model2rml.ss @@ -0,0 +1,458 @@ +#lang scheme/base +(require scheme/class + unstable/class-iop + scheme/list + scheme/gui + scheme/match + scheme/file + mrlib/include-bitmap + (prefix-in drlink: "drscheme-ui.ss") + "interfaces.ss" + "config.ss") +(provide model-renderer% + output-icon) + +(define (output-icon) + (make-object image-snip% (include-bitmap "output-icon.png"))) + +(define top-align (make-object style-delta% 'change-alignment 'top)) + +(define model-renderer% + (class object% + (init-field controller) + (init-field editor) + (super-new) + + (define/public (render-model/short model) + (cond [(is-a? model suite<%>) ;; (test-suite? test) + (render-suite-short-form model)] + [(is-a? model case<%>) ;; (test-case? test) + (render-case-short-form model)])) + + (define/public (render-model/long model) + (cond [(is-a? model suite<%>) ;; (test-suite? test) + (render-suite-long-form model)] + [(is-a? model case<%>) ;; (test-case? test) + (render-case-long-form model)])) + + (define/private (put styles . texts) + (send/apply editor insert/styles styles texts)) + + (define/private (put+click styles clickback . texts) + (send/apply editor insert/styles+click styles clickback texts)) + + (define/private (blank) + (send editor newline)) + + (define/private (n-things number singular plural) + (if (= 1 number) + (format "~a ~a" number singular) + (format "~a ~a" number plural))) + + (define/private (render-suite-long-form model) + (let [(suite (send/i model suite<%> get-test)) + (children (send/i model suite<%> get-children)) + (parent (send/i model suite<%> get-parent))] + (let* [(successes + (filter (lambda (c) (send/i c result<%> success?)) children)) + (failures + (filter (lambda (c) (send/i c result<%> failure?)) children)) + (errors + (filter (lambda (c) (send/i c result<%> error?)) children)) + (unexecuted + (filter (lambda (c) (not (send/i c result<%> finished?))) children)) + (finished? (send/i model suite<%> finished?)) + (num-tests (length children)) + (count-successes (length successes)) + (count-failures (length failures)) + (count-errors (length errors)) + (count-unexecuted (length unexecuted)) + (total-successes (send/i model suite<%> get-total-successes)) + (total-failures (send/i model suite<%> get-total-failures)) + (total-cases (send/i model suite<%> get-total-cases)) + (output? (send/i model suite<%> has-output?)) + (trash? (send/i model suite<%> has-trash?))] + (put '(large italic bold) (send/i model suite<%> get-name) "\n") + (when parent + (put '() " (in ") + (put+click '(clickback bold) + (lambda _ (send/i controller controller<%> set-selected-model parent)) + (send/i parent result<%> get-name)) + (put '() ")\n")) + (blank) + (if (positive? total-cases) + (begin (put '() (format "Total: ~a" + (n-things total-successes "success" "successes"))) + (when (positive? total-failures) + (put '() (format ", ~a" + (n-things total-failures "failure" "failures")))) + (blank) + (blank) + (when trash? + (put (list top-align) (output-icon)) + (put '() "Tests did not clean up resources.\n")) + (when output? + (put (list top-align) (output-icon)) + (put '() "Tests produced output.\n")) + (when (or trash? output?) + (blank)) + (when (positive? count-failures) + (put '(large) + (format "Failures (~a/~a)\n" + count-failures + num-tests)) + (for-each (lambda (m) (render-model/short m)) failures) + (blank)) + (when (positive? count-errors) + (put '(large) + (format "Errors (~a/~a)\n" + count-errors + num-tests)) + (for-each (lambda (m) (render-model/short m)) errors) + (blank)) + (when (positive? count-unexecuted) + (put '(large) + (format "Unexecuted (~a/~a)\n" + (length unexecuted) + num-tests)) + (for-each (lambda (m) (render-model/short m)) unexecuted) + (blank)) + (when (positive? count-successes) + (put '(large) + (format "Successes (~a/~a)\n" + count-successes + num-tests)) + (for-each (lambda (m) (render-model/short m)) successes) + (blank))) + (if finished? + (put '() + "This test suite is empty.") + (put '(test-unexecuted) + "This test suite has not been executed.")))))) + + (define/private (render-model-link model suite?) + (let ([styles (if suite? '(clickback bold) '(clickback))]) + (put+click styles + (lambda _ (send/i controller controller<%> set-selected-model model)) + (send/i model result<%> get-name)) + (when (or (send/i model result<%> has-output?) + (send/i model result<%> has-trash?)) + (put styles (output-icon))))) + + (define/private (render-suite-short-form model) + (let [(suite (send/i model suite<%> get-test))] + (let* [(children (send/i model suite<%> get-children)) + (successes + (filter (lambda (c) (send/i c result<%> success?)) children)) + (failures + (filter (lambda (c) (send/i c result<%> failure?)) children)) + (errors + (filter (lambda (c) (send/i c result<%> error?)) children)) + (unexecuted + (filter (lambda (c) (not (send/i c result<%> finished?))) children)) + (num-tests (length children)) + (total-failures (send/i model suite<%> get-total-failures))] + (let [(style (if (and (null? failures) (null? errors)) 'normal 'red))] + (render-model-link model #t) + (if (send/i model suite<%> finished?) + (when (positive? total-failures) + (put `(,style) + (format " (~a)" + (n-things total-failures "failure" "failures")))) + (put '(test-unexecuted) " not yet executed")) + (blank))))) + + (define/private (render-case-short-form model) + (cond [(send/i model case<%> success?) + (render-success-short-form model)] + [(send/i model case<%> failure?) + (render-failure-short-form model)] + [(send/i model case<%> error?) + (render-error-short-form model)] + [(not (send/i model case<%> finished?)) + (render-not-executed-short-form model)])) + + (define/private (render-success-short-form model) + (render-model-link model #f) + (put '() " succeeded\n")) + + (define/private (render-failure-short-form model) + (let* [(exn (send/i model case<%> get-result)) + (exnmsg (send/i model case<%> get-property prop:failure-message)) + (exnname (send/i model case<%> get-property prop:failure-assertion))] + (render-model-link model #f) + (put '() " failed") + (when exnname + (put '() " on ") + (put '(fail-type) (format "~a" exnname))) + (when exnmsg + (put '() " with message: ") + (put '(exn-message) exnmsg)) + (blank))) + + (define/private (render-error-short-form model) + (let [(exn (send/i model case<%> get-result))] + (render-model-link model #f) + (cond [(exn? exn) + (put '() " threw an exception of type ") + (put '(exn-type) (format "~a" (object-name exn))) + (put '() " with message: ") + (put '(exn-message) (exn-message exn))] + [else + (put '() (format " raised the value ~e" exn))]) + (blank))) + + (define/private (render-not-executed-short-form model) + (render-model-link model #f) + (put '(test-unexecuted) " has not been executed\n")) + + (define/private (render-case-long-form model) + (cond [(send/i model case<%> success?) + (render-success-long-form model)] + [(send/i model case<%> failure?) + (render-failure-long-form model)] + [(send/i model case<%> error?) + (render-error-long-form model)] + [(not (send/i model case<%> finished?)) + (render-not-executed-long-form model)]) + (when (send/i model case<%> finished?) + (render-timing model) + (render-trash model) + (render-output model))) + + (define/private (render-model-link* model suite?) + (let [(parent (send/i model result<%> get-parent))] + (let ([styles (if suite? '(bold) '())]) + (put `(large italic ,@styles) + (send/i model result<%> get-name)) + (blank) + (when parent + (put '() " in ") + (put+click `(clickback bold) + (lambda _ (send/i controller controller<%> set-selected-model parent)) + (send/i parent result<%> get-name)) + (blank)) + (blank)))) + + (define/private (render-success-long-form model) + (render-model-link* model #f) + (put '() "The test case succeeded.\n\n")) + + (define/private (render-failure-long-form model) + (render-model-link* model #f) + (let* [(exn (send/i model case<%> get-result)) + (failure-msgs (send/i model case<%> get-property-set prop:failure-message)) + (messages + (if (string? (exn-message exn)) + (cons (exn-message exn) failure-msgs) + failure-msgs)) + (exnname (send/i model case<%> get-property prop:failure-assertion)) + (exnlocs + (send/i model case<%> get-property-set prop:failure-location)) + (expecteds (send/i model case<%> get-property-set 'expected)) + (actuals (send/i model case<%> get-property-set 'actual)) + (params (send/i model case<%> get-property prop:failure-parameters)) + (other-properties + (filter (lambda (p) (not (known-property? (car p)))) + (send/i model case<%> get-all-properties))) + (exn2 (send/i model case<%> get-property 'exception))] + (put '() "The test case failed on ") + (put '(fail-type) (format "~a" exnname)) + (put '() ".\n\n") + (render-source-location "Check location" exnlocs) + (render-backtrace-link "Backtrace of check failure:" exn) + (render-messages messages) + (if (and (pair? expecteds) (pair? actuals)) + (render-expected+actual (car expecteds) (car actuals)) + (render-parameters params)) + (render-embedded-exception exn2) + (render-other-properties other-properties) + )) + + (define/private (render-error-long-form model) + (render-model-link* model #f) + (let [(exn (send/i model case<%> get-result))] + (cond [(exn? exn) + (put '() "The test case threw an exception of type ") + (put '(exn-type) (format "~a" (object-name exn))) + (put '() ".\n\n") + (render-backtrace-link "Exception backtrace:" exn) + (render-messages (list (exn-message exn))) + (render-value "Exception value:\n" exn)] + [else + (put '() "The test raised a value that was not " + "an instance of an exception struct.\n\n") + (render-value "Raised value:\n" exn)]))) + + (define/private (render-not-executed-long-form model) + (render-model-link* model #f) + (put '(test-unexecuted) + "The test case has not been executed.")) + + (define/private (render-value text value) + (put '() text) + (render-value-box value) + (blank)) + + (define/private (render-value-box value) + (send editor insert-wide-box + (lambda (editor) + (send editor insert/styles '(value) (format "~v" value))))) + + (define/private (render-value-box/display value) + (send editor insert-wide-box + (lambda (editor) + (send editor insert/styles '(value) (format "~a" value))))) + + (define/private (render-messages messages) + (when (pair? messages) + (put '() "Message:\n") + (for-each + (lambda (message) + (send editor insert-wide-box + (lambda (editor) + (send editor insert/styles '(exn-message) message)))) + messages) + (blank))) + + (define/private (render-expected+actual expected actual) + (put '() "Actual:\n") + (render-value-box actual) + (put '() "Expected:\n") + (render-value-box expected) + (blank)) + + (define/private (render-parameters parameters) + (when (and parameters (pair? parameters)) + (put '() "Parameters:\n") + (for-each (lambda (parameter) (render-value-box parameter)) + parameters) + (blank))) + + (define/private (render-other-properties properties) + (when (pair? properties) + (put '() "Additional information:\n") + (for-each (lambda (p) (render-other-property (car p) (cdr p))) + properties) + (blank))) + + (define/private (render-other-property key value) + (put '() (format "key ~s:" key)) + (when (exn? value) + (inline-backtrace-link "" value)) + (put '() "\n") + (render-value-box value)) + + (define/private (render-embedded-exception exn) + (when (exn? exn) + (put '() "Received exception") + (inline-backtrace-link "" exn) + (put '() ":\n") + (render-value-box exn) + (blank))) + + (define/private (render-source-location label location-reps) + (when (pair? location-reps) + (let* ([location-reps (reverse location-reps)] + [rep0 (car location-reps)] + [reps (cdr location-reps)]) + (put '() label ": ") + (inline-source-location/1 rep0) + (blank) + (when (pair? reps) + (put '() "Inner locations: ") + (for-each (lambda (r) (inline-source-location/1 r)) reps) + (blank)) + (blank))) + (unless (pair? location-reps) + (put '() label " is not available.") + (blank) + (blank))) + + (define/private (inline-source-location/1 location) + (match location + [(list src line col pos span) + (let* ([file-name (resolve-source-file src)] + [short-file-name + (if (or (path? file-name) (string? file-name)) + (path->string (file-name-from-path file-name)) + file-name)] + [source-location (format "~a:~a:~a" short-file-name line col)]) + (inline-source-location/h source-location src pos span))] + [_ (put '() "not usable")])) + + (define/private (inline-source-location/h source-location src pos span) + (if (and src (drlink:can-show-source?)) + (put+click '(clickback) + (lambda _ (drlink:show-source src pos span)) + source-location) + (put '() source-location))) + + (define/private (render-backtrace-link text exn) + (when (exn? exn) + (if (drlink:has-backtrace? exn) + (inline-backtrace-link text exn) + (begin (put '() text) + (put '() " not available"))) + (blank) + (blank))) + + (define/private (inline-backtrace-link text exn) + (when (drlink:has-backtrace? exn) + (put '() text)) + (when (drlink:has-errortrace-backtrace? exn) + (put '() " ") + (put+click '(clickback) + (lambda _ (drlink:show-errortrace-backtrace exn)) + "[from DrScheme]")) + (when (drlink:has-primitive-backtrace? exn) + (put '() " ") + (put+click '(clickback) + (lambda _ (drlink:show-primitive-backtrace exn)) + "[from mzscheme]"))) + + (define/private (render-output model) + (let [(output (send/i model case<%> get-output))] + (when (pair? output) + (put '() "Output:\n") + (send editor insert-wide-box + (lambda (editor) + (for ([mode+text output]) + (let ([styles + (if (eq? (car mode+text) 'error) + '(red italic) + '(darkblue))] + [buf (apply bytes-append + (reverse (cdr mode+text)))]) + (send editor insert/styles styles + (bytes->string/utf-8 buf #\?)))))) + (blank)))) + + (define/private (render-timing model) + (let [(timing (send/i model case<%> get-timing))] + (when timing + (let ([cpu (car timing)] + [real (cadr timing)] + [gc (caddr timing)]) + (put '() "Timing:\n") + (put '() (format "cpu: ~a; real: ~a; gc: ~a\n\n" + cpu real gc)))))) + + (define/private (render-trash model) + (let ([trash (send/i model case<%> get-trash)]) + (when (pair? trash) + (put '() "Test did not clean up resources:\n") + (for-each (lambda (t) (render-value-box/display t)) trash) + (blank)))) + + (define/private (resolve-source-file src) + (or (and (is-a? src editor<%>) + (let* [(tmp?-box (box #t)) + (filename (send src get-filename tmp?-box))] + (if (and filename (not (unbox tmp?-box))) + filename + #f))) + (cond [(path? src) (path->string src)] + [(string? src) src] + [else 'unknown]))) + )) diff --git a/collects/schemeunit/private/gui/output-icon.png b/collects/schemeunit/private/gui/output-icon.png new file mode 100644 index 0000000000000000000000000000000000000000..9d26abeb8ddd56d55a65bb1f2fb2303d4e9dc34c GIT binary patch literal 513 zcmV+c0{;DpP)Px#32;bRa{vGf6951U69E94oEQKA00(qQO+^RT1p);L0%=!kmjD0&8FWQhbVF}# zZDnqB07G(RVRU6=Aa`kWXdp*PO;A^X4i^9b0d7e|K~yNuU6Rjh6Hyd}zw_o-rkNp9 zQi=<;Q9J}clB}3;ar&+ zE5$%uk`)*@N3)=9C~73ul-^u3n|#5(@pi+wg~`jP;X)nU$FB4Kht7QI)HJTytn2P{(8N`%A_C}X!@I3 zU-6LgK=rOQU(HQ$BeemuO+ZE*Yy6zdQ{N*EWEuXx^Es|hQL*&@0gleL_0MpZ%o}ti z|CaPr+NT;IM`&(4#HCG7!00?8NfF8`g*TLYaxZOuVbgB_S@G9FkfTK94zoktn08xt z2BbOdr4^sm9s#&yZHL>*37)Vd&B= void +(define (insert-text e text style) + (let ([a (send e last-position)]) + (send e insert text) + (let ([b (send e last-position)]) + (send e change-style style a b)))) + +(define text<%> (class->interface text%)) + +(define ext:text-mixin + (mixin (text<%>) () + (init-field (style-map schemeunit-style-map)) + (inherit last-position + change-style + set-clickback + insert + get-canvas + set-styles-sticky + set-autowrap-bitmap) + + (super-new (auto-wrap #t)) + (set-styles-sticky #f) + (set-autowrap-bitmap #f) + + ;; insert/styles : (list-of style-delta%) string ... -> void + ;; A list of styles to be applied. The first style is the last applied. + (define/public (insert/styles styles . texts) + (unless (andmap (lambda (x) (or (string? x) (is-a? x snip%))) texts) + (raise-type-error 'insert/styles "list of strings" texts)) + (let-values ([(a b) (put texts)]) + (for-each (lambda (style) (change-style (resolve style) a b)) + (reverse styles)))) + + ;; insert/styles+click : (list-of style-delta%) (?? -> void) string ...-> void + (define/public (insert/styles+click styles clickback . texts) + (unless (andmap (lambda (x) (or (string? x) (is-a? x snip%))) texts) + (raise-type-error 'insert/styles+click "list of strings" texts)) + (let-values ([(a b) (put texts)]) + (for-each (lambda (style) (change-style (resolve style) a b)) + (reverse styles)) + (set-clickback a b clickback))) + + ;; put : (list-of string) -> int int + (define/private (put texts) + (let ([a (last-position)]) + (let loop ([texts texts] [where a]) + (if (pair? texts) + (begin (insert (car texts) where 'same #f) + (loop (cdr texts) (last-position))) + (values a where))))) + + (define/private (resolve style) + (if (symbol? style) + (send style-map get-style style) + style)) + + ;; newline : -> void + (define/public (newline) + (insert/styles '() "\n")) + + ;; insert-wide-box : (ext:text<%> -> void) -> void + (define/public (insert-wide-box p) + (internal-insert-box p #t) + (newline)) + + ;; internal-insert-box : (ext:text<%> -> void) boolean? -> void + (define/private (internal-insert-box p wide?) + (let* ([seditor (new ext:text%)] + [snip (new editor-snip% (editor seditor))]) + (p seditor) + (let [(canvas (get-canvas))] + (when (and (is-a? canvas canvas:wide-snip<%>) wide?) + (send canvas add-wide-snip snip))) + (insert snip) + (send seditor lock #t))) + + )) + +(define ext:text% + (text:wide-snip-mixin + (ext:text-mixin + text:hide-caret/selection%))) + +(define style:no-change (make-object style-delta% 'change-nothing)) +(define style:normal (make-object style-delta% 'change-normal)) +(define style:large (make-object style-delta% 'change-nothing)) +(void (send style:large set-size-mult 1.5)) + +(define style:blue (make-object style-delta% 'change-nothing)) +(void (send style:blue set-delta-foreground "Blue")) + +(define style:red (make-object style-delta% 'change-nothing)) +(void (send style:red set-delta-foreground "Red")) + +(define style:green (make-object style-delta% 'change-nothing)) +(void (send style:green set-delta-foreground "ForestGreen")) + +(define style:purple (make-object style-delta% 'change-nothing)) +(void (send style:purple set-delta-foreground "Purple")) + +(define style:gray (make-object style-delta% 'change-nothing)) +(void (send style:gray set-delta-foreground "DimGray")) + +(define style:darkblue (make-object style-delta% 'change-nothing)) +(void (send style:darkblue set-delta-foreground "DarkBlue")) + +(define style:clickback (make-object style-delta% 'change-underline #t)) +(void (send style:clickback set-delta-foreground "blue")) + +(define style:bold (make-object style-delta% 'change-nothing)) +(void (send style:bold set-delta 'change-weight 'bold)) + +(define style:italic (make-object style-delta% 'change-nothing)) +(void (send style:italic set-delta 'change-style 'italic)) + +(define basic-styles + `([no-change . ,style:no-change] + [normal . ,style:normal] + [large . ,style:large] + [clickback . ,style:clickback] + [red . ,style:red] + [blue . ,style:blue] + [green . ,style:green] + [purple . ,style:purple] + [darkblue . ,style:darkblue] + [bold . ,style:bold] + [italic . ,style:italic] + [error . ,style:red] + [value . ,style:darkblue])) + +(define schemeunit-styles + `([test-unexecuted . ,style:gray] + [test-success . ,style:green] + [test-failure . ,style:red] + [test-error . ,style:red] + + [exn-type . ,style:darkblue] + [exn-message . ,style:red] + [exn-value . ,style:darkblue] + [fail-type . ,style:darkblue])) + + +;; -- style-map classes + +(define extended-style-map% + (class* object% (style-map<%>) + (init-field styles + base) + (define/public (get-style sym) + (cond [(assq sym styles) => cdr] + [else (send base get-style sym)])) + (super-new))) + +(define empty-style-map% + (class* object% (style-map<%>) + (define/public (get-style sym) + (error 'get-style "unknown style: ~s" sym)) + (super-new))) + +;; extend-style-map : style-map<%> styles -> style-map<%> +(define (extend-style-map base styles) + (new extended-style-map% (base base) (styles styles))) + +;; empty-style-map : style-map<%> +(define empty-style-map + (new empty-style-map%)) + +;; basic-style-map : style-map<%> +(define basic-style-map + (extend-style-map empty-style-map + basic-styles)) + +;; schemeunit-style-map : style-map<%> +(define schemeunit-style-map + (extend-style-map basic-style-map + schemeunit-styles)) diff --git a/collects/schemeunit/private/gui/view.ss b/collects/schemeunit/private/gui/view.ss new file mode 100644 index 0000000000..fdb7175f7b --- /dev/null +++ b/collects/schemeunit/private/gui/view.ss @@ -0,0 +1,306 @@ +#lang scheme/base +(require scheme/class + unstable/class-iop + scheme/list + scheme/gui + framework + mrlib/hierlist + "interfaces.ss" + "config.ss" + "model2rml.ss" + "rml.ss") + +(provide make-view-frame + view%) + +(define style-map schemeunit-style-map) + +#| + +To avoid getting sequence contract violations from editors, all editor +mutations should be done in the eventspace thread. + +Can an update to a result<%> occur before its view link has been +created? Answer = yes, quite easily it seems (I tried it.) + +See 'do-model-update': we yield if the view-link hasn't been created +yet, since there should be a callback queued waiting to create it. + +With the 'queue-callback' calls and the one 'yield' call in place, I'm +no longer able to trigger the race condition. + +---- + +FIXME: + +Another problem: If tests are still running and a gui element "goes +away", then get errors. Eg, run (test/gui success-and-failure-tests) +and then immediately close the window. + +Why are these things actually disappearing, though? Shouldn't they +still be there, just not visible? + +|# + + +;; View +(define view% + (class* object% (view<%>) + (init-field parent + controller) + (super-new) + + (define editor (new ext:text% (style-map schemeunit-style-map))) + (define renderer + (new model-renderer% + (controller controller) + (editor editor))) + + (define eventspace + (send (send parent get-top-level-window) get-eventspace)) + + (define -hpane (new panel:horizontal-dragable% (parent parent))) + (define -lpane (new vertical-pane% (parent -hpane))) + (define -rpane (new vertical-pane% (parent -hpane))) + (define -details-canvas + (new canvas:wide-snip% (parent -rpane) (editor editor))) + + (define tree-view + (new model-tree-view% + (parent -lpane) ;; tree-panel + (view this) + (controller controller))) + + (send editor lock #t) + (with-handlers ([exn:fail? void]) + (send -hpane set-percentages VIEW-PANE-PERCENTS)) + + ;; View Links + + (define/public (create-view-link model parent) + (parameterize ((current-eventspace eventspace)) + (queue-callback + (lambda () + (send tree-view create-view-link model parent))))) + + (define/private (get-view-link model) + (send tree-view get-view-link model)) + + ;; Methods + + (define/private (get-selected-model) + (send/i controller controller<%> get-selected-model)) + + (send/i controller controller<%> listen-selected-model + (lambda (model) + (parameterize ((current-eventspace eventspace)) + (queue-callback + (lambda () + (let ([view-link (get-view-link model)]) + (send view-link select #t)) + (show-model model)))))) + + ;; Update Management + + (define update-queue (make-hasheq)) + (define update-lock (make-semaphore 1)) + + ;; queue-for-update : model -> void + (define/public (queue-for-update model) + (semaphore-wait update-lock) + (hash-set! update-queue model #t) + (semaphore-post update-lock) + (process-updates)) + + ;; process-updates : -> void + (define/private (process-updates) + (parameterize ((current-eventspace eventspace)) + (queue-callback + (lambda () + (let ([models-to-update (grab+clear-update-queue)]) + (for ([model models-to-update]) + (do-model-update model))))))) + + ;; grab+clear-update-queue : -> void + ;; ** Must be called from eventspace thread. + (define/private (grab+clear-update-queue) + (semaphore-wait update-lock) + (if (positive? (hash-count update-queue)) + (let ([old-queue update-queue]) + (set! update-queue (make-hasheq)) + (semaphore-post update-lock) + (reverse + (hash-map old-queue (lambda (k v) k)))) + (begin (semaphore-post update-lock) + null))) + + ;; do-model-update : model<%> -> void + ;; ** Must be called from eventspace thread. + (define/private (do-model-update model) + (let ([view-link (get-view-link model)]) + (cond [view-link + (send tree-view update-item view-link) + (when (eq? model (get-selected-model)) + (show-model model))] + [(not view-link) + ;; If the view-link has not been created, + ;; yield until it is. + (unless (yield) + (error 'schemeunit-gui + "internal error: no progress waiting for view-link")) + (do-model-update model)]))) + + ;; Update display + + ;; show-model : result<%> -> void + ;; Displays the result in the Details area. + ;; ** Must be called from eventspace thread. + (define/private (show-model model) + (send* editor + (begin-edit-sequence) + (lock #f) + (erase)) + (send renderer render-model/long model) + (send* editor + (lock #t) + (end-edit-sequence) + (scroll-to-position 0))) + + )) + + +;; tree-view% <: hierarchical-list% +(define model-tree-view% + (class* hierarchical-list% () + (init-field view + controller) + (super-new (style '(auto-hscroll))) + + (inherit get-items) + + ;; View Link + + (define model=>view-link (make-hasheq)) + + (define/public (set-view-link model item) + (hash-set! model=>view-link model item)) + (define/public (get-view-link model) + (hash-ref model=>view-link model #f)) + + ;; Behavior + + (define/override (on-select item) + (let [(model (send item user-data))] + (send/i controller controller<%> set-selected-model model))) + + (define/override (on-double-select item) + (when (is-a? item hierarchical-list-compound-item<%>) + (if (send item is-open?) + (send item close) + (send item open)))) + + (define/private (ensure-tree-visible model) + (let* [(parent (send model get-parent)) + (parent-view-link (and parent (get-view-link parent)))] + (when (and parent (not (send parent-view-link is-open?))) + (ensure-tree-visible parent) + (send parent-view-link open)))) + + ;; Construction + + ;; create-view-link : result<%> suite-result<%>/#f-> item + (define/public (create-view-link model parent) + (let ([parent-link + (if parent + (get-view-link parent) + this)]) + (initialize-view-link (cond [(is-a? model suite<%>) + (send parent-link new-list)] + [(is-a? model case<%>) + (send parent-link new-item)]) + model))) + + ;; initialize-view-link : result<%> (U compound-item% item%) -> item + (define/private (initialize-view-link item model) + (set-view-link model item) + (send item user-data model) + (insert-text (send item get-editor) + (send model get-name) + (send style-map get-style + (if (is-a? model suite<%>) + 'bold + 'normal)))) + + ;; update-item : item% -> void + (define/public (update-item view-link) + (let* ([editor (send view-link get-editor)] + [model (send view-link user-data)] + [name (send/i model result<%> get-name)] + [style-name + (cond [(not (send/i model result<%> finished?)) 'test-unexecuted] + [(send/i model result<%> success?) 'test-success] + [(send/i model result<%> failure?) 'test-failure] + [(send/i model result<%> error?) 'test-error])] + [style (send/i style-map style-map<%> get-style style-name)] + [output? (send/i model result<%> has-output?)] + [trash? (send/i model result<%> has-trash?)]) + (send editor begin-edit-sequence #f) + (send editor delete (string-length name) (send editor last-position) #f) + (when (or output? trash?) + (send editor insert + (output-icon) + (string-length name) + 'same + #f)) + (send editor change-style style 0 (send editor last-position) #f) + (send editor end-edit-sequence))))) + + +;; view-frame% <: frame% +(define view-frame% + (class (frame:standard-menus-mixin + (frame:basic-mixin frame%)) + + (init [width (pref:width)] + [height (pref:height)]) + (super-new (width width) (height height)) + + (inherit get-help-menu + get-width + get-height) + + (define-syntax override-false + (syntax-rules () + [(override-false name ...) + (begin (define/override (name . _) #f) ...)])) + + (override-false file-menu:create-new? + file-menu:create-open? + file-menu:create-open-recent? + file-menu:create-revert? + file-menu:create-save? + file-menu:create-save-as? + file-menu:create-print? + edit-menu:create-undo? + edit-menu:create-redo? + edit-menu:create-cut? + edit-menu:create-paste? + edit-menu:create-clear? + edit-menu:create-find? + #;edit-menu:create-replace-and-find-again? + edit-menu:create-preferences?) + + (define/augment (on-close) + (pref:width (get-width)) + (pref:height (get-height)) + (inner (void) on-close)) + + (send (get-help-menu) delete))) + +;; make-view-frame : -> frame% +(define (make-view-frame) + (let ([frame + (new view-frame% + (label FRAME-LABEL))]) + (send frame show #t) + frame)) diff --git a/collects/schemeunit/hash-monad.ss b/collects/schemeunit/private/hash-monad.ss similarity index 100% rename from collects/schemeunit/hash-monad.ss rename to collects/schemeunit/private/hash-monad.ss diff --git a/collects/schemeunit/location.ss b/collects/schemeunit/private/location.ss similarity index 100% rename from collects/schemeunit/location.ss rename to collects/schemeunit/private/location.ss diff --git a/collects/schemeunit/monad.ss b/collects/schemeunit/private/monad.ss similarity index 100% rename from collects/schemeunit/monad.ss rename to collects/schemeunit/private/monad.ss diff --git a/collects/schemeunit/name-collector.ss b/collects/schemeunit/private/name-collector.ss similarity index 98% rename from collects/schemeunit/name-collector.ss rename to collects/schemeunit/private/name-collector.ss index cf225b9f50..cc14dbdecf 100644 --- a/collects/schemeunit/name-collector.ss +++ b/collects/schemeunit/private/name-collector.ss @@ -31,7 +31,7 @@ (require "base.ss" "monad.ss" "hash-monad.ss" - (lib "list.ss" "srfi" "1")) + srfi/1) (provide display-test-case-name push-suite-name! diff --git a/collects/schemeunit/result.ss b/collects/schemeunit/private/result.ss similarity index 98% rename from collects/schemeunit/result.ss rename to collects/schemeunit/private/result.ss index c9ad329969..915b1f0d1d 100644 --- a/collects/schemeunit/result.ss +++ b/collects/schemeunit/private/result.ss @@ -28,9 +28,8 @@ #lang scheme/base -(require - (file "base.ss") - (file "test-suite.ss")) +(require "base.ss" + "test-suite.ss") (provide (all-defined-out)) diff --git a/collects/schemeunit/test-case.ss b/collects/schemeunit/private/test-case.ss similarity index 95% rename from collects/schemeunit/test-case.ss rename to collects/schemeunit/private/test-case.ss index bc265bc497..08921661b2 100644 --- a/collects/schemeunit/test-case.ss +++ b/collects/schemeunit/private/test-case.ss @@ -1,18 +1,17 @@ #lang scheme/base -(require (for-syntax scheme/base)) - -(require (file "base.ss") - (file "format.ss") - (file "check-info.ss") - (file "check.ss")) +(require (for-syntax scheme/base) + "base.ss" + "format.ss" + "check-info.ss" + "check.ss") (provide current-test-name current-test-case-around - + test-begin test-case - + before after around) diff --git a/collects/schemeunit/test-suite.ss b/collects/schemeunit/private/test-suite.ss similarity index 98% rename from collects/schemeunit/test-suite.ss rename to collects/schemeunit/private/test-suite.ss index 1d4eb1337c..155049cc2c 100644 --- a/collects/schemeunit/test-suite.ss +++ b/collects/schemeunit/private/test-suite.ss @@ -1,8 +1,7 @@ #lang scheme/base -(require (for-syntax scheme/base)) - -(require "base.ss" +(require (for-syntax scheme/base) + "base.ss" "test-case.ss" "check.ss") @@ -11,9 +10,9 @@ test-suite-check-around delay-test make-test-suite - + apply-test-suite - + define-test-suite define/provide-test-suite) @@ -66,7 +65,7 @@ [kid-seed (fdown suite name before after seed)] [kid-seed ((schemeunit-test-suite-tests suite) fdown fup fhere kid-seed)]) (fup suite name before after seed kid-seed))) - + ;; test-suite : name [#:before thunk] [#:after thunk] test ... ;; -> test-suite ;; @@ -167,7 +166,7 @@ (define name (test-suite (symbol->string (quote name)) test ...))])) - + (define-syntax define/provide-test-suite (syntax-rules () [(define/provide-test-suite name test ...) diff --git a/collects/schemeunit/test.ss b/collects/schemeunit/private/test.ss similarity index 96% rename from collects/schemeunit/test.ss rename to collects/schemeunit/private/test.ss index 9f82130467..47001dcd16 100644 --- a/collects/schemeunit/test.ss +++ b/collects/schemeunit/private/test.ss @@ -1,15 +1,14 @@ #lang scheme/base -(require (for-syntax scheme/base)) - -(require "base.ss" +(require (for-syntax scheme/base) + "base.ss" "check.ss" "check-info.ss" "result.ss" "test-case.ss" "test-suite.ss" "util.ss") - + (provide (struct-out exn:test:check) (struct-out check-info) (struct-out test-result) @@ -18,7 +17,7 @@ (struct-out test-success) (struct-out schemeunit-test-case) (struct-out schemeunit-test-suite) - + with-check-info with-check-info* @@ -50,13 +49,13 @@ define-test-suite define/provide-test-suite test-suite* - + before after around require/expose - + define-shortcut test-check @@ -70,18 +69,18 @@ test-not-false test-exn test-not-exn - + foldts fold-test-results run-test-case run-test - + fail-check define-check define-simple-check define-binary-check - + check check-exn check-not-exn diff --git a/collects/schemeunit/text-ui-util.ss b/collects/schemeunit/private/text-ui-util.ss similarity index 100% rename from collects/schemeunit/text-ui-util.ss rename to collects/schemeunit/private/text-ui-util.ss diff --git a/collects/schemeunit/util.ss b/collects/schemeunit/private/util.ss similarity index 96% rename from collects/schemeunit/util.ss rename to collects/schemeunit/private/util.ss index 94561a7c5d..e37ea67814 100644 --- a/collects/schemeunit/util.ss +++ b/collects/schemeunit/private/util.ss @@ -28,11 +28,9 @@ #lang scheme/base -(require (for-syntax scheme/base)) - -(require mzlib/etc) - -(require "check.ss" +(require (for-syntax scheme/base) + mzlib/etc + "check.ss" "test-suite.ss" "test-case.ss") diff --git a/collects/schemeunit/run-tests.ss b/collects/schemeunit/run-tests.ss deleted file mode 100644 index 1378f8b399..0000000000 --- a/collects/schemeunit/run-tests.ss +++ /dev/null @@ -1,10 +0,0 @@ -#lang scheme/base - -(require "all-schemeunit-tests.ss" - "main.ss" - "text-ui.ss") -; "graphical-ui.ss") - -;(run-tests all-schemeunit-tests) - -(run-tests success-and-failure-tests) diff --git a/collects/schemeunit/scribblings/base.ss b/collects/schemeunit/scribblings/base.ss index 04828b5efa..d78402873e 100644 --- a/collects/schemeunit/scribblings/base.ss +++ b/collects/schemeunit/scribblings/base.ss @@ -5,12 +5,16 @@ scribble/manual (for-label scheme/base + scheme/contract schemeunit - schemeunit/text-ui)) + schemeunit/text-ui + schemeunit/gui)) (provide (all-from-out scribble/eval scribble/manual) (for-label (all-from-out scheme/base + scheme/contract schemeunit - schemeunit/text-ui))) + schemeunit/text-ui + schemeunit/gui))) diff --git a/collects/schemeunit/scribblings/ui.scrbl b/collects/schemeunit/scribblings/ui.scrbl index 8cc329339b..b4d30e439c 100644 --- a/collects/schemeunit/scribblings/ui.scrbl +++ b/collects/schemeunit/scribblings/ui.scrbl @@ -9,10 +9,12 @@ SchemeUnit provides a textual and a graphical user interface @defmodule[schemeunit/text-ui] -The textual UI is in the @scheme[text-ui] module. It is run -via the @scheme[run-tests] function +The textual UI is in the @schememodname[schemeunit/text-ui] module. +It is run via the @scheme[run-tests] function. -@defproc[(run-tests (test (or/c test-case? test-suite?)) (verbosity (symbols 'quite 'normal 'verbose) 'normal)) natural-number/c]{ +@defproc[(run-tests (test (or/c test-case? test-suite?)) + (verbosity (symbols 'quite 'normal 'verbose) 'normal)) + natural-number/c]{ The given @scheme[test] is run and the result of running it output to the @scheme[current-output-port]. The output is @@ -29,7 +31,25 @@ information. @scheme[run-tests] returns the number of unsuccessful tests.} - @section{Graphical User Interface} -The GUI has not yet been updated to this version of SchemeUnit. +@defmodule[schemeunit/gui] + +SchemeUnit also provides a GUI test runner, available from the +@schememodname[schemeunit/gui] module. + +@defproc[(test/gui [test (or/c test-case? test-suite?)] ...) + any]{ + +Creates a new SchemeUnit GUI window and runs each @scheme[test]. The +GUI is updated as tests complete. + +} + +@defproc[(make-gui-runner) + (-> (or/c test-case? test-suite?) ... any)]{ + +Creates a new SchemeUnit GUI window and returns a procedure that, when +applied, runs the given tests and displays the results in the GUI. + +} diff --git a/collects/schemeunit/text-ui.ss b/collects/schemeunit/text-ui.ss index e71391f7e5..3a95491503 100644 --- a/collects/schemeunit/text-ui.ss +++ b/collects/schemeunit/text-ui.ss @@ -31,19 +31,18 @@ (require scheme/match scheme/pretty srfi/13 - srfi/26) - -(require "base.ss" - "counter.ss" - "format.ss" - "location.ss" - "result.ss" - "test.ss" - "check-info.ss" - "monad.ss" - "hash-monad.ss" - "name-collector.ss" - "text-ui-util.ss") + srfi/26 + "main.ss" + "private/base.ss" + "private/counter.ss" + "private/format.ss" + "private/location.ss" + "private/result.ss" + "private/check-info.ss" + "private/monad.ss" + "private/hash-monad.ss" + "private/name-collector.ss" + "private/text-ui-util.ss") (provide run-tests display-context diff --git a/collects/schemeunit/tool.ss b/collects/schemeunit/tool.ss new file mode 100644 index 0000000000..5b1c2eaf31 --- /dev/null +++ b/collects/schemeunit/tool.ss @@ -0,0 +1,95 @@ +#lang scheme/base +(require scheme/class + scheme/gui + framework + drscheme/tool + scheme/unit + (prefix-in drlink: "private/gui/drscheme-link.ss")) + +(provide tool@) + +;; CONSTANTS + +(define BACKTRACE-NO-MESSAGE "No message.") +(define LINK-MODULE-SPEC 'schemeunit/private/gui/drscheme-link) + +(define-namespace-anchor drscheme-ns-anchor) + +;; ---- + +;; close/eventspace : (a* -> b) -> (a* -> b) +;; Returns a procedure that executes the procedure in the +;; eventspace current when close/eventspace was executed. +;; Effectively, "close" the procedure in the current eventspace. +(define (close-eventspace f) + (let ([es (current-eventspace)]) + (lambda args + (parameterize [(current-eventspace es)] + (apply f args))))) + +(define (close-eventspace/async f) + (let ([es (current-eventspace)]) + (lambda args + (parameterize ((current-eventspace es)) + (queue-callback (lambda () (apply f args))))))) + +(define tool@ + (unit + (import drscheme:tool^) + (export drscheme:tool-exports^) + + ;; show-backtrace : exn -> void + (define show-backtrace + (close-eventspace/async + (lambda (msg bt) + (drscheme:debug:show-backtrace-window + (or msg BACKTRACE-NO-MESSAGE) + bt)))) + + (define (list->srcloc x) + (make-srcloc (list-ref x 0) + (list-ref x 1) + (list-ref x 2) + (list-ref x 3) + (list-ref x 4))) + + (define (get-errortrace-backtrace exn) + exn) + + ;; show-source : value number number -> void + (define show-source + (close-eventspace/async + (lambda (src pos span) + (drscheme:debug:open-and-highlight-in-file + (list (make-srcloc src #f #f pos span)))))) + + ;; Send them off to the drscheme-ui module. + ;; We'll still have to attach our instantiation of drscheme-link + ;; to the user namespace. + (set-box! drlink:link + (vector get-errortrace-backtrace + show-backtrace + show-source)) + + (define drscheme-ns (namespace-anchor->namespace drscheme-ns-anchor)) + + (define interactions-text-mixin + (mixin ((class->interface drscheme:rep:text%)) () + (inherit get-user-namespace) + (super-new) + + (define/private (setup-helper-module) + (namespace-attach-module drscheme-ns + LINK-MODULE-SPEC + (get-user-namespace))) + + (define/override (reset-console) + (super reset-console) + (setup-helper-module)))) + + (drscheme:get/extend:extend-interactions-text interactions-text-mixin) + + (define (phase1) (void)) + (define (phase2) (void)) + + )) diff --git a/collects/tests/info.ss b/collects/tests/info.ss index ff6700f7a2..1493f0a44b 100644 --- a/collects/tests/info.ss +++ b/collects/tests/info.ss @@ -21,6 +21,7 @@ "plot" "profj" "r6rs" + "schemeunit" "srfi" "srpersist" "stepper" diff --git a/collects/schemeunit/all-schemeunit-tests.ss b/collects/tests/schemeunit/all-schemeunit-tests.ss similarity index 95% rename from collects/schemeunit/all-schemeunit-tests.ss rename to collects/tests/schemeunit/all-schemeunit-tests.ss index 83291e9a05..a25deb45e6 100644 --- a/collects/schemeunit/all-schemeunit-tests.ss +++ b/collects/tests/schemeunit/all-schemeunit-tests.ss @@ -1,6 +1,6 @@ #lang scheme/base -(require "main.ss" +(require schemeunit "check-test.ss" "check-info-test.ss" "format-test.ss" @@ -15,8 +15,7 @@ "monad-test.ss" "hash-monad-test.ss" "counter-test.ss" - "text-ui-util-test.ss" - ) + "text-ui-util-test.ss") (provide all-schemeunit-tests success-and-failure-tests) diff --git a/collects/schemeunit/base-test.ss b/collects/tests/schemeunit/base-test.ss similarity index 97% rename from collects/schemeunit/base-test.ss rename to collects/tests/schemeunit/base-test.ss index 5219fd438e..8f3e9ffbd7 100644 --- a/collects/schemeunit/base-test.ss +++ b/collects/tests/schemeunit/base-test.ss @@ -28,8 +28,8 @@ #lang scheme/base -(require "test.ss") -(require "base.ss") +(require schemeunit + schemeunit/private/base) (provide base-tests) diff --git a/collects/schemeunit/check-info-test.ss b/collects/tests/schemeunit/check-info-test.ss similarity index 98% rename from collects/schemeunit/check-info-test.ss rename to collects/tests/schemeunit/check-info-test.ss index 2d00365c2d..9d2b9f8917 100644 --- a/collects/schemeunit/check-info-test.ss +++ b/collects/tests/schemeunit/check-info-test.ss @@ -27,8 +27,8 @@ #lang scheme/base -(require "test.ss" - "check-info.ss") +(require schemeunit + schemeunit/private/check-info) (provide check-info-tests) diff --git a/collects/schemeunit/check-test.ss b/collects/tests/schemeunit/check-test.ss similarity index 97% rename from collects/schemeunit/check-test.ss rename to collects/tests/schemeunit/check-test.ss index 576252500e..0e3b8a0331 100644 --- a/collects/schemeunit/check-test.ss +++ b/collects/tests/schemeunit/check-test.ss @@ -28,13 +28,12 @@ #lang scheme/base -(require - scheme/runtime-path - (lib "list.ss" "srfi" "1") - (file "check.ss") - (file "result.ss") - (file "test.ss") - (file "test-suite.ss")) +(require scheme/runtime-path + srfi/1 + schemeunit + schemeunit/private/check + schemeunit/private/result + schemeunit/private/test-suite) (provide check-tests) @@ -51,8 +50,6 @@ (define-check (bad) (fail-check)) -(define-runtime-path check-file "check.ss") - (define check-tests (test-suite "Check tests" @@ -291,7 +288,7 @@ (cns (current-namespace))) (parameterize ((current-namespace destns)) (namespace-require '(for-syntax scheme/base)) - (namespace-require `(file ,(path->string check-file))) + (namespace-require 'schemeunit/private/check) ;; First check that the right check macro got ;; used: ie that it didn't just compile the thing ;; as an application. @@ -306,7 +303,7 @@ ;; is writable (let ((stx-string "(check = 1 2)")) (write (compile (read-syntax - check-file + "check-test" (open-input-string stx-string))) (open-output-string)))))) diff --git a/collects/schemeunit/counter-test.ss b/collects/tests/schemeunit/counter-test.ss similarity index 91% rename from collects/schemeunit/counter-test.ss rename to collects/tests/schemeunit/counter-test.ss index d6cc563879..6ab8fbeeaa 100644 --- a/collects/schemeunit/counter-test.ss +++ b/collects/tests/schemeunit/counter-test.ss @@ -27,11 +27,11 @@ ;; Commentary: #lang scheme/base -(require (lib "plt-match.ss") - "test.ss") -(require "counter.ss" - "monad.ss" - "hash-monad.ss") +(require scheme/match + schemeunit + schemeunit/private/counter + schemeunit/private/monad + schemeunit/private/hash-monad) (provide counter-tests) diff --git a/collects/schemeunit/format-test.ss b/collects/tests/schemeunit/format-test.ss similarity index 86% rename from collects/schemeunit/format-test.ss rename to collects/tests/schemeunit/format-test.ss index ec8164dc06..47b9da6dd7 100644 --- a/collects/schemeunit/format-test.ss +++ b/collects/tests/schemeunit/format-test.ss @@ -1,8 +1,8 @@ #lang scheme/base -(require (file "test.ss") - (file "check-info.ss") - (file "format.ss")) +(require schemeunit + schemeunit/private/check-info + schemeunit/private/format) (provide format-tests) diff --git a/collects/schemeunit/hash-monad-test.ss b/collects/tests/schemeunit/hash-monad-test.ss similarity index 95% rename from collects/schemeunit/hash-monad-test.ss rename to collects/tests/schemeunit/hash-monad-test.ss index 40a0e36893..fd42b81853 100644 --- a/collects/schemeunit/hash-monad-test.ss +++ b/collects/tests/schemeunit/hash-monad-test.ss @@ -28,9 +28,9 @@ #lang scheme/base -(require "test.ss") -(require "monad.ss" - "hash-monad.ss") +(require schemeunit + schemeunit/private/monad + schemeunit/private/hash-monad) (provide hash-monad-tests) diff --git a/collects/schemeunit/location-test.ss b/collects/tests/schemeunit/location-test.ss similarity index 97% rename from collects/schemeunit/location-test.ss rename to collects/tests/schemeunit/location-test.ss index 7e156f74b5..52a1881f58 100644 --- a/collects/schemeunit/location-test.ss +++ b/collects/tests/schemeunit/location-test.ss @@ -27,8 +27,8 @@ ;; Commentary: #lang scheme/base -(require "test.ss" - "location.ss") +(require schemeunit + schemeunit/private/location) (provide location-tests) diff --git a/collects/schemeunit/monad-test.ss b/collects/tests/schemeunit/monad-test.ss similarity index 98% rename from collects/schemeunit/monad-test.ss rename to collects/tests/schemeunit/monad-test.ss index fbc90c602c..92c089fc8f 100644 --- a/collects/schemeunit/monad-test.ss +++ b/collects/tests/schemeunit/monad-test.ss @@ -29,8 +29,8 @@ #lang scheme/base -(require "test.ss") -(require "monad.ss") +(require schemeunit + schemeunit/private/monad) (provide monad-tests) diff --git a/collects/schemeunit/result-test.ss b/collects/tests/schemeunit/result-test.ss similarity index 94% rename from collects/schemeunit/result-test.ss rename to collects/tests/schemeunit/result-test.ss index b94924c291..fd0ae973ca 100644 --- a/collects/schemeunit/result-test.ss +++ b/collects/tests/schemeunit/result-test.ss @@ -1,8 +1,7 @@ #lang scheme/base - -(require - (file "test.ss") - (file "result.ss")) + +(require schemeunit + schemeunit/private/result) (provide result-tests) diff --git a/collects/tests/schemeunit/run-tests.ss b/collects/tests/schemeunit/run-tests.ss new file mode 100644 index 0000000000..8b5125ce5a --- /dev/null +++ b/collects/tests/schemeunit/run-tests.ss @@ -0,0 +1,9 @@ +#lang scheme/base + +(require schemeunit + schemeunit/text-ui + "all-schemeunit-tests.ss") + +;(run-tests all-schemeunit-tests) + +(run-tests success-and-failure-tests) diff --git a/collects/schemeunit/standalone-check-test.ss b/collects/tests/schemeunit/standalone-check-test.ss similarity index 97% rename from collects/schemeunit/standalone-check-test.ss rename to collects/tests/schemeunit/standalone-check-test.ss index d27c766b68..91d1daa716 100644 --- a/collects/schemeunit/standalone-check-test.ss +++ b/collects/tests/schemeunit/standalone-check-test.ss @@ -31,7 +31,7 @@ #lang scheme/base -(require "check.ss") +(require schemeunit/private/check) ;; This check should succeed (check = 1 1 0.0) diff --git a/collects/schemeunit/standalone-test-case-test.ss b/collects/tests/schemeunit/standalone-test-case-test.ss similarity index 87% rename from collects/schemeunit/standalone-test-case-test.ss rename to collects/tests/schemeunit/standalone-test-case-test.ss index f12ce9ab0f..742bb033dc 100644 --- a/collects/schemeunit/standalone-test-case-test.ss +++ b/collects/tests/schemeunit/standalone-test-case-test.ss @@ -4,8 +4,8 @@ #lang scheme/base -(require "check.ss" - "test-case.ss") +(require schemeunit/private/check + schemeunit/private/test-case) ;; These tests should succeeds (test-begin (check-eq? 1 1)) diff --git a/collects/schemeunit/test-case-test.ss b/collects/tests/schemeunit/test-case-test.ss similarity index 85% rename from collects/schemeunit/test-case-test.ss rename to collects/tests/schemeunit/test-case-test.ss index 1b9d03560b..0f3ceac97d 100644 --- a/collects/schemeunit/test-case-test.ss +++ b/collects/tests/schemeunit/test-case-test.ss @@ -1,10 +1,10 @@ #lang scheme/base -(require "base.ss" - "check.ss" - "test-case.ss" - "test-suite.ss" - "result.ss") +(require schemeunit/private/base + schemeunit/private/check + schemeunit/private/test-case + schemeunit/private/test-suite + schemeunit/private/result) (provide test-case-tests) diff --git a/collects/schemeunit/test-suite-test.ss b/collects/tests/schemeunit/test-suite-test.ss similarity index 93% rename from collects/schemeunit/test-suite-test.ss rename to collects/tests/schemeunit/test-suite-test.ss index 1ac3e0abe0..f8e4a1909b 100644 --- a/collects/schemeunit/test-suite-test.ss +++ b/collects/tests/schemeunit/test-suite-test.ss @@ -1,7 +1,7 @@ #lang scheme/base -(require "check.ss" - "test.ss") +(require schemeunit + schemeunit/private/check) (define run? #f) @@ -26,6 +26,9 @@ (test-begin (check-true run?)) + ;; Reset state so tests can be run again. + (set! run? #f) + (test-case "define-test" (check-pred test-suite? define-test)) diff --git a/collects/schemeunit/test-test.ss b/collects/tests/schemeunit/test-test.ss similarity index 96% rename from collects/schemeunit/test-test.ss rename to collects/tests/schemeunit/test-test.ss index a0dd35e084..cd3f237f26 100644 --- a/collects/schemeunit/test-test.ss +++ b/collects/tests/schemeunit/test-test.ss @@ -1,15 +1,13 @@ #lang scheme/base -(require (for-syntax scheme/base)) - -(require scheme/runtime-path +(require (for-syntax scheme/base) + scheme/runtime-path srfi/1 - srfi/13) + srfi/13 + schemeunit + schemeunit/private/util + schemeunit/private/location) -(require (file "test.ss") - (file "util.ss") - (file "location.ss")) - (provide test-tests) (define successful-suite @@ -25,8 +23,6 @@ "Example 3" #t))) -(define-runtime-path test-file "test.ss") - (define-check (check-test-results test successes failures errors) (let ((results (run-test test))) (check = (length results) (+ successes failures errors)) @@ -47,13 +43,13 @@ (let ((destns (make-base-namespace)) (cns (current-namespace))) (parameterize ((current-namespace destns)) - (namespace-require `(file ,(path->string test-file))) + (namespace-require 'schemeunit) (check-exn (lambda (e) (check-pred exn:fail:syntax? e) (check string-contains (exn-message e) msg)) (lambda () (eval sexp)))))) - + (define test-tests (test-suite "Test tests" diff --git a/collects/schemeunit/text-ui-test.ss b/collects/tests/schemeunit/text-ui-test.ss similarity index 98% rename from collects/schemeunit/text-ui-test.ss rename to collects/tests/schemeunit/text-ui-test.ss index 7e37c65858..9116a295c9 100644 --- a/collects/schemeunit/text-ui-test.ss +++ b/collects/tests/schemeunit/text-ui-test.ss @@ -30,10 +30,9 @@ (require scheme/runtime-path srfi/1 - srfi/13) - -(require "test.ss" - "text-ui.ss") + srfi/13 + schemeunit + schemeunit/text-ui) (provide text-ui-tests) diff --git a/collects/schemeunit/text-ui-util-test.ss b/collects/tests/schemeunit/text-ui-util-test.ss similarity index 96% rename from collects/schemeunit/text-ui-util-test.ss rename to collects/tests/schemeunit/text-ui-util-test.ss index 1496bc2e90..bb4948db09 100644 --- a/collects/schemeunit/text-ui-util-test.ss +++ b/collects/tests/schemeunit/text-ui-util-test.ss @@ -27,8 +27,8 @@ ;; Commentary: #lang scheme/base -(require "test.ss") -(require "text-ui-util.ss") +(require schemeunit + schemeunit/private/text-ui-util) (provide text-ui-util-tests) diff --git a/collects/schemeunit/util-test.ss b/collects/tests/schemeunit/util-test.ss similarity index 96% rename from collects/schemeunit/util-test.ss rename to collects/tests/schemeunit/util-test.ss index 10b14df9f7..36b90a5d89 100644 --- a/collects/schemeunit/util-test.ss +++ b/collects/tests/schemeunit/util-test.ss @@ -1,8 +1,7 @@ #lang scheme/base -(require - (file "test.ss") - (file "util.ss")) +(require schemeunit + schemeunit/private/util) (provide util-tests) diff --git a/collects/tests/srfi/19/tests.ss b/collects/tests/srfi/19/tests.ss index 977f9ed70e..6727cca4a0 100644 --- a/collects/tests/srfi/19/tests.ss +++ b/collects/tests/srfi/19/tests.ss @@ -8,7 +8,7 @@ (require srfi/19/time) -(require schemeunit/test +(require schemeunit schemeunit/text-ui) (define-check (check-comparisons comparison times expected) diff --git a/collects/tests/xml/test-clark.ss b/collects/tests/xml/test-clark.ss index 9375215f3b..9751da0f5b 100644 --- a/collects/tests/xml/test-clark.ss +++ b/collects/tests/xml/test-clark.ss @@ -1,13 +1,12 @@ #lang scheme (require schemeunit - schemeunit/base - schemeunit/test-case - schemeunit/check - schemeunit/test-suite + schemeunit/private/check + schemeunit/private/test-case + schemeunit/private/test-suite schemeunit/text-ui xml scheme/runtime-path) -(require/expose schemeunit/test-suite +(require/expose schemeunit/private/test-suite (current-seed)) (define (validate-xml? xml) From 5ad04e3b2c1127cb6828c38cf873e200c96e7a53 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 21 Feb 2010 02:06:28 +0000 Subject: [PATCH 2/5] changed some defconstructor/make's into defconstructor's svn: r18244 --- collects/scribblings/gui/brush-list-class.scrbl | 2 +- collects/scribblings/gui/dc-path-class.scrbl | 2 +- collects/scribblings/gui/editor-admin-class.scrbl | 2 +- collects/scribblings/gui/editor-data-class.scrbl | 2 +- collects/scribblings/gui/editor-wordbreak-map-class.scrbl | 2 +- collects/scribblings/gui/font-list-class.scrbl | 2 +- collects/scribblings/gui/keymap-class.scrbl | 2 +- collects/scribblings/gui/pen-list-class.scrbl | 2 +- collects/scribblings/gui/snip-admin-class.scrbl | 2 +- collects/scribblings/gui/snip-class-class.scrbl | 2 +- collects/scribblings/gui/snip-class.scrbl | 2 +- collects/scribblings/gui/style-list-class.scrbl | 2 +- collects/scribblings/gui/tab-snip-class.scrbl | 2 +- 13 files changed, 13 insertions(+), 13 deletions(-) diff --git a/collects/scribblings/gui/brush-list-class.scrbl b/collects/scribblings/gui/brush-list-class.scrbl index 5a216aff1b..cc8b115803 100644 --- a/collects/scribblings/gui/brush-list-class.scrbl +++ b/collects/scribblings/gui/brush-list-class.scrbl @@ -11,7 +11,7 @@ A global brush list, @scheme[the-brush-list], is created automatically. -@defconstructor/make[()]{ +@defconstructor[()]{ Creates an empty brush list. diff --git a/collects/scribblings/gui/dc-path-class.scrbl b/collects/scribblings/gui/dc-path-class.scrbl index e37bf31158..653f99e1b3 100644 --- a/collects/scribblings/gui/dc-path-class.scrbl +++ b/collects/scribblings/gui/dc-path-class.scrbl @@ -33,7 +33,7 @@ A path is not connected to any particular @scheme[dc<%>] object, so operations. Instead, a @scheme[dc<%>]'s origin and scale apply at the time that the path is drawn or used to set a region. -@defconstructor/make[()]{ +@defconstructor[()]{ Creates a new path that contains no sub-paths (and no @tech{open sub-path}). diff --git a/collects/scribblings/gui/editor-admin-class.scrbl b/collects/scribblings/gui/editor-admin-class.scrbl index 2f6c74ef38..a21bda3a83 100644 --- a/collects/scribblings/gui/editor-admin-class.scrbl +++ b/collects/scribblings/gui/editor-admin-class.scrbl @@ -18,7 +18,7 @@ To create a new @scheme[editor-admin%] class, all methods described -@defconstructor/make[()]{ +@defconstructor[()]{ Creates a (useless) editor administrator. diff --git a/collects/scribblings/gui/editor-data-class.scrbl b/collects/scribblings/gui/editor-data-class.scrbl index a305b95e0f..0c9290b6cf 100644 --- a/collects/scribblings/gui/editor-data-class.scrbl +++ b/collects/scribblings/gui/editor-data-class.scrbl @@ -8,7 +8,7 @@ snip or region in an editor. See also @|editordatadiscuss|. -@defconstructor/make[()]{ +@defconstructor[()]{ The element returned by @method[editor-data% get-next] is initialized to @scheme[#f]. diff --git a/collects/scribblings/gui/editor-wordbreak-map-class.scrbl b/collects/scribblings/gui/editor-wordbreak-map-class.scrbl index 7451f555c1..d20d2c9e96 100644 --- a/collects/scribblings/gui/editor-wordbreak-map-class.scrbl +++ b/collects/scribblings/gui/editor-wordbreak-map-class.scrbl @@ -32,7 +32,7 @@ The presence of a flag in a character's value indicates that the -@defconstructor/make[()]{ +@defconstructor[()]{ All ASCII alpha-numeric characters are initialized with @scheme['(caret line selection)]. All other ASCII non-whitespace diff --git a/collects/scribblings/gui/font-list-class.scrbl b/collects/scribblings/gui/font-list-class.scrbl index 775b930d1b..5c4dffc084 100644 --- a/collects/scribblings/gui/font-list-class.scrbl +++ b/collects/scribblings/gui/font-list-class.scrbl @@ -9,7 +9,7 @@ A @scheme[font-list%] object maintains a list of @scheme[font%] A global font list, @scheme[the-font-list], is created automatically. -@defconstructor/make[()]{ +@defconstructor[()]{ Creates an empty font list. diff --git a/collects/scribblings/gui/keymap-class.scrbl b/collects/scribblings/gui/keymap-class.scrbl index 34a01e0320..090a968629 100644 --- a/collects/scribblings/gui/keymap-class.scrbl +++ b/collects/scribblings/gui/keymap-class.scrbl @@ -25,7 +25,7 @@ A handler procedure in a keymap is invoked with a @scheme[key-event%] @scheme[editor<%>] object that received the keyboard or mouse event. -@defconstructor/make[()]{ +@defconstructor[()]{ Creates an empty keymap. diff --git a/collects/scribblings/gui/pen-list-class.scrbl b/collects/scribblings/gui/pen-list-class.scrbl index 37ff6bb72a..86380b2397 100644 --- a/collects/scribblings/gui/pen-list-class.scrbl +++ b/collects/scribblings/gui/pen-list-class.scrbl @@ -13,7 +13,7 @@ A global pen list @indexed-scheme[the-pen-list] is created automatically. -@defconstructor/make[()]{ +@defconstructor[()]{ Creates an empty pen list. diff --git a/collects/scribblings/gui/snip-admin-class.scrbl b/collects/scribblings/gui/snip-admin-class.scrbl index 2ac83df103..1f3f152e7f 100644 --- a/collects/scribblings/gui/snip-admin-class.scrbl +++ b/collects/scribblings/gui/snip-admin-class.scrbl @@ -20,7 +20,7 @@ Because a @scheme[snip-admin%] object typically owns more than one -@defconstructor/make[()]{ +@defconstructor[()]{ Creates a (useless) editor administrator. diff --git a/collects/scribblings/gui/snip-class-class.scrbl b/collects/scribblings/gui/snip-class-class.scrbl index 9bf2ecc6eb..88880800c7 100644 --- a/collects/scribblings/gui/snip-class-class.scrbl +++ b/collects/scribblings/gui/snip-class-class.scrbl @@ -31,7 +31,7 @@ In deriving a new @scheme[snip-class%] class, override the See also @|snipclassdiscuss|. -@defconstructor/make[()]{ +@defconstructor[()]{ Creates a (useless) snip class. diff --git a/collects/scribblings/gui/snip-class.scrbl b/collects/scribblings/gui/snip-class.scrbl index 02cfdf6890..efe1e6f1eb 100644 --- a/collects/scribblings/gui/snip-class.scrbl +++ b/collects/scribblings/gui/snip-class.scrbl @@ -74,7 +74,7 @@ To define a class of snips that read specially with -@defconstructor/make[()]{ +@defconstructor[()]{ Creates a plain snip of length 1 with the @scheme["Basic"] style of @scheme[the-style-list]. diff --git a/collects/scribblings/gui/style-list-class.scrbl b/collects/scribblings/gui/style-list-class.scrbl index 3aa9361ace..f7beba30e7 100644 --- a/collects/scribblings/gui/style-list-class.scrbl +++ b/collects/scribblings/gui/style-list-class.scrbl @@ -15,7 +15,7 @@ See @|stylediscuss| for more information. -@defconstructor/make[()]{ +@defconstructor[()]{ The root style, named @scheme["Basic"], is automatically created. diff --git a/collects/scribblings/gui/tab-snip-class.scrbl b/collects/scribblings/gui/tab-snip-class.scrbl index ebcb46a1e6..ce2ca93946 100644 --- a/collects/scribblings/gui/tab-snip-class.scrbl +++ b/collects/scribblings/gui/tab-snip-class.scrbl @@ -7,7 +7,7 @@ An instance of @scheme[tab-snip%] is created automatically when a tab is inserted into an editor. -@defconstructor/make[()]{ +@defconstructor[()]{ Creates a snip for a single tab, though the tab is initially empty. From 95debe6353b6fc99d56a11c29415ad5ebb573001 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 21 Feb 2010 02:06:57 +0000 Subject: [PATCH 3/5] added keyboard shortcuts for the first 9 tabs to the windows menu (on the mac) svn: r18245 --- collects/drscheme/private/main.ss | 11 +++++++++++ collects/drscheme/private/unit.ss | 15 ++++++++++----- collects/scribblings/tools/unit.scrbl | 11 ++++++++++- .../string-constants/english-string-constants.ss | 1 + 4 files changed, 32 insertions(+), 6 deletions(-) diff --git a/collects/drscheme/private/main.ss b/collects/drscheme/private/main.ss index 1f46e3d613..b9b70de1ab 100644 --- a/collects/drscheme/private/main.ss +++ b/collects/drscheme/private/main.ss @@ -561,6 +561,17 @@ (let ([frame (find-frame item)]) (when frame (send frame next-tab))))]) + (let ([frame (find-frame windows-menu)]) + (unless (= 1 (send frame get-tab-count)) + (for ([i (in-range 0 (send frame get-tab-count))] + #:when (< i 9)) + (new menu-item% + [parent windows-menu] + [label (format "Tab ~a: ~a" (+ i 1) (send frame get-tab-filename i))] + [shortcut (integer->char (+ (char->integer #\1) i))] + [callback + (λ (a b) + (send frame change-to-nth-tab i))])))) (new separator-menu-item% [parent windows-menu])))) ;; Check for any files lost last time. diff --git a/collects/drscheme/private/unit.ss b/collects/drscheme/private/unit.ss index 15a8ba5033..3a65ae2abf 100644 --- a/collects/drscheme/private/unit.ss +++ b/collects/drscheme/private/unit.ss @@ -2080,6 +2080,9 @@ module browser threading seems wrong. (unless (equal? label (send tabs-panel get-item-label (send tab get-i))) (send tabs-panel set-item-label (send tab get-i) label)))) + (define/public (get-tab-filename i) + (get-defs-tab-filename (send (list-ref tabs i) get-defs))) + (define/private (get-defs-tab-label defs tab) (let ([fn (send defs get-filename)] [i-prefix (or (for/or ([i (in-list tabs)] @@ -2090,11 +2093,13 @@ module browser threading seems wrong. "")]) (string-append i-prefix - (add-modified-flag - defs - (if fn - (get-tab-label-from-filename fn) - (send defs get-filename/untitled-name)))))) + (get-defs-tab-filename defs)))) + + (define/private (get-defs-tab-filename defs) + (let ([fn (send defs get-filename)]) + (if fn + (get-tab-label-from-filename fn) + (send defs get-filename/untitled-name)))) (define/private (get-tab-label-from-filename fn) (let* ([take-n diff --git a/collects/scribblings/tools/unit.scrbl b/collects/scribblings/tools/unit.scrbl index 2f98278140..8cb65a76ba 100644 --- a/collects/scribblings/tools/unit.scrbl +++ b/collects/scribblings/tools/unit.scrbl @@ -574,7 +574,16 @@ Shows the interactions window Returns the currently active tab. } - + +@defmethod[(get-tab-filename [i (<=/c 0 (#,(method drscheme:unit:frame% get-tab-count)))]) string?]{ + Returns a string naming the file in the @scheme[i]th tab or, if + the file is not saved, something like ``Untitled''. +} + +@defmethod[(get-tab-count) exact-positive-integer?]{ + Returns the number of open tabs in the frame. +} + @defmethod[(open-in-new-tab [filename (or/c path-string? #f)]) void?]{ Opens a new tab in this frame. If @scheme[filename] is a @scheme[path-string?], It loads that file in the definitions window of the new tab. diff --git a/collects/string-constants/english-string-constants.ss b/collects/string-constants/english-string-constants.ss index 2fa1e1206a..827da39cd9 100644 --- a/collects/string-constants/english-string-constants.ss +++ b/collects/string-constants/english-string-constants.ss @@ -730,6 +730,7 @@ please adhere to these guidelines: (most-recent-window "Most Recent Window") (next-tab "Next Tab") (prev-tab "Previous Tab") + (tab-i "Tab ~a") ;; menu item in the windows menu under mac os x. ~a is filled with a number between 1 and 9. (view-menu-label "&View") (show-overview "Show &Program Contour") From ad352387c9083fe2ee5c94c63b7fdf25b96e88dc Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 21 Feb 2010 02:09:25 +0000 Subject: [PATCH 4/5] added string constants for the menus added in the previous commit svn: r18246 --- collects/drscheme/private/main.ss | 4 +++- collects/string-constants/english-string-constants.ss | 2 +- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/collects/drscheme/private/main.ss b/collects/drscheme/private/main.ss index b9b70de1ab..8b63a80ca6 100644 --- a/collects/drscheme/private/main.ss +++ b/collects/drscheme/private/main.ss @@ -567,7 +567,9 @@ #:when (< i 9)) (new menu-item% [parent windows-menu] - [label (format "Tab ~a: ~a" (+ i 1) (send frame get-tab-filename i))] + [label (format (string-constant tab-i) + (+ i 1) + (send frame get-tab-filename i))] [shortcut (integer->char (+ (char->integer #\1) i))] [callback (λ (a b) diff --git a/collects/string-constants/english-string-constants.ss b/collects/string-constants/english-string-constants.ss index 827da39cd9..dca99cda5a 100644 --- a/collects/string-constants/english-string-constants.ss +++ b/collects/string-constants/english-string-constants.ss @@ -730,7 +730,7 @@ please adhere to these guidelines: (most-recent-window "Most Recent Window") (next-tab "Next Tab") (prev-tab "Previous Tab") - (tab-i "Tab ~a") ;; menu item in the windows menu under mac os x. ~a is filled with a number between 1 and 9. + (tab-i "Tab ~a: ~a") ;; menu item in the windows menu under mac os x. first ~a is filled with a number between 1 and 9; second one is the filename of the tab (view-menu-label "&View") (show-overview "Show &Program Contour") From 71b4df4a29fd9b0bf498c389a8ab5d622d692397 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 21 Feb 2010 02:29:12 +0000 Subject: [PATCH 5/5] removed some more one-of/c's in favor of or/c svn: r18247 --- .../scribblings/gui/mouse-event-class.scrbl | 24 +++++++++---------- 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/collects/scribblings/gui/mouse-event-class.scrbl b/collects/scribblings/gui/mouse-event-class.scrbl index aeebd2ca8d..e050d77d9f 100644 --- a/collects/scribblings/gui/mouse-event-class.scrbl +++ b/collects/scribblings/gui/mouse-event-class.scrbl @@ -13,9 +13,9 @@ See also @|mousekeydiscuss|. -@defconstructor[([event-type (one-of/c 'enter 'leave 'left-down 'left-up - 'middle-down 'middle-up - 'right-down 'right-up 'motion)] +@defconstructor[([event-type (or/c 'enter 'leave 'left-down 'left-up + 'middle-down 'middle-up + 'right-down 'right-up 'motion)] [left-down any/c #f] [middle-down any/c #f] [right-down any/c #f] @@ -51,7 +51,7 @@ See the corresponding @schemeidfont{get-} and @schemeidfont{set-} } -@defmethod[(button-changed? [button (one-of/c 'left 'middle 'right 'any) 'any]) +@defmethod[(button-changed? [button (or/c 'left 'middle 'right 'any) 'any]) boolean?]{ Returns @scheme[#t] if this was a mouse button press or release event, @@ -64,7 +64,7 @@ If @scheme[button] is not @scheme['any], then @scheme[#t] is only returned } -@defmethod[(button-down? [button (one-of/c 'left 'middle 'right 'any) 'any]) +@defmethod[(button-down? [button (or/c 'left 'middle 'right 'any) 'any]) boolean?]{ Returns @scheme[#t] if the event is for a button press, @scheme[#f] @@ -75,7 +75,7 @@ If @scheme[button] is not @scheme['any], then @scheme[#t] is only returned } -@defmethod[(button-up? [button (one-of/c 'left 'middle 'right 'any) 'any]) +@defmethod[(button-up? [button (or/c 'left 'middle 'right 'any) 'any]) boolean?]{ Returns @scheme[#t] if the event is for a button release, @scheme[#f] @@ -142,9 +142,9 @@ Under Mac OS X, if a control-key press is combined with a mouse button } @defmethod[(get-event-type) - (one-of/c 'enter 'leave 'left-down 'left-up - 'middle-down 'middle-up - 'right-down 'right-up 'motion)]{ + (or/c 'enter 'leave 'left-down 'left-up + 'middle-down 'middle-up + 'right-down 'right-up 'motion)]{ Returns the type of the event; see @scheme[mouse-event%] for information about each event type. See also @method[mouse-event% @@ -254,9 +254,9 @@ Under Mac OS X, if a control-key press is combined with a mouse button } -@defmethod[(set-event-type [event-type (one-of/c 'enter 'leave 'left-down 'left-up - 'middle-down 'middle-up - 'right-down 'right-up 'motion)]) +@defmethod[(set-event-type [event-type (or/c 'enter 'leave 'left-down 'left-up + 'middle-down 'middle-up + 'right-down 'right-up 'motion)]) void?]{ Sets the type of the event; see @scheme[mouse-event%] for information