From 7758f508c561840991a59db20fe44ad5c0770f55 Mon Sep 17 00:00:00 2001 From: Kathy Gray Date: Mon, 21 Feb 2011 12:46:39 +0000 Subject: [PATCH] Addition of define-wish to the teaching languages and corresponding addition of support for wishes in test reports and check-expects --- collects/lang/htdp-beginner.rkt | 3 ++- collects/lang/private/teach.rkt | 30 ++++++++++++++++++---- collects/test-engine/racket-tests.rkt | 37 +++++++++++++++++++-------- collects/test-engine/test-display.scm | 18 +++++++++++++ collects/test-engine/test-engine.rkt | 16 ++++++++++++ collects/test-engine/test-info.scm | 22 ++++++++++++++++ 6 files changed, 110 insertions(+), 16 deletions(-) diff --git a/collects/lang/htdp-beginner.rkt b/collects/lang/htdp-beginner.rkt index 69086007b3..0ea60daa6c 100644 --- a/collects/lang/htdp-beginner.rkt +++ b/collects/lang/htdp-beginner.rkt @@ -40,6 +40,7 @@ check-error check-member-of check-range + define-wish #%datum #%top-interaction empty true false @@ -50,7 +51,7 @@ ; Property ; check-property for-all ==> expect expect-within expect-member-of expect-range ) - + (require (for-syntax "private/firstorder.ss")) ;; This is essentially a specialized version of `define-primitive' diff --git a/collects/lang/private/teach.rkt b/collects/lang/private/teach.rkt index d5febf48df..acf7e671ea 100644 --- a/collects/lang/private/teach.rkt +++ b/collects/lang/private/teach.rkt @@ -48,7 +48,7 @@ (rename lang/private/signature-syntax signature:property property) (all-except deinprogramm/quickcheck/quickcheck property) (rename deinprogramm/quickcheck/quickcheck quickcheck:property property) - test-engine/scheme-tests + test-engine/racket-tests scheme/class "../posn.rkt" (only lang/private/teachprims @@ -66,7 +66,8 @@ (only racket/base syntax->datum datum->syntax) (rename racket/base kw-app #%app) racket/struct-info - stepper/private/shared) + stepper/private/shared + test-engine/racket-tests) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; run-time helpers @@ -216,7 +217,9 @@ advanced-case advanced-match advanced-shared - advanced-delay) + advanced-delay + + define-wish) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; compile-time helpers @@ -630,14 +633,31 @@ (define (beginner-define/proc stx) (define/proc #t #f stx #'beginner-lambda)) - + + (define (define-wish/proc stx) + (syntax-case stx () + [(_ name) + (define/proc #t #f + #`(define (#,#'name x) + (begin + (send (send (get-test-engine) get-info) add-wish-call (quote #,#'name)) + (raise (exn:fail:wish (format "wished for function ~a not implemented" (quote #,#'name)) + (current-continuation-marks) (quote #,#'name) x)))) #'lambda)] + [(_ name default-value) + (define/proc #t #f + #`(define (#,#'name x) + (begin + (send (send (get-test-engine) get-info) add-wish-call (quote #,#'name)) + #,#'default-value)) + #'lambda)])) + (define (intermediate-define/proc stx) (define/proc #f #f stx #'intermediate-pre-lambda)) (define (intermediate-lambda-define/proc stx) ;; no special treatment of intermediate-lambda: (define/proc #f #f stx #'beginner-lambda)) - + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; lambda (beginner; only works with define) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/collects/test-engine/racket-tests.rkt b/collects/test-engine/racket-tests.rkt index a90d46e1cc..fda9fb33b6 100644 --- a/collects/test-engine/racket-tests.rkt +++ b/collects/test-engine/racket-tests.rkt @@ -1,15 +1,15 @@ -#lang mzscheme +#lang racket (require lang/private/teachprims scheme/class scheme/match lang/private/continuation-mark-key - (only scheme/base for memf findf) + (only-in scheme/base for memf findf) "test-engine.rkt" "test-info.scm" ) -(require-for-syntax stepper/private/shared) +(require (for-syntax stepper/private/shared)) (provide check-expect ;; syntax : (check-expect ) @@ -21,7 +21,9 @@ ; for other modules implementing check-expect-like forms (provide - (for-syntax check-expect-maker)) + (for-syntax check-expect-maker) + get-test-engine + exn:fail:wish) (define INEXACT-NUMBERS-FMT "check-expect cannot compare inexact numbers. Try (check-within test ~a range).") @@ -285,7 +287,13 @@ ;; ( -> scheme-val) scheme-val scheme-val test-engine symbol? -> void (define (run-and-check check maker test expect range src test-engine kind) (match-let ([(list result result-val exn) - (with-handlers ([exn:fail? + (with-handlers ([exn:fail:wish? + (lambda (e) + (let ([display (error-display-handler)]) + (list (unimplemented-wish src (test-format) (exn:fail:wish-name e) (exn:fail:wish-args e)) + 'error + #f)))] + [exn:fail? (lambda (e) (let ([display (error-display-handler)]) (list (make-unexpected-error src (test-format) expect @@ -299,11 +307,11 @@ (list (maker src (test-format) test-val expect range) test-val #f)])))]) (cond [(check-fail? result) (send (send test-engine get-info) check-failed result (check-fail-src result) exn) - (if exn - (raise exn) - #f)] - [else - #t]))) + (if exn (raise exn) #f)] + [else #t]))) + +;;Wishes +(struct exn:fail:wish exn:fail (name args)) (define (reset-tests) (let ([test-engine (namespace-variable-value @@ -316,6 +324,9 @@ (namespace-set-variable-value! 'test~object te (current-namespace)) te)) +(define (get-test-engine) + (namespace-variable-value 'test~object #f builder (current-namespace))) + (define-syntax (test stx) (syntax-case stx () [(_) @@ -410,6 +421,12 @@ (super-instantiate ()))) +(define wish-test-info% + (class* test-info-base% () + (inherit add-check-failure) + + (super-instantiate ()))) + (define scheme-test% (class* test-engine% () (super-instantiate ()) diff --git a/collects/test-engine/test-display.scm b/collects/test-engine/test-display.scm index 402f449d98..89d4dc178b 100644 --- a/collects/test-engine/test-display.scm +++ b/collects/test-engine/test-display.scm @@ -101,6 +101,9 @@ [total-checks (send test-info checks-run)] [failed-checks (send test-info checks-failed)] [violated-signatures (send test-info failed-signatures)] + [wishes (send test-info unimplemented-wishes)] + [total-wishes (length wishes)] + [total-wish-calls (send test-info called-wishes)] [check-outcomes (lambda (total failed zero-message ck?) @@ -120,6 +123,12 @@ (string-constant test-engine-ran-n-tests)) "\n") total)])) + (send editor insert + (cond + [(null? wishes) ""] + [(= 1 total-wishes) (format "Wished for function ~a has not been implemented.\n" (car wishes))] + [(= 2 total-wishes) (format "Wished for functions ~a and ~a have not been implemented.\n" (car wishes) (cadr wishes))] + [else (format "Wished for functions ~a have not been implemented.\n" (format-list wishes))])) (when (> total 0) (send editor insert (cond @@ -195,6 +204,11 @@ editor test-info src-editor)) insert-test-results editor test-info src-editor)))) + (define (format-list l) + (cond + [(null? (cdr l)) (format "and ~a" (car l))] + [else (format "~a, ~a" (car l) (format-list (cdr l)))])) + (define/public (display-check-failures checks editor test-info src-editor) (when (pair? checks) (send editor insert (string-append (string-constant test-engine-check-failures) "\n"))) @@ -292,6 +306,10 @@ (formatter (not-range-test fail)) (formatter (not-range-min fail)) (formatter (not-range-max fail)))] + [(unimplemented-wish? fail) + (print "Test relies on a call to wished for function ~F that has not been implemented, with arguments ~F." + (symbol->string (unimplemented-wish-name fail)) + (formatter (unimplemented-wish-args fail)))] [(property-fail? fail) (print-string (string-constant test-engine-property-fail-error)) (for-each (lambda (arguments) diff --git a/collects/test-engine/test-engine.rkt b/collects/test-engine/test-engine.rkt index d8b25f2562..a6bd03ab9a 100644 --- a/collects/test-engine/test-engine.rkt +++ b/collects/test-engine/test-engine.rkt @@ -3,6 +3,22 @@ (require racket/class "test-info.scm") +(define test-display-base% + (class* object% () + + (init-field (current-rep #f)) + (define test-info #f) + + (define/pubment (install-info t) + (set! test-info t) + (inner (void) install-info t)) + (define/public (get-info) test-info) + + (define/public (display-results) + '...) + + (super-instantiate ()))) + (define test-display-textual% (class* object% () diff --git a/collects/test-engine/test-info.scm b/collects/test-engine/test-info.scm index 7b61404f99..429b93e4e3 100644 --- a/collects/test-engine/test-info.scm +++ b/collects/test-engine/test-info.scm @@ -28,6 +28,10 @@ ;; (make-not-range src format scheme-val scheme-val scheme-val) (define-struct (not-range check-fail) (test min max)) +;;Wishes +(define-struct (unimplemented-wish check-fail) (name args)) + + (define-struct signature-got (value format)) (define-struct signature-violation (obj signature message srcloc blame)) @@ -49,8 +53,10 @@ (define failed-tsts 0) (define total-cks 0) (define failed-cks 0) + (define total-called-wishes 0) (define failures null) + (define wishes null) (define/public (test-style) style) (define/public (tests-run) total-tsts) @@ -61,8 +67,15 @@ (cond [(and (zero? total-tsts) (zero? total-cks)) 'no-tests] [(and (zero? failed-cks) (zero? failed-tsts)) 'all-passed] [else 'mixed-results])) + (define/public (called-wishes) total-called-wishes) (define/public (failed-checks) failures) + (define/public (unimplemented-wishes) wishes) + + (define/pubment (add-wish-call name) + (set! total-called-wishes (add1 total-called-wishes)) + (unless (memq name wishes) (set! wishes (cons name wishes))) + (inner (void) add-wish-call name)) (define/pubment (add-check) (set! total-cks (add1 total-cks)) @@ -76,6 +89,11 @@ (set! failed-cks (add1 failed-cks)) (set! failures (cons (make-failed-check fail exn?) failures)) (inner (void) add-check-failure fail exn?)) + + (define/pubment (add-wish name) + (unless (memq name wishes) + (set! wishes (cons name wishes))) + (inner (void) add-wish name)) ;; check-failed: (U check-fail (list (U string snip%))) src (U exn false) -> void (define/pubment (check-failed msg src exn?) @@ -139,6 +157,10 @@ (formatter (not-range-test fail)) (formatter (not-range-min fail)) (formatter (not-range-max fail)))] + [(unimplemented-wish? fail) + (print "Test relies on a call to wished for function ~F that has not been implemented, with arguments ~F." + (unimplemented-wish-name fail) + (formatter (unimplemented-wish-args fail)))] [(property-fail? fail) (print-string "Property falsifiable with") (for-each (lambda (arguments)