suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Addition of define-wish to the teaching languages and corresponding addition of support for wishes in test reports and check-expects

Browse Source
This commit is contained in:
Kathy Gray 2011-02-21 12:46:39 +00:00
parent 59be514889
commit 7758f508c5
6 changed files with 110 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/lang/htdp-beginner.rkt
View File

@ -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'

30
collects/lang/private/teach.rkt
View File

@ -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)
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

37
collects/test-engine/racket-tests.rkt
View File

@ -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 <expression> <expression>)
@ -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 ())

18
collects/test-engine/test-display.scm
View File

@ -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)

16
collects/test-engine/test-engine.rkt
View File

@ -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% ()

22
collects/test-engine/test-info.scm
View File

@ -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)