Report signature violations in the REPL.
In the course of this, revamp the logic that controls when the test-results window pops up and when it doesn't. Closes PR 12185
This commit is contained in:
Mike Sperber
parent
45331d1ae8
commit
bbb38c0ff9
|
|
@ -377,6 +377,8 @@
|
|||
|
||||
(define signature-violations '())
|
||||
|
||||
(inherit report-failure)
|
||||
|
||||
(define/pubment (signature-failed obj signature message blame)
|
||||
|
||||
(let* ((cms
|
||||
|
|
@ -401,15 +403,18 @@
|
|||
(set! signature-violations
|
||||
(cons (make-signature-violation obj signature message srcloc blame)
|
||||
signature-violations)))
|
||||
(report-failure)
|
||||
(inner (void) signature-failed obj signature message))
|
||||
|
||||
(define/public (failed-signatures) (reverse signature-violations))
|
||||
|
||||
(inherit add-check-failure)
|
||||
(define/pubment (property-failed result src-info)
|
||||
(report-failure)
|
||||
(add-check-failure (make-property-fail src-info (test-format) result) #f))
|
||||
|
||||
(define/pubment (property-error exn src-info)
|
||||
(report-failure)
|
||||
(add-check-failure (make-property-error src-info (test-format) (exn-message exn) exn) exn))
|
||||
|
||||
(super-instantiate ())))
|
||||
|
|
|
|||
|
|
@ -142,8 +142,8 @@
|
|||
(define display-rep #f)
|
||||
(define display-event-space #f)
|
||||
(define silent-mode #t)
|
||||
(define test-run-since-last-display? #f)
|
||||
(define first-test-since-run? #t)
|
||||
(define initial-report-done #f)
|
||||
(define unreported-tests #f)
|
||||
|
||||
(super-instantiate ())
|
||||
|
||||
|
|
@ -154,7 +154,7 @@
|
|||
(define/public (add-analysis a) (send test-info add-analysis a))
|
||||
|
||||
(define/public (setup-info style)
|
||||
(set! first-test-since-run? #t)
|
||||
(set! initial-report-done #f)
|
||||
(set! test-info (make-object (info-class) style)))
|
||||
(define/pubment (setup-display cur-rep event-space)
|
||||
(set! test-display (make-object display-class cur-rep))
|
||||
|
|
@ -175,8 +175,9 @@
|
|||
|
||||
(define/public (summarize-results port)
|
||||
(cond
|
||||
((and (not test-run-since-last-display?)
|
||||
(not first-test-since-run?)))
|
||||
((and initial-report-done
|
||||
(not unreported-tests)
|
||||
(not (send test-info has-unreported-failures))))
|
||||
((test-execute)
|
||||
(unless test-display (setup-display #f #f))
|
||||
(send test-display install-info test-info)
|
||||
|
|
@ -191,16 +192,16 @@
|
|||
(+ (send test-info tests-run)
|
||||
(send test-info checks-run)))]
|
||||
[(mixed-results)
|
||||
(display-results display-rep display-event-space)]))))
|
||||
(display-results display-rep display-event-space)])))
|
||||
(send test-info clear-unreported-failures)
|
||||
(set! initial-report-done #t)
|
||||
(set! unreported-tests #f))
|
||||
(else
|
||||
(display-disabled port)))
|
||||
(set! first-test-since-run? #f)
|
||||
(set! test-run-since-last-display? #f))
|
||||
(display-disabled port))))
|
||||
|
||||
(define/private (display-success port event-space count)
|
||||
(when test-run-since-last-display?
|
||||
(clear-results event-space)
|
||||
(send test-display display-success-summary port count)))
|
||||
(send test-display display-success-summary port count))
|
||||
|
||||
(define/public (display-results rep event-space)
|
||||
(cond
|
||||
|
|
@ -214,19 +215,17 @@
|
|||
[else (send test-display display-results)]))
|
||||
|
||||
(define/public (display-untested port)
|
||||
(when (and test-run-since-last-display?
|
||||
(not silent-mode))
|
||||
(when (not silent-mode)
|
||||
(send test-display display-untested-summary port)))
|
||||
|
||||
(define/public (display-disabled port)
|
||||
(when test-run-since-last-display?
|
||||
(send test-display display-disabled-summary port)))
|
||||
(send test-display display-disabled-summary port))
|
||||
|
||||
(define/pubment (initialize-test test)
|
||||
(inner (void) initialize-test test))
|
||||
|
||||
(define/pubment (run-test test)
|
||||
(set! test-run-since-last-display? #t)
|
||||
(set! unreported-tests #t)
|
||||
(inner (void) run-test test))
|
||||
|
||||
(define/pubment (run-testcase testcase)
|
||||
|
|
|
|||
|
|
@ -58,6 +58,17 @@
|
|||
(define failures null)
|
||||
(define wishes null)
|
||||
|
||||
(define unreported-failures #f)
|
||||
|
||||
(define/public (clear-unreported-failures)
|
||||
(set! unreported-failures #f))
|
||||
|
||||
(define/public (report-failure)
|
||||
(set! unreported-failures #t))
|
||||
|
||||
(define/public (has-unreported-failures)
|
||||
unreported-failures)
|
||||
|
||||
(define/public (test-style) style)
|
||||
(define/public (tests-run) total-tsts)
|
||||
(define/public (tests-failed) failed-tsts)
|
||||
|
|
@ -105,10 +116,12 @@
|
|||
msg
|
||||
(make-message-error src #f msg))))
|
||||
(add-check-failure fail exn?)
|
||||
(report-failure)
|
||||
(inner (void) check-failed fail src exn?)))
|
||||
|
||||
(define/pubment (test-failed failed-info)
|
||||
(set! failed-tsts (add1 failed-tsts))
|
||||
(report-failure)
|
||||
(inner (void) test-failed failed-info))
|
||||
|
||||
(define/public (add-analysis a) (set! analyses (cons a analyses)))
|
||||
|
|
|
|||
|
|
@ -24,7 +24,9 @@
|
|||
(test-expression "(check-expect 1 2)"
|
||||
""
|
||||
#:check-failures-expected
|
||||
(list (make-check-expect-failure "1" "2" 1 0))))
|
||||
(list (make-check-expect-failure "1" "2" 1 0))
|
||||
#:repl-check-failures-expected
|
||||
(list (make-check-expect-failure "1" "2" 3 2))))
|
||||
|
||||
(define (common-signatures-*sl)
|
||||
(test-expression "(: foo Integer) (define foo 5)"
|
||||
|
|
@ -34,7 +36,20 @@
|
|||
""
|
||||
#:repl-expected "foo: this name was defined previously and cannot be re-defined"
|
||||
#:signature-violations-expected
|
||||
(list (make-signature-violation "\"bar\"" 1 7))))
|
||||
(list (make-signature-violation "\"bar\"" 1 7)))
|
||||
(test-expression "(: foo (Integer -> Integer)) (define (foo x) x) (foo \"foo\")"
|
||||
"\"foo\""
|
||||
#:repl-expected "foo: this name was defined previously and cannot be re-defined\n\"foo\""
|
||||
#:signature-violations-expected
|
||||
(list (make-signature-violation "\"foo\" at line 1, column 48 " 1 8))
|
||||
#:repl-signature-violations-expected
|
||||
(list (make-signature-violation "\"foo\" at line 4, column 50 " 1 8)))
|
||||
(test-expression "(: foo (Integer -> Integer)) (define foo (lambda (x) x))"
|
||||
""
|
||||
#:repl-expression "(foo \"foo\")"
|
||||
#:repl-expected "\"foo\""
|
||||
#:repl-signature-violations-expected
|
||||
(list (make-signature-violation "\"foo\" at line 3, column 2 " 1 8))))
|
||||
|
||||
(define (common-signatures-DMdA)
|
||||
(test-expression "(: foo integer) (define foo 5)"
|
||||
|
|
@ -44,7 +59,21 @@
|
|||
""
|
||||
#:repl-expected "define: Zweite Definition für denselben Namen"
|
||||
#:signature-violations-expected
|
||||
(list (make-signature-violation "\"bar\"" 1 7))))
|
||||
(list (make-signature-violation "\"bar\"" 1 7)))
|
||||
(test-expression "(: foo (integer -> integer)) (define foo (lambda (x) x)) (foo \"foo\")"
|
||||
"\"foo\""
|
||||
#:repl-expected "define: Zweite Definition für denselben Namen\n\"foo\""
|
||||
#:signature-violations-expected
|
||||
(list (make-signature-violation "\"foo\" at line 1, column 57 " 1 8))
|
||||
#:repl-signature-violations-expected
|
||||
(list (make-signature-violation "\"foo\" at line 4, column 59 " 1 8)))
|
||||
(test-expression "(: foo (integer -> integer)) (define foo (lambda (x) x))"
|
||||
""
|
||||
#:repl-expression "(foo \"foo\")"
|
||||
#:repl-expected "\"foo\""
|
||||
#:repl-signature-violations-expected
|
||||
(list (make-signature-violation "\"foo\" at line 3, column 2 " 1 8))))
|
||||
|
||||
|
||||
|
||||
;
|
||||
|
|
@ -315,31 +344,24 @@
|
|||
(else '())))
|
||||
|
||||
|
||||
;; test-expression : (union string 'xml 'image (listof (union string 'xml 'image)))
|
||||
;; (union string regexp (string -> boolean))
|
||||
;; -> void
|
||||
;; types an expression in the definitions window, executes it and tests the output
|
||||
;; types an expression in the REPL and tests the output from the REPL.
|
||||
(define (test-expression expression defs-expected
|
||||
#:repl-expression (repl-expression expression)
|
||||
#:repl-expected (repl-expected defs-expected)
|
||||
#:check-failures-expected (check-failures-expected '())
|
||||
#:signature-violations-expected (signature-violations-expected '()))
|
||||
#:signature-violations-expected (signature-violations-expected '())
|
||||
#:repl-check-failures-expected (repl-check-failures-expected '())
|
||||
#:repl-signature-violations-expected (repl-signature-violations-expected '()))
|
||||
(let* ([drs (wait-for-drscheme-frame)]
|
||||
[interactions-text (queue-callback/res (λ () (send drs get-interactions-text)))]
|
||||
[definitions-text (queue-callback/res (λ () (send drs get-definitions-text)))]
|
||||
[handle-insertion
|
||||
[handle-definition-insertion
|
||||
(lambda (item)
|
||||
(cond
|
||||
[(eq? item 'image)
|
||||
(use-get/put-dialog
|
||||
(lambda () (fw:test:menu-select "Insert" "Insert Image..."))
|
||||
(simplify-path (build-path (collection-path "icons") "recycle.png")))]
|
||||
[(string? item)
|
||||
(type-in-definitions drs item)]
|
||||
[(eq? item 'xml)
|
||||
(fw:test:menu-select "Insert" "Insert XML Box")
|
||||
(for-each fw:test:keystroke (string->list "<a><b>"))]
|
||||
[else (error 'handle-insertion "unknown thing to insert ~s" item)]))]
|
||||
(type-in-definitions drs item))]
|
||||
[handle-interaction-insertion
|
||||
(lambda (item)
|
||||
(type-in-interactions drs item))]
|
||||
[check-expectation
|
||||
(lambda (expected got)
|
||||
(cond
|
||||
|
|
@ -349,35 +371,8 @@
|
|||
(regexp-match expected got)]
|
||||
[(procedure? expected)
|
||||
(expected got)]))]
|
||||
[make-err-msg
|
||||
(lambda (expected)
|
||||
(cond
|
||||
[(string? expected)
|
||||
"FAILED: ~s ~s expected ~s to produce:\n ~s\ngot:\n ~s\ninstead\n"]
|
||||
[(regexp? expected)
|
||||
"FAILED: ~s ~s expected ~s to match ~s, got ~s instead\n"]
|
||||
[(procedure? expected)
|
||||
"FAILED: ~s ~s expected ~s to pass predicate ~s, got ~s\n"]))])
|
||||
(clear-definitions drs)
|
||||
(cond
|
||||
[(pair? expression) (for-each handle-insertion expression)]
|
||||
[else (handle-insertion expression)])
|
||||
(do-execute drs)
|
||||
|
||||
(let ([got
|
||||
(fetch-output
|
||||
drs
|
||||
(queue-callback/res (λ () (send interactions-text paragraph-start-position 2)))
|
||||
(queue-callback/res
|
||||
(λ ()
|
||||
(send interactions-text paragraph-end-position
|
||||
(- (send interactions-text last-paragraph) 1)))))])
|
||||
(when (regexp-match re:out-of-sync got)
|
||||
(error 'test-expression "got out of sync message"))
|
||||
(unless (check-expectation defs-expected got)
|
||||
(eprintf (make-err-msg defs-expected)
|
||||
'definitions (language) expression defs-expected got)))
|
||||
|
||||
[check-failures
|
||||
(lambda (signature-violations-expected check-failures-expected)
|
||||
(let ((text
|
||||
(cond
|
||||
((send (send definitions-text get-tab) get-test-editor)
|
||||
|
|
@ -405,17 +400,42 @@
|
|||
'definitions (language) expression signature-violations-expected signature-violations))))
|
||||
(else
|
||||
(eprintf "expected ~a check failures and ~a signature violations but got none"
|
||||
(length check-failures-expected) (length signature-violations-expected)))))
|
||||
; #### do same for REPL
|
||||
(length check-failures-expected) (length signature-violations-expected))))))]
|
||||
|
||||
[make-err-msg
|
||||
(lambda (expected)
|
||||
(cond
|
||||
[(string? expected)
|
||||
"FAILED: ~s ~s expected ~s to produce:\n ~s\ngot:\n ~s\ninstead\n"]
|
||||
[(regexp? expected)
|
||||
"FAILED: ~s ~s expected ~s to match ~s, got ~s instead\n"]
|
||||
[(procedure? expected)
|
||||
"FAILED: ~s ~s expected ~s to pass predicate ~s, got ~s\n"]))])
|
||||
(clear-definitions drs)
|
||||
(cond
|
||||
[(pair? expression) (for-each handle-definition-insertion expression)]
|
||||
[else (handle-definition-insertion expression)])
|
||||
(do-execute drs)
|
||||
|
||||
(let ([got
|
||||
(fetch-output
|
||||
drs
|
||||
(queue-callback/res (λ () (send interactions-text paragraph-start-position 2)))
|
||||
(queue-callback/res
|
||||
(λ ()
|
||||
(send definitions-text select-all)
|
||||
(send definitions-text copy)
|
||||
(send interactions-text set-position
|
||||
(send interactions-text last-position)
|
||||
(send interactions-text last-position))
|
||||
(send interactions-text paste)))
|
||||
(send interactions-text paragraph-end-position
|
||||
(- (send interactions-text last-paragraph) 1)))))])
|
||||
(when (regexp-match re:out-of-sync got)
|
||||
(error 'test-expression "got out of sync message"))
|
||||
(unless (check-expectation defs-expected got)
|
||||
(eprintf (make-err-msg defs-expected)
|
||||
'definitions (language) expression defs-expected got)))
|
||||
|
||||
(check-failures signature-violations-expected check-failures-expected)
|
||||
|
||||
(cond
|
||||
[(pair? repl-expression) (for-each handle-interaction-insertion repl-expression)]
|
||||
[else (handle-interaction-insertion repl-expression)])
|
||||
|
||||
(let ([last-para (queue-callback/res (lambda () (send interactions-text last-paragraph)))])
|
||||
(alt-return-in-interactions drs)
|
||||
|
|
@ -433,7 +453,11 @@
|
|||
(when (regexp-match re:out-of-sync got)
|
||||
(error 'test-expression "got out of sync message"))
|
||||
(unless (check-expectation repl-expected got)
|
||||
(eprintf (make-err-msg repl-expected) 'interactions (language) expression repl-expected got))))))
|
||||
(eprintf (make-err-msg repl-expected) 'interactions (language) expression repl-expected got))))
|
||||
|
||||
;; the failures from the definition window stick around
|
||||
(check-failures (append signature-violations-expected repl-signature-violations-expected)
|
||||
(append check-failures-expected repl-check-failures-expected))))
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user