diff --git a/collects/framework/framework.ss b/collects/framework/framework.ss index f209405f..5eb90cbe 100644 --- a/collects/framework/framework.ss +++ b/collects/framework/framework.ss @@ -1,5 +1,4 @@ -(require-library "mred-interfaces.ss" "framework") -(require-library "frameworks.ss" "framework") +(require-relative-library "frameworks.ss") (require-library "string.ss") (require-library "function.ss") @@ -19,7 +18,7 @@ [framework:keys : framework:keys^] [framework:test : framework:test^]) (link [M : mred-interfaces^ (mred-interfaces@)] - [F : frameworkc^ ((require-library "frameworkc.ss" "framework") + [F : frameworkc^ ((require-relative-library "frameworkc.ss") core:string core:function core:pretty-print diff --git a/collects/framework/frameworks.ss b/collects/framework/frameworks.ss index 8f62e4cf..8d624376 100644 --- a/collects/framework/frameworks.ss +++ b/collects/framework/frameworks.ss @@ -12,13 +12,9 @@ (require-library "macro.ss") (require-relative-library "macro.ss") +(require-relative-library "mred-interfaces.ss") (require-relative-library "tests.ss") -(define-signature framework:keys^ - (shifted-key-list - get-shifted-key-list)) - - (define-signature framework:version^ (add-spec version)) diff --git a/collects/framework/keys.ss b/collects/framework/keys.ss deleted file mode 100644 index e536da56..00000000 --- a/collects/framework/keys.ss +++ /dev/null @@ -1,8 +0,0 @@ -(unit/sig framework:keys^ - (import) - - (define shifted-key-list - '("?" ":" "~" "\"" "|" - "<" ">" "{" "}" "[" "]" "(" ")" - "!" "@" "#" "$" "%" "^" "&" "*" "_" "+")) - (define (get-shifted-key-list) shifted-key-list)) \ No newline at end of file diff --git a/collects/tests/framework/load.ss b/collects/tests/framework/load.ss index e69de29b..b566fb5d 100644 --- a/collects/tests/framework/load.ss +++ b/collects/tests/framework/load.ss @@ -0,0 +1,66 @@ +(test + 'testr.ss + (lambda (x) #f) + '(parameterize ([current-namespace (make-namespace 'mred)]) + (require-library "tests.ss" "framework") + (invoke-open-unit/sig + (compound-unit/sig + (import) + (link [mred : mred-interfaces^ (mred-interfaces@)] + [keys : framework:keys^ ((require-library "keys.ss" "framework"))] + [test : framework:test^ ((require-library "testr.ss" "framework") mred keys)]) + (export (unit test)))) + (global-defined-value 'test:run-one) + (global-defined-value 'test:button-push) + (void))) + +(test + 'test.ss + (lambda (x) #f) + '(parameterize ([current-namespace (make-namespace 'mred)]) + (require-library "test.ss" "framework") + (global-defined-value 'test:run-one) + (global-defined-value 'test:button-push) + (void))) + +(test + 'mred-interfaces.ss + (lambda (x) + (printf "Called predicate: ~a~n" x) + #f) + '(parameterize ([current-namespace (make-namespace 'mred)]) + (require-library "mred-interfaces.ss" "framework") + (global-defined-value 'mred-interfaces^) + (global-defined-value 'mred-interfaces@) + (void))) + +(test + 'frameworkr.ss + (lambda (x) #f) + '(parameterize ([current-namespace (make-namespace 'mred)]) + (require-library "frameworks.ss" "framework") + (invoke-open-unit/sig + (compound-unit/sig + (import) + (link [mred : mred-interfaces^ (mred-interfaces@)] + [core : mzlib:core^ ((require-library "corer.ss"))] + [framework : framework^ ((require-library "frameworkr.ss" "framework") core mred)]) + (export (open framework)))) + (global-defined-value 'test:run-one) + (global-defined-value 'test:button-push) + (global-defined-value 'frame:basic-mixin) + (global-defined-value 'editor:basic-mixin) + (global-defined-value 'exit:exit) + (void))) + +(test + 'framework.ss + (lambda (x) #f) + '(parameterize ([current-namespace (make-namespace 'mred)]) + (require-library "framework.ss" "framework") + (global-defined-value 'test:run-one) + (global-defined-value 'test:button-push) + (global-defined-value 'frame:basic-mixin) + (global-defined-value 'editor:basic-mixin) + (global-defined-value 'exit:exit) + (void))) diff --git a/collects/tests/framework/main.ss b/collects/tests/framework/main.ss index 04df218c..e39cc8f8 100644 --- a/collects/tests/framework/main.ss +++ b/collects/tests/framework/main.ss @@ -61,8 +61,17 @@ (or (not (char-ready? in-port)) (not (eof-object? (peek-char in-port))))) (restart-mred)) - (printf "send-sexp-to-mred.sending:~n") - (pretty-print sexp) + (printf "sending to mred:~n") + (parameterize ([pretty-print-print-line + (let ([prompt " "] + [old-liner (pretty-print-print-line)]) + (lambda (ln port ol cols) + (let ([ov (old-liner ln port ol cols)]) + (if ln + (begin (display prompt port) + (+ (string-length prompt) ov)) + ov))))]) + (pretty-print sexp)) (write sexp out-port) (newline out-port) (let ([answer @@ -79,7 +88,6 @@ (loop)) null))))))]) (read in-port))]) - (printf "send-sexp-to-mred.received result~n") (unless (or (eof-object? answer) (and (list? answer) (= 2 (length answer)))) @@ -88,14 +96,16 @@ (raise (make-eof-result)) (case (car answer) [(error) - (error 'send-sexp-to-mred (format "mred raised \"~a\" with input: ~s" (second answer) sexp))] + (error 'send-sexp-to-mred (format "mred raised \"~a\"" (second answer)))] [(cant-read) (error 'mred/cant-parse (second answer))] [(normal) (second answer)])))))))) (define section-jump void) (define test - (opt-lambda (test-name failed? test [jump 'section]) + (case-lambda + [(test-name failed? sexp/proc) (test test-name failed? sexp/proc 'section)] + [(test-name failed? sexp/proc jump) (let ([failed (with-handlers ([(lambda (x) #t) (lambda (x) @@ -103,15 +113,15 @@ (exn-message x) x))]) (failed? - (if (procedure? test) - (test) - (eval (send-sexp-to-mred test)))))]) + (if (procedure? sexp/proc) + (sexp/proc) + (eval (send-sexp-to-mred sexp/proc)))))]) (when failed (printf "FAILED ~a: ~a~n" test-name failed) (case jump [(section) (section-jump)] [(continue) (void)] - [else (jump)]))))) + [else (jump)])))])) (define preferences-file (build-path (find-system-path 'pref-dir) (case (system-type)