diff --git a/collects/combinator-parser/private-combinator/combinator.scm b/collects/combinator-parser/private-combinator/combinator.scm index 80dc13d29e..8d7254300b 100644 --- a/collects/combinator-parser/private-combinator/combinator.scm +++ b/collects/combinator-parser/private-combinator/combinator.scm @@ -607,14 +607,14 @@ (cond [(weak-map-get inner-memo-table curr-input #f)(weak-map-get inner-memo-table curr-input)] [(null? curr-input) - #;(printf "out of input for ~a~n" repeat-name) + #;(printf "out of input for ~a~n" (repeat-name)) (make-repeat-res (make-res null null (repeat-name) "" 0 #f #f) 'out-of-input)] [else (let ([this-res (sub curr-input curr-src)]) #;(printf "Repeat of ~a called it's repeated entity ~n" (repeat-name)) (cond [(and (res? this-res) (res-a this-res)) - #;(printf "loop again case for ~a~n" repeat-name) + #;(printf "loop again case for ~a~n" (repeat-name)) (process-rest this-res (loop (res-rest this-res) (update-src (res-rest this-res) curr-src)))] @@ -650,8 +650,8 @@ curr-src)))] [else (map (lambda (match) - #;(printf "calling repeat loop again, res-rest match ~a~n" - (length (res-rest match))) + #;(printf "calling repeat loop again ~a, res-rest match ~a~n" + (repeat-name) (length (res-rest match))) (process-rest match (loop (res-rest match) (update-src (res-rest match) curr-src)))) diff --git a/collects/lang/htdp-langs.ss b/collects/lang/htdp-langs.ss index 7e8f58e57d..ed4ad0c5ff 100644 --- a/collects/lang/htdp-langs.ss +++ b/collects/lang/htdp-langs.ss @@ -38,8 +38,9 @@ "run-teaching-program.ss" stepper/private/shared - (lib "scheme-gui.scm" "test-engine") - (lib "test-display.scm" "test-engine") + (only test-engine/scheme-gui format-value) + (only test-engine/scheme-tests scheme-test-data scheme-test-format) + (lib "test-display.scm" "test-engine") ) @@ -160,7 +161,7 @@ [set-result-module-name ((current-module-name-resolver) '(lib "lang/private/set-result.ss") #f #f)] [scheme-test-module-name - ((current-module-name-resolver) '(lib "test-engine/scheme-gui.scm") #f #f)]) + ((current-module-name-resolver) '(lib "test-engine/scheme-tests.ss") #f #f)]) (run-in-user-thread (lambda () (read-accept-quasiquote (get-accept-quasiquote?)) @@ -175,6 +176,7 @@ (namespace-attach-module drs-namespace scheme-test-module-name) (namespace-require scheme-test-module-name) (scheme-test-data (list (drscheme:rep:current-rep) drs-eventspace test-display%)) + (scheme-test-format format-value) ))) (super on-execute settings run-in-user-thread)) diff --git a/collects/profj/comb-parsers/parser-units.scm b/collects/profj/comb-parsers/parser-units.scm index aac68d1763..9a255e8792 100644 --- a/collects/profj/comb-parsers/parser-units.scm +++ b/collects/profj/comb-parsers/parser-units.scm @@ -353,7 +353,7 @@ init #;(sequence (new type-name init) "array initialization"))) (define (binary-expression-end op) - (sequence (op expression) id "binary expression")) + (sequence (op (eta expression)) id "binary expression")) (define if-expr-end (sequence (? (eta expression) : (eta expression)) id "conditional expression")) @@ -669,11 +669,11 @@ (define class (class-def #f #f (implements-dec identifier) - (repeat-greedy (class-body (list field method constructor))))) + (repeat (class-body (list field method constructor))))) (define program - (make-program #f (repeat-greedy import-dec) - (repeat-greedy (top-member (list class interface))))) + (make-program #f (repeat import-dec) + (repeat (top-member (list class interface))))) (define interact (choose (field statement expression) "interactive program")) diff --git a/collects/test-engine/scheme-gui.scm b/collects/test-engine/scheme-gui.scm deleted file mode 100644 index 789e2e5357..0000000000 --- a/collects/test-engine/scheme-gui.scm +++ /dev/null @@ -1,32 +0,0 @@ -#lang scheme/base - -(require scheme/class - "test-engine.scm") - -(define scheme-test-data (make-parameter (list #f #f #f))) -(define scheme-test-format (make-parameter (lambda (v) (format "~a" v)))) - -(define scheme-test% - (class* test-engine% () - (super-instantiate ()) - (inherit-field test-info test-display) - (inherit setup-info) - - (field [tests null] - [test-objs null]) - - (define/public (add-test tst) - (set! tests (cons tst tests))) - (define/public (get-info) - (unless test-info (send this setup-info 'check-require)) - test-info) - - (define/augment (run) - (inner (void) run) - (for ([t (reverse tests)]) (run-test t))) - - (define/augment (run-test test) - (test) - (inner (void) run-test test)))) - -(provide scheme-test% scheme-test-data scheme-test-format) diff --git a/collects/test-engine/scheme-gui.ss b/collects/test-engine/scheme-gui.ss new file mode 100644 index 0000000000..e11dfffa82 --- /dev/null +++ b/collects/test-engine/scheme-gui.ss @@ -0,0 +1,33 @@ +(module scheme-gui scheme/base + + (require mred framework scheme/class + mzlib/pconvert mzlib/pretty) + + (require (except-in "scheme-tests.ss" test) "test-display.scm") + + (define (format-value value) + (cond + [(is-a? value snip%) value] + [(or (pair? value) (struct? value)) + (parameterize ([constructor-style-printing #t] + [pretty-print-columns 40]) + (let* ([text* (new (editor:standard-style-list-mixin text%))] + [text-snip (new editor-snip% [editor text*])]) + (pretty-print (print-convert value) (open-output-text-editor text*)) + (send text* lock #t) + text-snip))] + [else (format "~v" value)])) + + (define (test) (run-tests) (pop-up)) + + (define (pop-up) + (let ([test-info (namespace-variable-value 'test~object #f builder (current-namespace))]) + (parameterize ([scheme-test-format format-value]) + (and test-info + (send test-info refine-display-class test-display%) + (send test-info setup-display #f #f) + (send test-info summarize-results (current-output-port)))))) + + (provide test format-value (all-from-out "scheme-tests.ss")) + + ) \ No newline at end of file diff --git a/collects/test-engine/scheme-tests.ss b/collects/test-engine/scheme-tests.ss index 4e6c945df2..791b121dae 100644 --- a/collects/test-engine/scheme-tests.ss +++ b/collects/test-engine/scheme-tests.ss @@ -1,12 +1,10 @@ #lang mzscheme (require lang/private/teachprims - #;mred - #;framework - #;mzlib/pretty - #;mzlib/pconvert - mzlib/class - "scheme-gui.scm") + scheme/class + (only scheme/base for) + "test-engine.scm" + ) (require-for-syntax stepper/private/shared) @@ -16,61 +14,6 @@ check-error ;; syntax : (check-error ) ) -(define (builder) - (let ([te (build-test-engine)]) - (namespace-set-variable-value! 'test~object te (current-namespace)) - te)) - -(define (test) - (run-tests) - (display-results)) - -(define (test-text) - (run-tests) - (print-results)) - -(define-syntax (run-tests stx) - (syntax-case stx () - [(_) - (syntax-property - #'(run (namespace-variable-value 'test~object #f builder - (current-namespace))) - 'test-call #t)])) - -(define (run test-info) (and test-info (send test-info run))) - -(define-syntax (display-results stx) - (syntax-case stx () - [(_) - (syntax-property - #'(let ([test-info (namespace-variable-value 'test~object #f builder - (current-namespace))]) - (and test-info - (let ([display-data (scheme-test-data)]) - (send test-info refine-display-class (caddr display-data)) - (send test-info setup-display - (car display-data) (cadr display-data)) - (send test-info summarize-results (current-output-port))))) - 'test-call #t)])) - -(define-syntax (print-results stx) - (syntax-case stx () - [(_) - (syntax-property - #'(let ([test-info (namespace-variable-value 'test~object #f builder - (current-namespace))]) - (and test-info - (send test-info summarize-results (current-output-port)))) - 'test-call #t)])) - -(provide run-tests display-results test test-text) - -(define (build-test-engine) - (let ([engine (make-object scheme-test%)]) - (send engine setup-info 'check-require) - engine)) -(define (insert-test test-info test) (send test-info add-test test)) - (define INEXACT-NUMBERS-FMT "check-expect cannot compare inexact numbers. Try (check-within test ~a range).") (define CHECK-ERROR-STR-FMT @@ -272,15 +215,69 @@ ((scheme-test-format) (expected-error-value fail)) (format ".~n ~a~n" (expected-error-message fail)))])) -#;(define (format-value value) - (cond - [(is-a? value snip%) value] - [(or (pair? value) (struct? value)) - (parameterize ([constructor-style-printing #t] - [pretty-print-columns 40]) - (let* ([text* (new (editor:standard-style-list-mixin text%))] - [text-snip (new editor-snip% [editor text*])]) - (pretty-print (print-convert value) (open-output-text-editor text*)) - (send text* lock #t) - text-snip))] - [else (format "~v" value)])) + +(define (builder) + (let ([te (build-test-engine)]) + (namespace-set-variable-value! 'test~object te (current-namespace)) + te)) + +(define (test) (run-tests) (display-results)) + +(define-syntax (run-tests stx) + (syntax-case stx () + [(_) + (syntax-property + #'(run (namespace-variable-value 'test~object #f builder (current-namespace))) + 'test-call #t)])) + +(define (run test-info) (and test-info (send test-info run))) + +(define-syntax (display-results stx) + (syntax-case stx () + [(_) + (syntax-property + #'(let ([test-info (namespace-variable-value 'test~object #f builder (current-namespace))]) + (and test-info + (let ([display-data (scheme-test-data)]) + (when (caddr display-data) + (send test-info refine-display-class (caddr display-data))) + (send test-info setup-display (car display-data) (cadr display-data)) + (send test-info summarize-results (current-output-port))))) + 'test-call #t)])) + +(provide run-tests display-results test builder) + +(define (build-test-engine) + (let ([engine (make-object scheme-test%)]) + (send engine setup-info 'check-require) + engine)) + +(define (insert-test test-info test) (send test-info add-test test)) + +(define scheme-test-data (make-parameter (list #f #f #f))) +(define scheme-test-format (make-parameter (lambda (v) (format "~a" v)))) + +(define scheme-test% + (class* test-engine% () + (super-instantiate ()) + (inherit-field test-info test-display) + (inherit setup-info) + + (field [tests null] + [test-objs null]) + + (define/public (add-test tst) + (set! tests (cons tst tests))) + (define/public (get-info) + (unless test-info (send this setup-info 'check-require)) + test-info) + + (define/augment (run) + (inner (void) run) + (for ([t (reverse tests)]) (run-test t))) + + (define/augment (run-test test) + (test) + (inner (void) run-test test)))) + +(provide scheme-test-data scheme-test-format) \ No newline at end of file