diff --git a/collects/deinprogramm/contract/contract-test-display.rkt b/collects/deinprogramm/contract/contract-test-display.rkt deleted file mode 100644 index 4a9f0bb7b6..0000000000 --- a/collects/deinprogramm/contract/contract-test-display.rkt +++ /dev/null @@ -1,494 +0,0 @@ -#lang scheme/base - -; DeinProgramm version of collects/test-engine/test-display.ss -; synched with SVN rev 16065 - -(provide contract-test-display%) - -(require scheme/class - scheme/file - mred - framework - string-constants - (lib "test-engine/test-info.scm") - (lib "test-engine/test-engine.scm") - (lib "test-engine/print.ss") - (except-in deinprogramm/contract/contract contract-violation) ; clashes with test-engine - deinprogramm/quickcheck/quickcheck) - -(define contract-test-display% - (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 current-tab #f) - (define drscheme-frame #f) - (define src-editor #f) - (define/public (display-settings df ct ed) - (set! current-tab ct) - (set! drscheme-frame df) - (set! src-editor ed)) - - (define (docked?) - (and drscheme-frame - (get-preference 'test:test-window:docked? - (lambda () (put-preferences '(test:test-window:docked?) '(#f)) #f)))) - - (define/public (report-success) - (when current-rep - (unless current-tab - (set! current-tab (send (send current-rep get-definitions-text) get-tab))) - (unless drscheme-frame - (set! drscheme-frame (send current-rep get-top-level-window))) - (let ([curr-win (and current-tab (send current-tab get-test-window))]) - (when curr-win - (let ([content (make-object (editor:standard-style-list-mixin text%))]) - (send content lock #t) - (when curr-win (send curr-win update-editor content)) - (when current-tab (send current-tab current-test-editor content)) - (when (docked?) - (send drscheme-frame display-test-panel content) - (send curr-win show #f))))))) - - (define/public (display-success-summary port count) - (unless (test-silence) - (display (case count - [(0) (string-constant test-engine-0-tests-passed)] - [(1) (string-constant test-engine-1-test-passed)] - [(2) (string-constant test-engine-both-tests-passed)] - [else (format (string-constant test-engine-all-n-tests-passed) - count)]) - port))) - - (define/public (display-untested-summary port) - (unless (test-silence) - (fprintf port (string-constant test-engine-should-be-tested)) - (display "\n" port))) - - (define/public (display-disabled-summary port) - (display (string-constant test-engine-tests-disabled) port) - (display "\n" port)) - - (define/public (display-results) - (let* ([curr-win (and current-tab (send current-tab get-test-window))] - [window (or curr-win (make-object test-window%))] - [content (make-object (editor:standard-style-list-mixin text%))]) - - (send this insert-test-results content test-info src-editor) - (send content lock #t) - (send window update-editor content) - (when current-tab - (send current-tab current-test-editor content) - (unless curr-win - (send current-tab current-test-window window) - (send drscheme-frame register-test-window window) - (send window update-switch - (lambda () (send drscheme-frame dock-tests))) - (send window update-disable - (lambda () (send current-tab update-test-preference #f))) - (send window update-closer - (lambda() - (send drscheme-frame deregister-test-window window) - (send current-tab current-test-window #f) - (send current-tab current-test-editor #f))))) - (if (docked?) - (send drscheme-frame display-test-panel content) - (send window show #t)))) - - (define/pubment (insert-test-results editor test-info src-editor) - (let* ([style (send test-info test-style)] - [total-checks (send test-info checks-run)] - [failed-checks (send test-info checks-failed)] - [violated-contracts (send test-info failed-contracts)] - [check-outcomes - (lambda (zero-message) - (send editor insert - (cond - [(zero? total-checks) zero-message] - [(= 1 total-checks) - (string-append (string-constant test-engine-ran-1-check) "\n")] - [else (format (string-append (string-constant test-engine-ran-n-checks) "\n") - total-checks)])) - (when (> total-checks 0) - (send editor insert - (cond - [(and (zero? failed-checks) (= 1 total-checks)) - (string-append (string-constant test-engine-1-check-passed) "\n\n")] - [(zero? failed-checks) - (string-append (string-constant test-engine-all-checks-passed) "\n\n")] - [(= failed-checks total-checks) - (string-append (string-constant test-engine-0-checks-passed) "\n")] - [else (format (string-append (string-constant test-engine-m-of-n-checks-failed) "\n\n") - failed-checks total-checks)]))) - (send editor insert - (cond - ((null? violated-contracts) - (string-append (string-constant test-engine-no-contract-violations) "\n\n")) - ((null? (cdr violated-contracts)) - (string-append (string-constant test-engine-1-contract-violation) "\n\n")) - (else - (format (string-append (string-constant test-engine-n-contract-violations) "\n\n") - (length violated-contracts))))) - )]) - (case style - [(check-require) - (check-outcomes (string-append (string-constant test-engine-is-unchecked) "\n"))] - [else (check-outcomes "")]) - - (unless (and (zero? total-checks) - (null? violated-contracts)) - (inner (begin - (display-check-failures (send test-info failed-checks) - editor test-info src-editor) - (send editor insert "\n") - (display-contract-violations violated-contracts - editor test-info src-editor)) - insert-test-results editor test-info src-editor)))) - - (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"))) - (for ([failed-check (reverse checks)]) - (send editor insert "\t") - (if (failed-check-exn? failed-check) - (make-error-link editor - (failed-check-reason failed-check) - (failed-check-exn? failed-check) - (check-fail-src (failed-check-reason failed-check)) - src-editor) - (make-link editor - (failed-check-reason failed-check) - (check-fail-src (failed-check-reason failed-check)) - src-editor)) - (send editor insert "\n"))) - - (define/public (display-contract-violations violations editor test-info src-editor) - (when (pair? violations) - (send editor insert (string-append (string-constant test-engine-contract-violations) "\n"))) - (for-each (lambda (violation) - (send editor insert "\t") - (make-contract-link editor violation src-editor) - (send editor insert "\n")) - violations)) - - ;next-line: editor% -> void - ;Inserts a newline and a tab into editor - (define/public (next-line editor) (send editor insert "\n\t")) - - ;; make-link: text% check-fail src editor -> void - (define (make-link text reason dest src-editor) - (display-reason text reason) - (let ((start (send text get-end-position))) - (send text insert (format-src dest)) - (when (and src-editor current-rep) - (send text set-clickback - start (send text get-end-position) - (lambda (t s e) (highlight-check-error dest src-editor)) - #f #f) - (set-clickback-style text start "royalblue")))) - - (define (display-reason text fail) - (let* ((print-string - (lambda (m) - (send text insert m))) - (print-formatted - (lambda (m) - (when (is-a? m snip%) - (send m set-style (send (send text get-style-list) - find-named-style "Standard"))) - (send text insert m))) - (print - (lambda (fstring . vals) - (apply print-with-values fstring print-string print-formatted vals))) - (formatter (check-fail-format fail))) - (cond - [(unexpected-error? fail) - (print (string-constant test-engine-check-encountered-error) - (formatter (unexpected-error-expected fail)) - (unexpected-error-message fail))] - [(unequal? fail) - (print (string-constant test-engine-actual-value-differs-error) - (formatter (unequal-test fail)) - (formatter (unequal-actual fail)))] - [(outofrange? fail) - (print (string-constant test-engine-actual-value-not-within-error) - (formatter (outofrange-test fail)) - (outofrange-range fail) - (formatter (outofrange-actual fail)))] - [(incorrect-error? fail) - (print (string-constant test-engine-encountered-error-error) - (incorrect-error-expected fail) - (incorrect-error-message fail))] - [(expected-error? fail) - (print (string-constant test-engine-expected-error-error) - (formatter (expected-error-value fail)) - (expected-error-message fail))] - [(message-error? fail) - (for-each print-formatted (message-error-strings fail))] - [(not-mem? fail) - (print (string-constant test-engine-not-mem-error) - (formatter (not-mem-test fail))) - (for-each (lambda (a) (print " ~F" (formatter a))) (not-mem-set fail)) - (print ".")] - [(not-range? fail) - (print (string-constant test-engine-not-range-error) - (formatter (not-range-test fail)) - (formatter (not-range-min fail)) - (formatter (not-range-max fail)))] - [(property-fail? fail) - (print-string (string-constant test-engine-property-fail-error)) - (for-each (lambda (arguments) - (for-each (lambda (p) - (if (car p) - (print " ~a = ~F" (car p) (formatter (cdr p))) - (print "~F" (formatter (cdr p))))) - arguments)) - (result-arguments-list (property-fail-result fail)))] - [(property-error? fail) - (print (string-constant test-engine-property-error-error) - (property-error-message fail))]) - (print-string "\n"))) - - ;; make-error-link: text% check-fail exn src editor -> void - (define (make-error-link text reason exn dest src-editor) - (make-link text reason dest src-editor) - ;; the following code never worked - #;(let ((start (send text get-end-position))) - (send text insert (string-constant test-engine-trace-error)) - (send text insert " ") - (when (and src-editor current-rep) - (send text set-clickback - start (send text get-end-position) - (lambda (t s e) ((error-handler) exn)) - #f #f) - (set-clickback-style text start "red")))) - - (define (insert-messages text msgs) - (for ([m msgs]) - (when (is-a? m snip%) - (send m set-style (send (send text get-style-list) - find-named-style "Standard"))) - (send text insert m))) - - (define (make-contract-link text violation src-editor) - (let* ((contract (contract-violation-contract violation)) - (stx (contract-syntax contract)) - (srcloc (contract-violation-srcloc violation)) - (message (contract-violation-message violation))) - (cond - ((string? message) - (send text insert message)) - ((contract-got? message) - (insert-messages text (list (string-constant test-engine-got) - " " - ((contract-got-format message) - (contract-got-value message)))))) - (when srcloc - (send text insert " ") - (let ((source (srcloc-source srcloc)) - (line (srcloc-line srcloc)) - (column (srcloc-column srcloc)) - (pos (srcloc-position srcloc)) - (span (srcloc-span srcloc)) - (start (send text get-end-position))) - (send text insert (format-position source line column)) - (send text set-clickback - start (send text get-end-position) - (lambda (t s e) - (highlight-error line column pos span src-editor)) - #f #f) - (set-clickback-style text start "blue"))) - (send text insert ", ") - (send text insert (string-constant test-engine-contract)) - (send text insert " ") - (format-clickable-syntax-src text stx src-editor) - (cond - ((contract-violation-blame violation) - => (lambda (blame) - (next-line text) - (send text insert (string-constant test-engine-to-blame)) - (send text insert " ") - (format-clickable-syntax-src text blame src-editor)))))) - - (define (format-clickable-syntax-src text stx src-editor) - (let ((start (send text get-end-position))) - (send text insert (format-syntax-src stx)) - (send text set-clickback - start (send text get-end-position) - (lambda (t s e) - (highlight-error/syntax stx src-editor)) - #f #f) - (set-clickback-style text start "blue"))) - - (define (set-clickback-style text start color) - (let ([end (send text get-end-position)] - [c (new style-delta%)]) - (send text insert " ") - (send text change-style - (make-object style-delta% 'change-underline #t) - start end #f) - (send c set-delta-foreground color) - (send text change-style c start end #f))) - - (define (format-syntax-src stx) - (format-position (syntax-source stx) - (syntax-line stx) (syntax-column stx))) - - ;format-src: src -> string - (define (format-src src) - (format-position (car src) (cadr src) (caddr src))) - - (define (format-position file line column) - (let ([line (cond [line => number->string] - [else - (string-constant test-engine-unknown)])] - [col - (cond [column => number->string] - [else (string-constant test-engine-unknown)])]) - - (if (path? file) - (let-values (((base name must-be-dir?) - (split-path file))) - (if (path? name) - (format (string-constant test-engine-in-at-line-column) - (path->string name) line col) - (format (string-constant test-engine-at-line-column) - line col))) - (format (string-constant test-engine-at-line-column) - line col)))) - - (define (highlight-error line column position span src-editor) - (when (and current-rep src-editor) - (cond - [(is-a? src-editor text:basic<%>) - (let ((highlight - (lambda () - (send current-rep highlight-errors - (list (make-srcloc src-editor - line - column - position span)) #f)))) - (queue-callback highlight))]))) - - (define (highlight-check-error srcloc src-editor) - (let* ([src-pos cadddr] - [src-span (lambda (l) (car (cddddr l)))] - [position (src-pos srcloc)] - [span (src-span srcloc)]) - (highlight-error (cadr srcloc) (caddr srcloc) - position span - src-editor))) - - (define (highlight-error/syntax stx src-editor) - (highlight-error (syntax-line stx) (syntax-column stx) - (syntax-position stx) (syntax-span stx) - src-editor)) - - (super-instantiate ()))) - -(define test-window% - (class* frame% () - - (super-instantiate - ((string-constant test-engine-window-title) #f 400 350)) - - ;; (define editor #f) - (define switch-func void) - (define disable-func void) - (define close-cleanup void) - - (define content - (make-object editor-canvas% this #f '(auto-vscroll))) - - (define button-panel - (make-object horizontal-panel% this - '() #t 0 0 0 0 '(right bottom) 0 0 #t #f)) - - (define buttons - (list (make-object button% - (string-constant close) - button-panel - (lambda (b c) - (when (eq? 'button (send c get-event-type)) - (close-cleanup) - (send this show #f)))) - (make-object button% - (string-constant dock) - button-panel - (lambda (b c) - (when (eq? 'button (send c get-event-type)) - (send this show #f) - (put-preferences '(test:test-window:docked?) - '(#t)) - (switch-func)))) - (make-object grow-box-spacer-pane% button-panel))) - - (define/public (update-editor e) - ;;(set! editor e) - (send content set-editor e)) - - (define/public (update-switch thunk) - (set! switch-func thunk)) - (define/public (update-closer thunk) - (set! close-cleanup thunk)) - (define/public (update-disable thunk) - (set! disable-func thunk)))) - -(define test-panel% - (class* vertical-panel% () - - (inherit get-parent) - - (super-instantiate ()) - - (define content (make-object editor-canvas% this #f '())) - (define button-panel (make-object horizontal-panel% this - '() #t 0 0 0 0 '(right bottom) 0 0 #t #f)) - (define (hide) - (let ([current-tab (send frame get-current-tab)]) - (send frame deregister-test-window - (send current-tab get-test-window)) - (send current-tab current-test-window #f) - (send current-tab current-test-editor #f)) - (remove)) - - (make-object button% - (string-constant hide) - button-panel - (lambda (b c) - (when (eq? 'button (send c get-event-type)) - (hide)))) - #;(make-object button% - (string-constant profj-test-results-hide-and-disable) - button-panel - (lambda (b c) - (when (eq? 'button (send c get-event-type)) - (hide) - (send (send frame get-current-tab) - update-test-preference #f)))) - (make-object button% - (string-constant undock) - button-panel - (lambda (b c) - (when (eq? 'button (send c get-event-type)) - (put-preferences '(test:test-window:docked?) '(#f)) - (send frame undock-tests)))) - - (define/public (update-editor e) - (send content set-editor e)) - - (define frame #f) - (define/public (update-frame f) - (set! frame f)) - - (define/public (remove) - (let ([parent (get-parent)]) - (put-preferences '(test:test-dock-size) - (list (send parent get-percentages))) - (send parent delete-child this))))) - diff --git a/collects/deinprogramm/deinprogramm-langs.rkt b/collects/deinprogramm/deinprogramm-langs.rkt index 239f9a5e49..96dd7e4792 100644 --- a/collects/deinprogramm/deinprogramm-langs.rkt +++ b/collects/deinprogramm/deinprogramm-langs.rkt @@ -29,8 +29,8 @@ (only-in test-engine/scheme-gui make-formatter) test-engine/scheme-tests + (lib "test-display.scm" "test-engine") deinprogramm/contract/contract - deinprogramm/contract/contract-test-display ) @@ -199,7 +199,7 @@ => (lambda (engine) (send (send engine get-info) contract-failed obj contract message blame)))))) - (scheme-test-data (list (drscheme:rep:current-rep) drs-eventspace contract-test-display%)) + (scheme-test-data (list (drscheme:rep:current-rep) drs-eventspace test-display%)) (test-execute (get-preference 'tests:enable? (lambda () #t))) (test-format (make-formatter (lambda (v o) (render-value/format (if (procedure? v) diff --git a/collects/test-engine/test-display.scm b/collects/test-engine/test-display.scm index 04c01f88a8..55d076bf5d 100644 --- a/collects/test-engine/test-display.scm +++ b/collects/test-engine/test-display.scm @@ -7,7 +7,9 @@ string-constants "test-info.scm" "test-engine.scm" - "print.ss") + "print.ss" + (except-in deinprogramm/contract/contract contract-violation) ; clashes with test-engine + deinprogramm/quickcheck/quickcheck) (define test-display% (class* object% () @@ -38,15 +40,15 @@ (set! current-tab (send (send current-rep get-definitions-text) get-tab))) (unless drscheme-frame (set! drscheme-frame (send current-rep get-top-level-window))) - (let ([curr-win (and current-tab (send current-tab get-test-window))] - [content (make-object (editor:standard-style-list-mixin text%))]) - (send this insert-test-results content test-info src-editor) - (send content lock #t) - (when curr-win (send curr-win update-editor content)) - (when current-tab (send current-tab current-test-editor content)) - (when (and curr-win (docked?)) - (send drscheme-frame display-test-panel content) - #;(send curr-win show #f))))) + (let ([curr-win (and current-tab (send current-tab get-test-window))]) + (when curr-win + (let ([content (make-object (editor:standard-style-list-mixin text%))]) + (send content lock #t) + (when curr-win (send curr-win update-editor content)) + (when current-tab (send current-tab current-test-editor content)) + (when (docked?) + (send drscheme-frame display-test-panel content) + (send curr-win show #f))))))) (define/public (display-success-summary port count) (unless (test-silence) @@ -99,61 +101,73 @@ [failed-tests (send test-info tests-failed)] [total-checks (send test-info checks-run)] [failed-checks (send test-info checks-failed)] - [outcomes + [violated-contracts (send test-info failed-contracts)] + + [check-outcomes (lambda (total failed zero-message ck?) (send editor insert (cond - [(zero? total) zero-message] - [(= 1 total) - (string-append - (if ck? - (string-constant test-engine-ran-1-check) - (string-constant test-engine-ran-1-test)) - "\n")] - [else - (format (string-append - (if ck? - (string-constant test-engine-ran-n-checks) - (string-constant test-engine-ran-n-tests)) - "\n") - total)])) + [(zero? total) zero-message] + [(= 1 total) + (string-append + (if ck? + (string-constant test-engine-ran-1-check) + (string-constant test-engine-ran-1-test)) + "\n")] + [else + (format (string-append + (if ck? + (string-constant test-engine-ran-n-checks) + (string-constant test-engine-ran-n-tests)) + "\n") + total)])) (when (> total 0) (send editor insert (cond - [(and (zero? failed) (= 1 total)) - (string-append (if ck? - (string-constant test-engine-1-check-passed) - (string-constant test-engine-1-test-passed)) - "\n\n")] - [(zero? failed) - (string-append (if ck? - (string-constant test-engine-all-checks-passed) - (string-constant test-engine-all-tests-passed)) - "\n\n")] - [(= failed total) - (string-append (if ck? - (string-constant test-engine-0-checks-passed) - (string-constant test-engine-0-tests-passed)) - "\n")] - [else - (format - (string-append (if ck? - (string-constant test-engine-m-of-n-checks-failed) - (string-constant test-engine-m-of-n-tests-failed)) - "\n\n") - failed total)]))))] + [(and (zero? failed) (= 1 total)) + (string-append (if ck? + (string-constant test-engine-1-check-passed) + (string-constant test-engine-1-test-passed)) + "\n\n")] + [(zero? failed) + (string-append (if ck? + (string-constant test-engine-all-checks-passed) + (string-constant test-engine-all-tests-passed)) + "\n\n")] + [(= failed total) + (string-append (if ck? + (string-constant test-engine-0-checks-passed) + (string-constant test-engine-0-tests-passed)) + "\n")] + [else (format (string-append + (if ck? + (string-constant test-engine-m-of-n-checks-failed) + (string-constant test-engine-0-tests-passed)) + "\n\n") + failed total)]))) + (send editor insert + (cond + ((null? violated-contracts) + (string-append (string-constant test-engine-no-contract-violations) "\n\n")) + ((null? (cdr violated-contracts)) + (string-append (string-constant test-engine-1-contract-violation) "\n\n")) + (else + (format (string-append (string-constant test-engine-n-contract-violations) "\n\n") + (length violated-contracts))))) + )] + [check-outcomes/check (lambda (zero-message) - (outcomes total-checks failed-checks - zero-message #t))] + (check-outcomes total-checks failed-checks + zero-message #t))] [check-outcomes/test (lambda (zero-message) - (outcomes total-checks failed-checks - zero-message #f))] + (check-outcomes total-checks failed-checks + zero-message #f))] [test-outcomes (lambda (zero-message) - (outcomes total-tests failed-tests - zero-message #f))]) + (check-outcomes total-tests failed-tests + zero-message #f))]) (case style [(test-require) (test-outcomes @@ -172,12 +186,19 @@ "\n"))] [else (check-outcomes/check "")]) - (unless (and (zero? total-checks) (zero? total-tests)) - (inner (display-check-failures (send test-info failed-checks) - editor test-info src-editor) + (unless (and (zero? total-checks) + (null? violated-contracts)) + (inner (begin + (display-check-failures (send test-info failed-checks) + editor test-info src-editor) + (send editor insert "\n") + (display-contract-violations violated-contracts + editor test-info src-editor)) insert-test-results editor test-info src-editor)))) (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"))) (for ([failed-check (reverse checks)]) (send editor insert "\t") (if (failed-check-exn? failed-check) @@ -192,6 +213,15 @@ src-editor)) (send editor insert "\n"))) + (define/public (display-contract-violations violations editor test-info src-editor) + (when (pair? violations) + (send editor insert (string-append (string-constant test-engine-contract-violations) "\n"))) + (for-each (lambda (violation) + (send editor insert "\t") + (make-contract-link editor violation src-editor) + (send editor insert "\n")) + violations)) + ;next-line: editor% -> void ;Inserts a newline and a tab into editor (define/public (next-line editor) (send editor insert "\n\t")) @@ -206,14 +236,7 @@ start (send text get-end-position) (lambda (t s e) (highlight-check-error dest src-editor)) #f #f) - (let ([end (send text get-end-position)] - [c (new style-delta%)]) - (send text insert " ") - (send text change-style - (make-object style-delta% 'change-underline #t) - start end #f) - (send c set-delta-foreground "royalblue") - (send text change-style c start end #f))))) + (set-clickback-style text start "royalblue")))) (define (display-reason text fail) #;(write (list 'display-reason fail (check-fail? fail) (message-error? fail)) @@ -267,12 +290,25 @@ (formatter (not-range-test fail)) (formatter (not-range-min fail)) (formatter (not-range-max fail)))] + [(property-fail? fail) + (print-string (string-constant test-engine-property-fail-error)) + (for-each (lambda (arguments) + (for-each (lambda (p) + (if (car p) + (print " ~a = ~F" (car p) (formatter (cdr p))) + (print "~F" (formatter (cdr p))))) + arguments)) + (result-arguments-list (property-fail-result fail)))] + [(property-error? fail) + (print (string-constant test-engine-property-error-error) + (property-error-message fail))] ) (print-string "\n"))) ;; make-error-link: text% check-fail exn src editor -> void (define (make-error-link text reason exn dest src-editor) (make-link text reason dest src-editor) + ;; the following code never worked #;(let ((start (send text get-end-position))) (send text insert (string-constant test-engine-trace-error)) (send text insert " ") @@ -281,53 +317,128 @@ start (send text get-end-position) (lambda (t s e) ((error-handler) exn)) #f #f) - (let ([end (send text get-end-position)] - [c (new style-delta%)]) - (send text insert " ") - (send text change-style - (make-object style-delta% 'change-underline #t) - start end #f) - (send c set-delta-foreground "red") - (send text change-style c start end #f))))) + (set-clickback-style text start "red")))) + + (define (insert-messages text msgs) + (for ([m msgs]) + (when (is-a? m snip%) + (send m set-style (send (send text get-style-list) + find-named-style "Standard"))) + (send text insert m))) + + (define (make-contract-link text violation src-editor) + (let* ((contract (contract-violation-contract violation)) + (stx (contract-syntax contract)) + (srcloc (contract-violation-srcloc violation)) + (message (contract-violation-message violation))) + (cond + ((string? message) + (send text insert message)) + ((contract-got? message) + (insert-messages text (list (string-constant test-engine-got) + " " + ((contract-got-format message) + (contract-got-value message)))))) + (when srcloc + (send text insert " ") + (let ((source (srcloc-source srcloc)) + (line (srcloc-line srcloc)) + (column (srcloc-column srcloc)) + (pos (srcloc-position srcloc)) + (span (srcloc-span srcloc)) + (start (send text get-end-position))) + (send text insert (format-position source line column)) + (send text set-clickback + start (send text get-end-position) + (lambda (t s e) + (highlight-error line column pos span src-editor)) + #f #f) + (set-clickback-style text start "blue"))) + (send text insert ", ") + (send text insert (string-constant test-engine-contract)) + (send text insert " ") + (format-clickable-syntax-src text stx src-editor) + (cond + ((contract-violation-blame violation) + => (lambda (blame) + (next-line text) + (send text insert (string-constant test-engine-to-blame)) + (send text insert " ") + (format-clickable-syntax-src text blame src-editor)))))) + + (define (format-clickable-syntax-src text stx src-editor) + (let ((start (send text get-end-position))) + (send text insert (format-syntax-src stx)) + (send text set-clickback + start (send text get-end-position) + (lambda (t s e) + (highlight-error/syntax stx src-editor)) + #f #f) + (set-clickback-style text start "blue"))) + + (define (set-clickback-style text start color) + (let ([end (send text get-end-position)] + [c (new style-delta%)]) + (send text insert " ") + (send text change-style + (make-object style-delta% 'change-underline #t) + start end #f) + (send c set-delta-foreground color) + (send text change-style c start end #f))) + + (define (format-syntax-src stx) + (format-position (syntax-source stx) + (syntax-line stx) (syntax-column stx))) ;format-src: src -> string (define (format-src src) - (let ([src-file car] - [src-line cadr] - [src-col caddr]) - (let ([line (cond [(src-line src) => number->string] - [else - (string-constant test-engine-unknown)])] - [col - (cond [(src-col src) => number->string] - [else (string-constant test-engine-unknown)])]) - (string-append - " " - (cond - [(or (symbol? (src-file src)) - (is-a? (src-file src) editor<%>)) - (format (string-constant test-engine-at-line-column) line col)] - [(path? (src-file src)) - (format (string-constant test-engine-in-at-line-column) - (path->string (src-file src)) - line col)]))))) + (format-position (car src) (cadr src) (caddr src))) + + (define (format-position file line column) + (let ([line (cond [line => number->string] + [else + (string-constant test-engine-unknown)])] + [col + (cond [column => number->string] + [else (string-constant test-engine-unknown)])]) + + (if (path? file) + (let-values (((base name must-be-dir?) + (split-path file))) + (if (path? name) + (format (string-constant test-engine-in-at-line-column) + (path->string name) line col) + (format (string-constant test-engine-at-line-column) + line col))) + (format (string-constant test-engine-at-line-column) + line col)))) + + (define (highlight-error line column position span src-editor) + (when (and current-rep src-editor) + (cond + [(is-a? src-editor text:basic<%>) + (let ((highlight + (lambda () + (send current-rep highlight-errors + (list (make-srcloc src-editor + line + column + position span)) #f)))) + (queue-callback highlight))]))) (define (highlight-check-error srcloc src-editor) (let* ([src-pos cadddr] [src-span (lambda (l) (car (cddddr l)))] [position (src-pos srcloc)] [span (src-span srcloc)]) - (when (and current-rep src-editor) - (cond - [(is-a? src-editor text:basic<%>) - (let ((highlight - (lambda () - (send current-rep highlight-errors - (list (make-srcloc src-editor - (cadr srcloc) - (caddr srcloc) - position span)) #f)))) - (queue-callback highlight))])))) + (highlight-error (cadr srcloc) (caddr srcloc) + position span + src-editor))) + + (define (highlight-error/syntax stx src-editor) + (highlight-error (syntax-line stx) (syntax-column stx) + (syntax-position stx) (syntax-span stx) + src-editor)) (super-instantiate ())))