diff --git a/collects/deinprogramm/DMdA.rkt b/collects/deinprogramm/DMdA.rkt index de333e253e..090bb03221 100644 --- a/collects/deinprogramm/DMdA.rkt +++ b/collects/deinprogramm/DMdA.rkt @@ -4,11 +4,11 @@ (require test-engine/scheme-tests (lib "test-info.scm" "test-engine") + test-engine/scheme-tests scheme/class) (require deinprogramm/contract/module-begin - deinprogramm/contract/contract - deinprogramm/contract/contract-test-engine + (except-in deinprogramm/contract/contract contract-violation) (except-in deinprogramm/contract/contract-syntax property)) (require (for-syntax scheme/base) diff --git a/collects/deinprogramm/contract/contract-test-display.rkt b/collects/deinprogramm/contract/contract-test-display.rkt deleted file mode 100644 index 906b4bccae..0000000000 --- a/collects/deinprogramm/contract/contract-test-display.rkt +++ /dev/null @@ -1,495 +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") - deinprogramm/contract/contract - deinprogramm/contract/contract-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 "Tatsächlicher Wert ~F ist keins der Elemente " - (formatter (not-mem-test fail))) - (for-each (lambda (a) (print " ~F" (formatter a))) (not-mem-set fail)) - (print ".")] - [(not-range? fail) - (print "Tatsächlicher Wert ~F liegt nicht zwischen ~F und ~F (inklusive)." - (formatter (not-range-test fail)) - (formatter (not-range-min fail)) - (formatter (not-range-max fail)))] - [(property-fail? fail) - (print-string "Eigenschaft falsifizierbar mit") - (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 "`check-property' bekam den folgenden Fehler~n:: ~a" - (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/contract/contract-test-engine.rkt b/collects/deinprogramm/contract/contract-test-engine.rkt deleted file mode 100644 index 55ef1a70df..0000000000 --- a/collects/deinprogramm/contract/contract-test-engine.rkt +++ /dev/null @@ -1,145 +0,0 @@ -#lang scheme/base - -(provide build-contract-test-engine - contract-violation? - contract-violation-obj contract-violation-contract contract-violation-message - contract-violation-blame contract-violation-srcloc - contract-got? contract-got-value contract-got-format - property-fail? property-fail-result - property-error? make-property-error property-error-message property-error-exn) - -(require scheme/class - (lib "test-engine/test-engine.scm") - (lib "test-engine/test-info.scm")) - -(define (build-contract-test-engine) - (let ((engine (make-object contract-test-engine%))) - (send engine setup-info 'check-require) - engine)) - -(define contract-test-engine% - (class* test-engine% () - (super-instantiate ()) - (inherit-field test-info test-display) - (inherit setup-info display-untested display-disabled) - - (define display-rep #f) - (define display-event-space #f) - - (field (tests null) - (test-objs null)) - - (define/override (info-class) contract-test-info%) - - ;; need display-rep & display-event-space - (define/augment (setup-display cur-rep event-space) - (set! display-rep cur-rep) - (set! display-event-space event-space) - (inner (void) setup-display cur-rep event-space)) - - (define/public (add-test tst) - (set! tests (cons tst tests))) - (define/public (get-info) - (unless test-info (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)) - - (define/private (clear-results event-space) - (when event-space - (parameterize ([(dynamic-require 'scheme/gui 'current-eventspace) event-space]) - ((dynamic-require 'scheme/gui 'queue-callback) - (lambda () (send test-display report-success)))))) - - (define/override (summarize-results port) - (cond - ((test-execute) - (unless test-display (setup-display #f #f)) - (send test-display install-info test-info) - (if (pair? (send test-info failed-contracts)) - (send this display-results display-rep display-event-space) - (let ((result (send test-info summarize-results))) - (case result - [(no-tests) - (clear-results display-event-space) - (display-untested port)] - [(all-passed) (display-success port display-event-space - (+ (send test-info tests-run) - (send test-info checks-run)))] - [(mixed-results) - (display-results display-rep display-event-space)])))) - (else - (display-disabled port)))) - - (define/private (display-success port event-space count) - (clear-results event-space) - (send test-display display-success-summary port count)) - - (define/override (display-results rep event-space) - (cond - [(and rep event-space) - (parameterize ([(dynamic-require 'scheme/gui 'current-eventspace) event-space]) - ((dynamic-require 'scheme/gui 'queue-callback) - (lambda () (send rep display-test-results test-display))))] - [event-space - (parameterize ([(dynamic-require 'scheme/gui 'current-eventspace) event-space]) - ((dynamic-require 'scheme/gui 'queue-callback) (lambda () (send test-display display-results))))] - [else (send test-display display-results)])) - -)) - -(define-struct contract-got (value format)) - -(define-struct contract-violation (obj contract message srcloc blame)) - -(define-struct (property-fail check-fail) (result)) -(define-struct (property-error check-fail) (message exn)) - -(define contract-test-info% - (class* test-info-base% () - - (define contract-violations '()) - - (define/pubment (contract-failed obj contract message blame) - - (let* ((cms - (continuation-mark-set->list (current-continuation-marks) - ;; set from deinprogramm-langs.ss - 'deinprogramm-teaching-languages-continuation-mark-key)) - (srcloc - (cond - ((findf (lambda (mark) - (and mark - (or (path? (car mark)) - (symbol? (car mark))))) - cms) - => (lambda (mark) - (apply (lambda (source line col pos span) - (make-srcloc source line col pos span)) - mark))) - (else #f))) - (message - (or message - (make-contract-got obj (test-format))))) - - (set! contract-violations - (cons (make-contract-violation obj contract message srcloc blame) - contract-violations))) - (inner (void) contract-failed obj contract message)) - - (define/public (failed-contracts) (reverse contract-violations)) - - (inherit add-check-failure) - (define/pubment (property-failed result src-info) - (add-check-failure (make-property-fail src-info (test-format) result) #f)) - - (define/pubment (property-error exn src-info) - (add-check-failure (make-property-error src-info (test-format) (exn-message exn) exn) exn)) - - (super-instantiate ()))) diff --git a/collects/deinprogramm/deinprogramm-langs.rkt b/collects/deinprogramm/deinprogramm-langs.rkt index 1c66b29227..84608754fe 100644 --- a/collects/deinprogramm/deinprogramm-langs.rkt +++ b/collects/deinprogramm/deinprogramm-langs.rkt @@ -24,13 +24,13 @@ lang/stepper-language-interface lang/debugger-language-interface lang/run-teaching-program + lang/private/continuation-mark-key stepper/private/shared (only-in test-engine/scheme-gui make-formatter) - (only-in test-engine/scheme-tests scheme-test-data error-handler test-format test-execute) + test-engine/scheme-tests + (lib "test-display.scm" "test-engine") deinprogramm/contract/contract - deinprogramm/contract/contract-test-engine - deinprogramm/contract/contract-test-display ) @@ -189,8 +189,8 @@ (namespace-attach-module drs-namespace scheme-contract-module-name) (namespace-require scheme-contract-module-name) - ;; DeinProgramm hack: the test-engine code knows about the test~object name; we do, too - (namespace-set-variable-value! 'test~object (build-contract-test-engine)) + ;; hack: the test-engine code knows about the test~object name; we do, too + (namespace-set-variable-value! 'test~object (build-test-engine)) ;; record test-case failures with the test engine (contract-violation-proc (lambda (obj contract message blame) @@ -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) @@ -1156,15 +1156,7 @@ ; ; ; - - - - - ;; cm-key : symbol - ;; the key used to put information on the continuation - ;; DeinProgramm change: contract-test-engine.ss knows about this - (define cm-key 'deinprogramm-teaching-languages-continuation-mark-key) - + (define mf-note (let ([bitmap (make-object bitmap% @@ -1194,7 +1186,7 @@ [(exn:srclocs? exn) ((exn:srclocs-accessor exn) exn)] [(exn? exn) - (let ([cms (continuation-mark-set->list (exn-continuation-marks exn) cm-key)]) + (let ([cms (continuation-mark-set->list (exn-continuation-marks exn) teaching-languages-continuation-mark-key)]) (cond ((not cms) '()) ((findf (lambda (mark) @@ -1218,7 +1210,7 @@ ;; with-mark : syntax syntax -> syntax ;; a member of stacktrace-imports^ - ;; guarantees that the continuation marks associated with cm-key are + ;; guarantees that the continuation marks associated with teaching-languages-continuation-mark-key are ;; members of the debug-source type (define (with-mark source-stx expr) (let ([source (syntax-source source-stx)] @@ -1231,8 +1223,8 @@ (number? span)) (with-syntax ([expr expr] [mark (list source line col start-position span)] - [cm-key cm-key]) - #`(with-continuation-mark 'cm-key + [teaching-languages-continuation-mark-key teaching-languages-continuation-mark-key]) + #`(with-continuation-mark 'teaching-languages-continuation-mark-key 'mark expr)) expr))) diff --git a/collects/lang/htdp-advanced.rkt b/collects/lang/htdp-advanced.rkt index 5cbcddf5a1..dfa6406199 100644 --- a/collects/lang/htdp-advanced.rkt +++ b/collects/lang/htdp-advanced.rkt @@ -2,7 +2,7 @@ (module htdp-advanced scheme/base (require "private/teach.ss" "private/teachprims.ss" - "private/contract-forms.ss" + "private/contracts/contracts-module-begin.ss" mzlib/etc mzlib/list mzlib/pretty @@ -49,8 +49,6 @@ [advanced-case case] [advanced-delay delay] [advanced-module-begin #%module-begin] - ;; [advanced-contract contract] - ;; [advanced-define-data define-data] ) check-expect check-within @@ -59,7 +57,11 @@ check-range #%datum #%top-interaction - empty true false) + empty true false + + contract : -> mixed one-of predicate combined + Number Real Rational Integer Natural Boolean True False String Char Empty-list + property) ;; procedures: (provide-and-document diff --git a/collects/lang/htdp-beginner-abbr.rkt b/collects/lang/htdp-beginner-abbr.rkt index 8cde4498d6..916f54a903 100644 --- a/collects/lang/htdp-beginner-abbr.rkt +++ b/collects/lang/htdp-beginner-abbr.rkt @@ -8,8 +8,8 @@ ;; Implements the forms: (require "private/teach.ss" - "private/contract-forms.ss" - "private/teachprims.ss") + "private/teachprims.ss" + "private/contracts/contracts-module-begin.ss") ;; syntax: (provide (rename-out @@ -29,8 +29,6 @@ [beginner-dots ....] [beginner-dots .....] [beginner-dots ......] - ;; [beginner-contract contract] - ;; [beginner-define-data define-data] [intermediate-quote quote] [intermediate-quasiquote quasiquote] [intermediate-unquote unquote] @@ -43,7 +41,11 @@ check-range #%datum #%top-interaction - empty true false) + empty true false + + contract : -> mixed one-of predicate combined + Number Real Rational Integer Natural Boolean True False String Char Empty-list + property) ;; procedures: (provide-and-document diff --git a/collects/lang/htdp-beginner.rkt b/collects/lang/htdp-beginner.rkt index c3bc2f9ad1..32280ade34 100644 --- a/collects/lang/htdp-beginner.rkt +++ b/collects/lang/htdp-beginner.rkt @@ -11,7 +11,7 @@ ;; Implements the forms: (require "private/teach.ss" - "private/contract-forms.ss" + "private/contracts/contracts-module-begin.ss" test-engine/scheme-tests) ;; syntax: @@ -34,8 +34,6 @@ [beginner-dots ....] [beginner-dots .....] [beginner-dots ......] - ;; [beginner-contract contract] - ;; [beginner-define-data define-data] ) check-expect check-within @@ -44,7 +42,11 @@ check-range #%datum #%top-interaction - empty true false) + empty true false + + contract : -> mixed one-of predicate combined + Number Real Rational Integer Natural Boolean True False String Char Empty-list + property) (require (for-syntax "private/firstorder.ss")) diff --git a/collects/lang/htdp-intermediate-lambda.rkt b/collects/lang/htdp-intermediate-lambda.rkt index 11f6930b95..284fbac2df 100644 --- a/collects/lang/htdp-intermediate-lambda.rkt +++ b/collects/lang/htdp-intermediate-lambda.rkt @@ -1,7 +1,7 @@ (module htdp-intermediate-lambda scheme/base (require "private/teach.ss" - "private/contract-forms.ss" + "private/contracts/contracts-module-begin.ss" mzlib/etc mzlib/list syntax/docprovide @@ -37,8 +37,6 @@ [intermediate-unquote-splicing unquote-splicing] [intermediate-time time] [intermediate-module-begin #%module-begin] - ;; [intermediate-contract contract] - ;; [intermediate-define-data define-data] ) check-expect check-within @@ -47,7 +45,11 @@ check-range #%datum #%top-interaction - empty true false) + empty true false + + contract : -> mixed one-of predicate combined + Number Real Rational Integer Natural Boolean True False String Char Empty-list + property) ;; procedures: (provide-and-document diff --git a/collects/lang/htdp-intermediate.rkt b/collects/lang/htdp-intermediate.rkt index 3dbd7a9eac..25bf3c48b4 100644 --- a/collects/lang/htdp-intermediate.rkt +++ b/collects/lang/htdp-intermediate.rkt @@ -2,7 +2,7 @@ (module htdp-intermediate scheme/base (require "private/teach.ss" "private/teachprims.ss" - "private/contract-forms.ss" + "private/contracts/contracts-module-begin.ss" mzlib/etc mzlib/list syntax/docprovide @@ -37,8 +37,6 @@ [intermediate-unquote-splicing unquote-splicing] [intermediate-time time] [intermediate-module-begin #%module-begin] - ;; [intermediate-contract contract] - ;; [intermediate-define-data define-data] ) check-expect check-within @@ -47,7 +45,11 @@ check-range #%datum #%top-interaction - empty true false) + empty true false + + contract : -> mixed one-of predicate combined + Number Real Rational Integer Natural Boolean True False String Char Empty-list + property) ;; procedures: (provide-and-document diff --git a/collects/lang/htdp-langs.rkt b/collects/lang/htdp-langs.rkt index 385d80c073..35df03fd5a 100644 --- a/collects/lang/htdp-langs.rkt +++ b/collects/lang/htdp-langs.rkt @@ -23,15 +23,19 @@ ;; this module is shared between the drscheme's namespace (so loaded here) ;; and the user's namespace in the teaching languages "private/set-result.ss" - + + "private/continuation-mark-key.rkt" + "stepper-language-interface.ss" "debugger-language-interface.ss" "run-teaching-program.ss" stepper/private/shared (only-in test-engine/scheme-gui make-formatter) - (only-in test-engine/scheme-tests scheme-test-data error-handler test-format test-execute) + (only-in test-engine/scheme-tests + scheme-test-data error-handler test-format test-execute build-test-engine) (lib "test-engine/test-display.scm") + deinprogramm/contract/contract ) @@ -131,7 +135,9 @@ [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-tests.ss") #f #f)]) + ((current-module-name-resolver) '(lib "test-engine/scheme-tests.ss") #f #f)] + [scheme-contract-module-name + ((current-module-name-resolver) '(lib "deinprogramm/contract/contract.ss") #f #f)]) (run-in-user-thread (lambda () (read-accept-quasiquote (get-accept-quasiquote?)) @@ -145,6 +151,18 @@ (read-accept-dot (get-read-accept-dot)) (namespace-attach-module drs-namespace scheme-test-module-name) (namespace-require scheme-test-module-name) + (namespace-attach-module drs-namespace scheme-contract-module-name) + (namespace-require scheme-contract-module-name) + ;; hack: the test-engine code knows about the test~object name; we do, too + (namespace-set-variable-value! 'test~object (build-test-engine)) + ;; record test-case failures with the test engine + (contract-violation-proc + (lambda (obj contract message blame) + (cond + ((namespace-variable-value 'test~object #f (lambda () #f)) + => (lambda (engine) + (send (send engine get-info) contract-failed + obj contract message blame)))))) (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 v settings o 40))))))) @@ -953,10 +971,6 @@ - ;; cm-key : symbol - ;; the key used to put information on the continuation - (define cm-key (gensym 'teaching-languages-continuation-mark-key)) - (define mf-note (let ([bitmap (make-object bitmap% @@ -973,7 +987,7 @@ (display (exn-message exn) (current-error-port)) (fprintf (current-error-port) "uncaught exception: ~e" exn)) (fprintf (current-error-port) "\n") - + ;; need to flush here so that error annotations inserted in next line ;; don't get erased if this output were to happen after the insertion (flush-output (current-error-port)) @@ -986,22 +1000,21 @@ [(exn:srclocs? exn) ((exn:srclocs-accessor exn) exn)] [(exn? exn) - (let ([cms (continuation-mark-set->list (exn-continuation-marks exn) cm-key)]) - (if cms - (let loop ([cms cms]) - (cond - [(null? cms) '()] - [else (let* ([cms (car cms)] - [source (car cms)] - [pos (cadr cms)] - [span (cddr cms)]) - (if (or (path? source) - (symbol? source)) - (list (make-srcloc source #f #f pos span)) - (loop (cdr cms))))])) - '()))] - [else '()])]) - + (let ([cms (continuation-mark-set->list (exn-continuation-marks exn) teaching-languages-continuation-mark-key)]) + (cond + ((not cms) '()) + ((findf (lambda (mark) + (and mark + (or (path? (car mark)) + (symbol? (car mark))))) + cms) + => (lambda (mark) + (apply (lambda (source line col pos span) + (list (make-srcloc source line col pos span))) + mark))) + (else '())))] + [else '()])]) + (parameterize ([current-eventspace drs-eventspace]) (queue-callback (lambda () @@ -1011,19 +1024,21 @@ ;; with-mark : syntax syntax -> syntax ;; a member of stacktrace-imports^ - ;; guarantees that the continuation marks associated with cm-key are + ;; guarantees that the continuation marks associated with teaching-languages-continuation-mark-key are ;; members of the debug-source type (define (with-mark source-stx expr) (let ([source (syntax-source source-stx)] + [line (syntax-line source-stx)] + [col (syntax-column source-stx)] [start-position (syntax-position source-stx)] [span (syntax-span source-stx)]) (if (and (or (symbol? source) (path? source)) (number? start-position) (number? span)) (with-syntax ([expr expr] - [mark (list* source start-position span)] - [cm-key cm-key]) - #`(with-continuation-mark 'cm-key + [mark (list source line col start-position span)] + [teaching-languages-continuation-mark-key teaching-languages-continuation-mark-key]) + #`(with-continuation-mark 'teaching-languages-continuation-mark-key 'mark expr)) expr))) diff --git a/collects/lang/private/continuation-mark-key.rkt b/collects/lang/private/continuation-mark-key.rkt new file mode 100644 index 0000000000..4646862d79 --- /dev/null +++ b/collects/lang/private/continuation-mark-key.rkt @@ -0,0 +1,9 @@ +#lang scheme/base + +(provide teaching-languages-continuation-mark-key) + +; The test code also needs access to this. + +;; cm-key : symbol +;; the key used to put information on the continuation +(define teaching-languages-continuation-mark-key (gensym 'teaching-languages-continuation-mark-key)) diff --git a/collects/lang/private/contract-forms.rkt b/collects/lang/private/contract-forms.rkt deleted file mode 100644 index e2a456847e..0000000000 --- a/collects/lang/private/contract-forms.rkt +++ /dev/null @@ -1,17 +0,0 @@ -(module contract-forms mzscheme - - (require "contracts/contracts-module-begin.ss" - "contracts/contracts.ss" - "contracts/define-data.ss") - - (provide beginner-contract - beginner-define-data - beginner-module-begin - - intermediate-contract - intermediate-define-data - intermediate-module-begin - - advanced-contract - advanced-define-data - advanced-module-begin)) diff --git a/collects/lang/private/contracts/advanced-contracts.rkt b/collects/lang/private/contracts/advanced-contracts.rkt deleted file mode 100644 index bf563df619..0000000000 --- a/collects/lang/private/contracts/advanced-contracts.rkt +++ /dev/null @@ -1,7 +0,0 @@ -(module advanced-contracts mzscheme - (require "contracts-helpers.ss") - (require mzlib/list) - - (provide void-contract) - - (define void-contract (lambda (stx) (build-flat-contract void? 'void stx)))) diff --git a/collects/lang/private/contracts/beginner-contracts.rkt b/collects/lang/private/contracts/beginner-contracts.rkt deleted file mode 100644 index 2daf383e67..0000000000 --- a/collects/lang/private/contracts/beginner-contracts.rkt +++ /dev/null @@ -1,26 +0,0 @@ -(module beginner-contracts mzscheme - - (require "contracts-helpers.ss" - lang/posn - lang/private/teach - mzlib/list) - - (provide (all-defined)) - - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; flat type contracts for beginner language - - (define any-contract (lambda (stx) (build-flat-contract (lambda (x) #t) 'any stx))) - (define symbol-contract (lambda (stx) (build-flat-contract symbol? 'symbol stx))) - (define number-contract (lambda (stx) (build-flat-contract number? 'number stx))) - (define integer-contract (lambda (stx) (build-flat-contract integer? 'integer stx))) - (define exact-number-contract (lambda (stx) (build-flat-contract exact? 'exact-number stx))) - (define inexact-number-contract (lambda (stx) (build-flat-contract inexact? 'inexact-number stx))) - (define boolean-contract (lambda (stx) (build-flat-contract boolean? 'boolean stx))) - (define true-contract (lambda (stx) (build-flat-contract (lambda (x) (eq? x #t)) 'true stx))) - (define false-contract (lambda (stx) (build-flat-contract (lambda (x) (eq? x #f)) 'false stx))) - (define string-contract (lambda (stx) (build-flat-contract string? 'string stx))) - (define posn-contract (lambda (stx) (build-flat-contract posn? 'posn stx))) - (define empty-contract (lambda (stx) (build-flat-contract null? 'empty stx))) - (define list-contract (lambda (stx) (build-flat-contract pair? 'list stx)))) diff --git a/collects/lang/private/contracts/contract-transformers.rkt b/collects/lang/private/contracts/contract-transformers.rkt deleted file mode 100644 index fb852ae305..0000000000 --- a/collects/lang/private/contracts/contract-transformers.rkt +++ /dev/null @@ -1,202 +0,0 @@ -(module contract-transformers mzscheme - (require-for-template mzscheme - "contracts-helpers.ss" - "beginner-contracts.ss" - "intermediate-contracts.ss" - "advanced-contracts.ss") - - (provide (all-defined)) - - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; COMMON STUFF- Translators - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - ;; We really should compare with module-identifier=", - ;; but importing the right identifiers here is a pain. - ;; As it happens, the teaching languages disable shadowing, - ;; so we can safely use symbol equality. - (define (contract-id=? a b) - (eq? (syntax-e a) (syntax-e b))) - - ;; a translator is a function that translates syntax for contracts - ;; (like: number, (number -> string), (number -> (number -> boolean)) ) - ;; and converts it into the necesary function calls to enforce those contracts - - ;; translate-arrow-contract : syntax (syntax -> syntax) -> syntax - ;; parses contracts for (domain ... -> range) type contracts - ;; the first argument is the syntax object to parse - ;; the second argument is translator that should be used for recursive calls - (define translate-arrow-contract - (lambda (stx translator) - (syntax-case stx (->) - [(domain ... -> range) - (with-syntax - ([(parsed-domain ...) (map translator (syntax-e (syntax (domain ...))))] - [parsed-range (translator (syntax range))] - [ret stx]) - (syntax (->-contract (list parsed-domain ...) parsed-range #'ret)))] - [else-stx (raise-syntax-error 'contracts "unknown contract" (syntax else-stx))]))) - - ;; beginners cant use higher order contracts, so only allow func contracts in the top level - (define beginner-translate-contract - (case-lambda - [(stx) (beginner-translate-contract stx beginner-translate-flat-contract)] - [(stx recur) - (syntax-case stx (->) - [(domain ... -> range) (translate-arrow-contract stx recur)] - [_else-stx (beginner-translate-flat-contract stx recur)])])) - - - ;; syntax definitions for beginner language contracts (from beginner-contracts.scm) - (define beginner-translate-flat-contract - (case-lambda - [(stx) (beginner-translate-flat-contract stx beginner-translate-flat-contract)] - [(stx recur) - - (syntax-case* stx (-> add1 quote cons number any integer - exact-number inexact-number posn boolean - true false - string empty symbol list) - contract-id=? - [(cons a b) (with-syntax ([car-contract (recur (syntax a))] - [cdr-contract (recur (syntax b))] - [ret stx]) - (syntax/loc stx (cons-contract car-contract cdr-contract #'ret)))] - [(list a ...) (with-syntax ([(translated ...) (map recur (syntax-e (syntax/loc stx (a ...))))] - [ret stx]) - (syntax/loc stx (args-contract (list translated ...) #'ret)))] - [(add1 a) (with-syntax ([translated (recur (syntax/loc stx a))] - [ret stx]) - (syntax/loc stx (add1-contract translated #'ret)))] - [empty (with-syntax ([ret stx]) - (syntax/loc stx (empty-contract #'ret)))] - [(quote n) (with-syntax ([ret stx]) - (syntax/loc stx (build-flat-contract (lambda (x) (eq? x 'n)) 'n #'ret)))] - [number (with-syntax ([ret stx]) - (syntax/loc stx (number-contract #'ret)))] - [any (with-syntax ([ret stx]) - (syntax/loc stx (any-contract #'ret)))] - [symbol (with-syntax ([ret stx]) - (syntax/loc stx (symbol-contract #'ret)))] - [integer (with-syntax ([ret stx]) - (syntax/loc stx (integer-contract #'ret)))] - [exact-number (with-syntax ([ret stx]) - (syntax/loc stx (exact-number-contract #'ret)))] - [inexact-number (with-syntax ([ret stx]) - (syntax/loc stx (inexact-number-contract #'ret)))] - [boolean (with-syntax ([ret stx]) - (syntax/loc stx (boolean-contract #'ret)))] - [true (with-syntax ([ret stx]) - (syntax/loc stx (true-contract #'ret)))] - [false (with-syntax ([ret stx]) - (syntax/loc stx (false-contract #'ret)))] - [string(with-syntax ([ret stx]) - (syntax/loc stx (string-contract #'ret)))] - [posn (with-syntax ([ret stx]) - (syntax/loc stx (posn-contract #'ret)))] - [(domain ... -> range) - (raise-syntax-error 'contracts "functions in the beginner language can't take other functions as input" stx)] - [(make-struct e1 e2 ...) - (pair? (regexp-match "make-(.*)" (symbol->string (syntax-object->datum (syntax make-struct))))) - (let ([make (regexp-match "make-(.*)" (symbol->string (syntax-object->datum (syntax make-struct))))]) - (let ([struct (datum->syntax-object stx (string->symbol (cadr make)))]) - (if (define-struct? struct) - (with-syntax ([pred (get-predicate-from-struct struct)] - [(accessors ...) (reverse (get-accessors-from-struct struct))] - [name (syntax-object->datum struct)] - [(translated ...) (map recur (syntax-e (syntax (e1 e2 ...))))] - [ret stx]) ; we wrap with lambdas so that beginner doesnt complain about using them without a ( - (syntax/loc stx (struct-contract 'name (lambda (x) (pred x)) (list (lambda (x) (accessors x)) ...) (list translated ...) #'ret))) - (raise-syntax-error 'contracts (format "unknown structure type: ~e" - (syntax-object->datum struct)) stx))))] - - [-> (raise-syntax-error 'contracts "found a lone '->', check your parentheses!" stx)] - - [name - (number? (syntax-object->datum (syntax name))) - (with-syntax ([num (syntax-object->datum (syntax name))] - [ret stx]) - (syntax/loc stx (build-flat-contract (lambda (x) (eq? num x)) num #'ret)))] - - [name - (define-data? (syntax name)) ; things from a define data - (with-syntax ([cnt (get-cnt-from-dd (syntax name))]) - (syntax/loc stx cnt))] - - [name - (define-struct? (syntax name)) ; generic structs - (with-syntax ([pred (get-predicate-from-struct (syntax name))] - [type-name (get-name-from-struct (syntax name))] - [ret stx]) - (syntax/loc stx (build-flat-contract (lambda (x) (pred x)) 'type-name #'ret)))] - - [name (raise-syntax-error 'contracts "unknown contract" (syntax name))])])) - - ;; stx definitions for intermediate language contracts (intermediate-contracts.scm) - (define intermediate-translate-contract - (case-lambda - [(stx) (intermediate-translate-contract stx intermediate-translate-contract)] - [(stx recur) - (syntax-case* stx (-> listof quote vectorof boxof) - contract-id=? - [(listof type) (with-syntax ([ret stx] - [trans-type (recur (syntax type))]) - (syntax/loc stx (listof-contract trans-type #'ret)))] - [(vectorof type) (with-syntax ([ret stx] - [trans-type (recur (syntax type))]) - (syntax/loc stx (vectorof-contract trans-type #'ret)))] - [(boxof type) (with-syntax ([ret stx] - [trans-type (recur (syntax type))]) - (syntax/loc stx (boxof-contract trans-type #'ret)))] - [(quote n) (with-syntax ([ret stx]) - (syntax/loc stx (build-flat-contract (lambda (x) (eq? x 'n)) 'n #'ret)))] - [(domain ... -> range) (translate-arrow-contract stx intermediate-translate-contract)] - [else-stx (beginner-translate-contract (syntax else-stx) intermediate-translate-contract)])])) - - ;; stx definitions for advanced language contracts (advanced-contracts.scm) - (define advanced-translate-contract - (case-lambda - [(stx) (advanced-translate-contract stx advanced-translate-contract)] - [(stx recur) - (syntax-case* stx (-> void) contract-id=? - [void (with-syntax ([ret stx]) - (syntax/loc stx (void-contract #'ret)))] - [(domain ... -> range) (translate-arrow-contract stx advanced-translate-contract)] - [else-stx (intermediate-translate-contract (syntax else-stx))])])) - - ;; helper functions for these - - ;;get-predicate-from-struct : stx -> stx - ;;returns the predicate for the given stx, which needs to be an object defined via define-struct/define-data - (define (get-predicate-from-struct stx) - (caddr (syntax-local-value stx))) - - ;;get-cnt-from-dd : stx -> stx - ;;returns the syntax contract that corresponds to the current define-data object - (define (get-cnt-from-dd stx) - (if (define-data? stx) - (caddr (syntax-local-value stx)))) - - ;;get-name-from-struct : stx -> stx - ;;returns the name for the given stx, which needs to be an object defined via define-struct/define-data - (define (get-name-from-struct stx) - (car (syntax-local-value stx))) - - ;;get-accessors-from-struct : stx -> list of stx - ;;returns the name for the given stx, which needs to be an object defined via define-struct/define-data - (define (get-accessors-from-struct stx) - (cadddr (syntax-local-value stx))) - - ;;define-struct? : stx -> boolean - ; was this thing defined in a define-struct? - (define (define-struct? stx) - (and (identifier? stx) (pair? (syntax-local-value stx (lambda () #f))))) - - ;;define-data? : stx -> boolean - ; was this thing defined in a define-data? - (define (define-data? stx) - (and (identifier? stx) - (let ([data (syntax-local-value stx (lambda () #f))]) - (and data (pair? data) (eq? (cadr data) 'define-data))))) - - ) diff --git a/collects/lang/private/contracts/contracts-helpers.rkt b/collects/lang/private/contracts/contracts-helpers.rkt deleted file mode 100644 index ac15211eca..0000000000 --- a/collects/lang/private/contracts/contracts-helpers.rkt +++ /dev/null @@ -1,427 +0,0 @@ -(module contracts-helpers mzscheme - - (require "hilighters.ss") - (require mzlib/etc) - - (provide (all-defined)) - - #| -contract : - enforcer: function (x -> x) that enforces the contract - hilighter: a function that given a path to a contract violation, - returns the content of the contract with the expression - denoted by the path hilighted. - source,line,column,pos,span: source location data for where the contract was defined - correspond to same fields in defining syntax object -|# - (define-struct contract (enforcer hilighter source line column position span)) - - #| -flat-contract : contract - predicate: a predicate that can be used to verify this contract. -|# - (define-struct (flat-contract contract) (predicate)) - - ; build-flat-contract: short cut for making flat-contracts - ; (any -> bool) symbol syntax -> flat-contract - ; returns contract that enforces given predicate - (define build-flat-contract - (lambda (predicate name stx) - (letrec ([me (make-flat-contract - - (lambda (x) - (if (predicate x) - x - (contract-error x me '()))) - - (mk-flat-hilighter name) - - (syntax-source stx) - (syntax-line stx) - (syntax-column stx) - (syntax-position stx) - (syntax-span stx) - - predicate)]) - me))) - - ;; ->-contract: list-of-contracts contract syntax -> contract - ;; translates domain and range contracts into a single contract - ;; that represents the contract of a function that takes in values that - ;; satisfy domain contract and returns values that satisfies range contract - ;; the domain contract is defined by the list, - (define ->-contract - (lambda (domain-contracts-list range-contract stx) - (letrec ([me (make-contract - (lambda (f) - (cond [(not (procedure? f)) - (error 'contracts (format "~e is not a function" f))] - [(procedure-arity-includes? f (length domain-contracts-list)) - (apply-contract f domain-contracts-list range-contract me stx)] - [else - (parameterize ([print-struct true]) - (error 'contracts (format "~e expects ~e arguments, not ~e" - f - (procedure-arity f) - (length domain-contracts-list))))])) - - (let ([dom-hilighter-list (map (lambda (x) (contract-hilighter x)) domain-contracts-list)]) - (mk-arrow-hilighter dom-hilighter-list (contract-hilighter range-contract))) - - (syntax-source stx) - (syntax-line stx) - (syntax-column stx) - (syntax-position stx) - (syntax-span stx))]) - - me))) - - ;; args-contract: (contract ...) stx -> contract - ;; takes in a list of contracts, and returns a contract that checks for a - ;; list (a b c ...) where each member satisfies the corresponding contract in the input - ;; useful for function arguments - (define (args-contract cnt-list stx) - (letrec ([me (make-flat-contract - (lambda (values) - (if (pair? values) - (verify-contracts me cnt-list values) - (contract-error values me '()))) - (mk-list-hilighter (map (lambda (c) (contract-hilighter c)) cnt-list)) - (syntax-source stx) - (syntax-line stx) - (syntax-column stx) - (syntax-position stx) - (syntax-span stx) - - (lambda (values) - (if (not (andmap flat-contract? cnt-list)) - (error 'args-contract - "not all subcontracts of ~e are flat contracts, so predicate is undefined" - ((contract-hilighter me) #f)) - (and (list? values) - (andmap (lambda (c x) ((flat-contract-predicate c) x)) cnt-list values)))))]) - me)) - - - ;; apply-contract: (any ... -> any) list of contracts contract -> (any ... -> any) - ;; returns a function that identical to the given one, except that it enforces contracts - ;; since functions can take in multiple values, the full domain contract is given as a list of - ;; contracts. - (define (apply-contract function domain-contracts-list range-contract func-cnt stx) - (let ([dom-list-contract (args-contract domain-contracts-list stx)] - [range-composer - (lambda (values) - (lambda (error) - (let ([name (object-name function)]) - (if (regexp-match #rx"[0-9]+:[0-9]+" (symbol->string name)) - ; cant infer a good name (higher order things) - (format "function defined on line ~e (called with: ~a) failed the assertion ~s" - name - (format-list-with-spaces values) - error) - ; have func name - (format "function ~e (called with: ~a) failed the assertion ~s" - name - (format-list-with-spaces values) - error)))))] - [domain-composer - (lambda (values) - (lambda (error) - (let ([name (object-name function)]) - (if (regexp-match #rx"[0-9]+:[0-9]+" (symbol->string name)) - (format "the arguments to the function defined on line ~e (~e) failed the assertion ~s" - name values error) - (format "function ~e's arguments ~a failed the assertion ~s" - name - (format-list-with-spaces values) - error)))))]) - - (lambda values - (let* ([checked-values (catch-contract-error (domain-composer values) - 'car - func-cnt - ((contract-enforcer dom-list-contract) values))] - [return-value (apply function checked-values)] - [range-enforcer (contract-enforcer range-contract)]) - (catch-contract-error (range-composer values) 'cdr func-cnt (range-enforcer return-value)))))) - - ;; format-list-with-spaces : (listof any) -> string - (define (format-list-with-spaces args) - (cond - [(null? args) ""] - [else - (apply - string-append - (let loop ([fst (car args)] - [rst (cdr args)]) - (cond - [(null? rst) (list (format "~e" fst))] - [else (cons (format "~e " fst) - (loop (car rst) - (cdr rst)))])))])) - - - ; verify-contracts: contract contracts values - ; contracts and values are two lists of equal length - ; uses the hilighter from the first argument. enforcer for args-contract - (define (verify-contracts cnt cnt-list values) - (if (not (eq? (length cnt-list) (length values))) - (error 'verify-contracts - (format "~e and ~e dont have same length (~e and ~e)" - cnt-list - values - (length cnt-list) - (length values)))) - (let loop ([path-to-add (cons 'car '())] - [curr-cnt cnt-list] - [curr-val values] - [ret-val '()]) - - (if (or (null? curr-val) (null? curr-cnt)) - (reverse ret-val) - - (let ([curr-ret (catch-contract-error path-to-add - cnt - ((contract-enforcer (car curr-cnt)) (car curr-val)))]) - (loop (cons 'cdr path-to-add) - (cdr curr-cnt) - (cdr curr-val) - (cons curr-ret ret-val)))))) - - ; cons-contract: contract contract -> contract - ; given two contracts, returns a contract that accepts lists where the car satisfies the first - ; and the cdr satisfies the second - (define (cons-contract car-contract cdr-contract stx) - (if (not (and (flat-contract? car-contract) (flat-contract? cdr-contract))) - (error 'contracts "(cons ) type contracts can only take flat contracts") - (letrec ([cons-hilighter (mk-cons-hilighter (contract-hilighter car-contract) (contract-hilighter cdr-contract))] - [me (make-flat-contract - (lambda (l) - - (if (pair? l) - (let ([composer (lambda (h) (format "~s didnt satisfy the contract ~s" l h))]) - (catch-contract-error composer 'car me ((contract-enforcer car-contract) (car l))) - (catch-contract-error composer 'cdr me ((contract-enforcer cdr-contract) (cdr l))) - l) - (contract-error l me '()))) - - cons-hilighter - - (syntax-source stx) - (syntax-line stx) - (syntax-column stx) - (syntax-position stx) - (syntax-span stx) - - (lambda (l) (and (pair? l) ((flat-contract-predicate car-contract) (car l)) - ((flat-contract-predicate cdr-contract) (cdr l)))))]) - me))) - - - ;; add1-contract: flat-contract syntax -> flat-contract - ;; implements checker for (add1 ) style contracts - (define (add1-contract cnt stx) - (if (flat-contract? cnt) - (letrec ([me (make-flat-contract - - (lambda (x) - (if (and (number? x) (>= x 0)) - (catch-contract-error 'car me ((contract-enforcer cnt) (- x 1))) - (contract-error x me '()))) - - (mk-add1-hilighter (contract-hilighter cnt)) - - (syntax-source stx) - (syntax-line stx) - (syntax-column stx) - (syntax-position stx) - (syntax-span stx) - - (lambda (x) (and (number? x) (>= x 0) ((flat-contract-predicate cnt) (- x 1)))))]) - me) - (error 'contracts "add1 can only be used with flat contracts"))) - - ; struct contract: symbol (any -> boolean) (struct -> any) flat-contracts -> flat-contract - ; returns a contract that enforces the contract (make- cnt cnt cnt ...) - (define (struct-contract name predicate accessors field-contracts stx) - (letrec ([hilighter (mk-struct-hilighter name (map contract-hilighter field-contracts))] - [not-struct-composer - (lambda (value) - (lambda (error) - (format "~e is not a structure of type ~e, so didnt satisfy contract ~e" value name error)))] - [me (make-flat-contract - (lambda (x) (if (predicate x) - (let ([field-values (map (lambda (accessor) (accessor x)) accessors)] - [field-composer (lambda (error) - (format "the fields of structure ~e did not satisfy the assertion ~e" - x error))]) - (catch-contract-error field-composer #f me - (verify-contracts me field-contracts field-values))) - (contract-error x me '() #f (not-struct-composer x)))) - hilighter - (syntax-source stx) - (syntax-line stx) - (syntax-column stx) - (syntax-position stx) - (syntax-span stx) - (lambda (x) - (and (predicate x) - (andmap - (lambda (a b) - (and (flat-contract? b) - ((flat-contract-predicate b) (a x)))) - accessors field-contracts))))]) - me)) - - ; define-data-enforcer: contract any listof contracts -> any - (define (define-data-enforcer me value list-of-cnts) - (if ((flat-contract-predicate me) value) - value - (define-data-error me value list-of-cnts))) - - ;; define-data-error: define-data-contract any list-of-flat-contracts -> void - ;; raises the contract exception with a good error message - (define (define-data-error me value list-of-cnts) - (let loop ([contract-list list-of-cnts] - [max-depth 0] - [best-cnt #f]) - - (if (null? contract-list) - (if (or (eq? max-depth 0) (not best-cnt)) ; all contracts failed at top level, so just give standard report - (contract-error value me '()) - (define-data-report me value best-cnt))) ; there was a contract that failed deeper than others, - - ; give this as the failed part - (let ([current-depth (get-error-depth (car contract-list) value)]) - (if (> current-depth max-depth) - (loop (cdr contract-list) - current-depth - (car contract-list)) - - (loop (cdr contract-list) - max-depth - best-cnt))))) - - ;; get-error-depth: flat-contract any -> number - ;; returns how 'deep' the contract checker had to go to find a violation - ;; used as a guess as to which contract was the best match for a define-data - (define (get-error-depth cnt value) - (with-handlers ([exn:contract-violation? - (lambda (e) - (length (exn:contract-violation-trace e)))]) - ((contract-enforcer cnt) value) - (error 'define-data - (format "major internal error: ~e didnt fail ~e, but define-data-error said it did." - value - ((contract-hilighter cnt) #f))))) - - - ;; define-data-report: define-data-contract any flat-contract -> void - ;; generates the correct error report for a define data. - ;; the first argument is the define-data contract being checked, - ;; the second is the value being checked - ;; and the third is the contract (one of the flats that was used in the - ;; define-data) that will be reported as the best failure match - (define (define-data-report me value best-cnt) - (with-handlers ([exn:contract-violation? - (lambda (e) - (raise - (make-exn:contract-violation - (format "contract violation: ~e is not a ~e [failed part: ~e]" - value - ((contract-hilighter me) '()) - ((contract-hilighter best-cnt) (exn:contract-violation-path e))) - (current-continuation-marks) - value - '() - me - (exn:contract-violation-trace e))))]) - - ((contract-enforcer best-cnt) value)) - - (error 'define-data - (format "major internal error: ~e didnt fail ~e, but define-data-error said it did." - value - ((contract-hilighter best-cnt) #f)))) - - ;;;;;;;;;;;;;;;;;; ERROR HANDLING - - ; exn:contract-violation - ; exception used for contract violations. - ; full fields: - ; - message - ; - continuation-marks - ; - value - ; - path: a list of 'car 'cdr that describes which component of the contract failed - ; - failed-cnt: the contract that failed - ; - trace: a list of exn:contract-violation that describe the whole path of contract exceptions thrown - (define-struct (exn:contract-violation exn) (value path failed-cnt trace)) - - ; contract-error-display-handler: outputs of the information from a contract exception - (define contract-error-display-handler - (lambda (msg e) - (if (exn:contract-violation? e) - - (let ([failed (exn:contract-violation-failed-cnt e)]) - (begin - (printf "~s (source: ~e, line: ~e, col: ~e, pos: ~e, span: ~e)\n" - (exn-message e) - (contract-source failed) - (contract-line failed) - (contract-column failed) - (contract-position failed) - (contract-span failed)) - - (printf "current path: ~e\n" (exn:contract-violation-path e))) - - (unless (null? (exn:contract-violation-trace e)) - (printf "trace:\n") - (map (lambda (x) - (printf "\t~s ~s\n" (exn-message x) (exn:contract-violation-path x))) - (exn:contract-violation-trace e))))) - - (display msg))) - - ; contract-error : value failed-contract path [exn:contract-violation message-composer] -> void - ; produces a nice error message. - ; if exn-to-pass is given, its tacked on in the front of the new exception's trace. if not given, trace is emptied - ; a message composer is a function that takes in an S-Expression that represents the failed contract - ; and returns a string that will be used as the error message - (define contract-error - (opt-lambda (value cnt path [exn-to-pass #f] [message-composer #f]) - (let ([cnt-hilighted ((contract-hilighter cnt) path)]) - (raise (make-exn:contract-violation - (if message-composer - (format "contract violation: ~a" (message-composer cnt-hilighted)) - (format "contract violation: ~e didnt satisfy the contract ~e" value cnt-hilighted)) - (current-continuation-marks) - value - path - cnt - (if (and (boolean? exn-to-pass) (not exn-to-pass)) - '() - (cons exn-to-pass (exn:contract-violation-trace exn-to-pass)))))))) - - - ; shorthand for catching a contract-violation and passing up a new exception with modified paths and hilighters - ; (catch-contract-error ('car|'cdr) hilighter expr1 expr2 ...) - (define-syntax catch-contract-error - (lambda (stx) - (syntax-case stx () - [(_ path-to-add cnt e1) - (syntax - (catch-contract-error #f path-to-add cnt e1))] - - ;; this version takes a message-composer, as in contract-error - [(_ message-composer path-to-add cnt e1) - (syntax - (with-handlers - ([exn:contract-violation? - (lambda (e) - (let ([val (exn:contract-violation-value e)] - [new-path (cond - [(not path-to-add) (exn:contract-violation-path e)] - [(pair? path-to-add) (append path-to-add (exn:contract-violation-path e))] - [else (cons path-to-add (exn:contract-violation-path e))])]) - (contract-error val cnt new-path e message-composer)))]) - e1))])))) diff --git a/collects/lang/private/contracts/contracts-module-begin.rkt b/collects/lang/private/contracts/contracts-module-begin.rkt index 02821d6c1f..1e8c764cab 100644 --- a/collects/lang/private/contracts/contracts-module-begin.rkt +++ b/collects/lang/private/contracts/contracts-module-begin.rkt @@ -1,286 +1,194 @@ -(module contracts-module-begin mzscheme +#lang scheme/base + +; Once upon a time, there were three different variants. Preserve the +; ability to do this. +(provide (rename-out (module-begin beginner-module-begin) + (module-begin intermediate-module-begin) + (module-begin advanced-module-begin))) + +(require lang/private/contracts/contract-syntax) + +(require (for-syntax scheme/base) + (for-syntax mzlib/list) + (for-syntax syntax/boundmap) + (for-syntax syntax/kerncase)) + +(define-syntax (print-results stx) + (syntax-case stx () + ((_ expr) + (not (or (syntax-property #'expr 'stepper-hide-completed) + (syntax-property #'expr 'stepper-skip-completely) + (syntax-property #'expr 'test-call))) + (syntax-property + (syntax-property + #'(#%app call-with-values (lambda () expr) + do-print-results) + 'stepper-skipto + '(syntax-e cdr cdr car syntax-e cdr cdr car)) + 'certify-mode + 'transparent)) + ((_ expr) #'expr))) + +(define (do-print-results . vs) + (for-each (current-print) vs) + ;; Returning 0 values avoids any further result printing + ;; (even if void values are printed) + (values)) - (require "contracts.ss") - - (require-for-syntax mzlib/list - syntax/boundmap - syntax/kerncase) - - (provide beginner-module-begin intermediate-module-begin advanced-module-begin) +(define-syntaxes (module-begin module-continue) + (let () + ;; takes a list of syntax objects (the result of syntax-e) and returns all the syntax objects that correspond to + ;; a contract declaration. Syntax: (: id contract) + (define extract-contracts + (lambda (lostx) + (let* ((table (make-bound-identifier-mapping)) + (non-contracts + (filter (lambda (maybe) + (syntax-case maybe (:) + ((: ?id ?cnt) + (identifier? #'id) + (begin + (when (bound-identifier-mapping-get table #'?id (lambda () #f)) + (raise-syntax-error #f + "Second contract declaraton for the same name." + maybe)) + (bound-identifier-mapping-put! table #'?id #'?cnt) + #f)) + ((: ?id) + (raise-syntax-error 'contracts "Contract declaration is missing a contract." maybe)) + ((: ?id ?cnt ?stuff0 ?stuff1 ...) + (raise-syntax-error 'contracts "The : form expects a name and a contract; there is more." + (syntax/loc #'?stuff0 + (?stuff0 ?stuff1 ...)))) + (_ #t))) + lostx))) + (values table non-contracts)))) - (define-syntax (print-results stx) - (syntax-case stx () - [(_ expr) - (not (or (syntax-property #'expr 'stepper-hide-completed) - (syntax-property #'expr 'stepper-skip-completely) - (syntax-property #'expr 'test-call))) - (syntax-property - (syntax-property - #'(#%app call-with-values (lambda () expr) - do-print-results) - 'stepper-skipto - '(syntax-e cdr cdr car syntax-e cdr cdr car)) - 'certify-mode - 'transparent)] - [(_ expr) #'expr])) + (define local-expand-stop-list + (append (list #': #'define-contract + #'#%require #'#%provide) + (kernel-form-identifier-list))) + + (define (expand-contract-expressions contract-table expressions) - (define (do-print-results . vs) - (for-each (current-print) vs) - ;; Returning 0 values avoids any further result printing - ;; (even if void values are printed) - (values)) - - (define-syntaxes (beginner-module-begin intermediate-module-begin advanced-module-begin - beginner-continue intermediate-continue advanced-continue) - (let () - (define (parse-contracts language-level-contract language-level-define-data - module-begin-continue-id) - ;; takes a list of syntax objects (the result of syntax-e) and returns all the syntax objects that correspond to - ;; a contract declaration. Syntax: (contract function-name (domain ... -> range)) - (define extract-contracts - (lambda (lostx) - (filter contract-stx? lostx))) - - ;; negate previous - (define extract-not-contracts - (lambda (stx-list) - (filter (lambda (x) (not (contract-stx? x))) stx-list))) - - ;; predicate: is this syntax object a contract expr? - (define contract-stx? - (lambda (stx) - (syntax-case stx () - [(contract function cnt) - (and (identifier? #'contract) - (module-identifier=? #'contract language-level-contract))] - [_ #f]))) - - ;; pred: is this syntax obj a define-data? - (define define-data-stx? - (lambda (stx) - (syntax-case stx () - [(define-data name e1 e2 ...) - (and (identifier? #'define-data) - (module-identifier=? #'define-data language-level-define-data))] - [_ #f]))) - - ;; takes a list of contract stx and a definitions stx and tells you if there is a contract defined for this function - (define contract-defined? - (lambda (cnt-list item) - (cond - [(null? cnt-list) #f] - [(fn=? (get-function-from-contract (car cnt-list)) (get-function-from-def item)) #t] - [else (contract-defined? (cdr cnt-list) item)]))) - - ;; returns the name of the function in a given contract-syntax - (define get-function-from-contract - (lambda (stx) - (if (contract-stx? stx) - (syntax-case stx () - [(contract function cnt ...) (syntax function)] - [_ (raise-syntax-error 'contract "internal error.1")]) - (raise-syntax-error 'contract "this is not a valid contract" stx)))) - - ;; used to match up contract definitions with function definitions - ; should just be bound-identifier=?, but since beginner does some funny things - ; with hygiene, we have to do this - (define (fn=? a b) - (string=? (symbol->string (syntax-object->datum a)) - (symbol->string (syntax-object->datum b)))) - - ;; search in the cnt-list for the contract that matches the given definition - (define get-contract - (lambda (cnt-list def-stx) - (cond - [(null? cnt-list) (error 'get-contract "contract not found")] - [(fn=? (get-function-from-contract (car cnt-list)) (get-function-from-def def-stx)) (car cnt-list)] - [else (get-contract (cdr cnt-list) def-stx)]))) - - ;; returns the name of the function in a given definition-syntax - (define get-function-from-def - (lambda (stx) - (if (definition-stx? stx) - (syntax-case stx (begin define-values define-syntaxes) - [(define-values (f) e1 ...) (syntax f)] - [_ (raise-syntax-error 'contract "internal error.2")]) - (raise-syntax-error 'defs "this is not a valid definition" stx)))) - - ;; given a syntax object, tells you whether or not this is a definition. - (define definition-stx? - (lambda (stx) - (syntax-case stx (begin define-values) - [(define-values (f) e1 ...) #t] - [_ #f]))) - - ;;transform-definiton - (define (transform-definition def) - (syntax-case def (define-values) - [(define-values (func) exp) - (with-syntax ([new-name (rename-func def)] - [expr-infname (syntax-property (syntax exp) 'inferred-name - (syntax-object->datum (syntax func)))]) - (syntax/loc def (define-values (new-name) expr-infname)))] - [_ (raise-syntax-error 'contract "internal error.3")])) - - (define (rename-func def) - (let ([name (get-function-from-def def)]) - (syntax-case def (define-values) - [(define-values (f) e1) - (datum->syntax-object (syntax f) - (string->symbol (string-append (symbol->string (syntax-object->datum name)) "-con")))] - [_ (raise-syntax-error 'contract "internal error.4")]))) - + (let loop ((exprs expressions)) - ;; transform-contract : syntax syntax -> syntax - ;; takes in two syntax objects: one representing a contract, and another representing a definition, - ;; returns a syntax object that returns the correct language level contract wrapping - (define transform-contract - (lambda (language-level-contract cnt-stx def-stx) - (syntax-case cnt-stx () - [(contract function cnt) - (with-syntax ([ll-contract language-level-contract] - [name-to-bind (get-function-from-def def-stx)] - [func-to-wrap (rename-func def-stx)]) - (syntax/loc cnt-stx (ll-contract 'name-to-bind 'func-to-wrap cnt)))] - [_ (raise-syntax-error 'contract "internal error.5")]))) - - (define local-expand-stop-list - (append (list #'contract #'#%require #'#%provide language-level-define-data) - (kernel-form-identifier-list))) + (cond + ((null? exprs) + (bound-identifier-mapping-for-each contract-table + (lambda (id thing) + (when thing + (if (identifier-binding id) + (raise-syntax-error #f "Cannot declare a contract for a built-in form." id) + (raise-syntax-error #f "There is no definition for this contract declaration." id))))) + #'(begin)) + (else + (let ((expanded (car exprs))) - ;; parse-contract-expressions - ;; takes in a list of top level expressions and a list of contracts, and outputs the correct transformation. - ;; 1. expand until we find a definition or a contract - ;; 2. if its a definition, and it has a contract, transform and output - ;; 3. else just output it - (define (parse-contract-expressions ll-contract ll-define-data contract-list expressions) + (syntax-case expanded (begin define-values) + ((define-values (?id ...) ?e1) + (with-syntax (((?enforced ...) + (map (lambda (id) + (cond + ((bound-identifier-mapping-get contract-table id (lambda () #f)) + => (lambda (cnt) + (bound-identifier-mapping-put! contract-table id #f) ; check for orphaned contracts + (with-syntax ((?id id) + (?cnt cnt)) + #'(?id (contract ?cnt))))) + (else + id))) + (syntax->list #'(?id ...)))) + (?rest (loop (cdr exprs)))) + (with-syntax ((?defn + (syntax-track-origin + #'(define-values/contract (?enforced ...) + ?e1) + (car exprs) + (car (syntax-e expanded))))) - (let loop ([cnt-list contract-list] - [exprs expressions]) + (syntax/loc (car exprs) + (begin + ?defn + ?rest))))) + ((begin e1 ...) + (loop (append (syntax-e (syntax (e1 ...))) (cdr exprs)))) + (else + (with-syntax ((?first expanded) + (?rest (loop (cdr exprs)))) + (syntax/loc (car exprs) + (begin + ?first ?rest)))))))))) + (values + ;; module-begin + (lambda (stx) + (syntax-case stx () + ((_ e1 ...) + ;; module-begin-continue takes a sequence of expanded + ;; exprs and a sequence of to-expand exprs; that way, + ;; the module-expansion machinery can be used to handle + ;; requires, etc.: + #`(#%plain-module-begin + (module-continue (e1 ...) () ()))))) - (cond - [(null? exprs) - (if (null? cnt-list) - (syntax (begin )) - (raise-syntax-error 'contracts "this contract has no corresponding def" (car cnt-list)))] - [else - (let ([expanded (car exprs)]) - - (syntax-case expanded (begin define-values) - [(define-values (func) e1 ...) - (contract-defined? cnt-list expanded) - (let ([cnt (get-contract cnt-list expanded)]) - (quasisyntax/loc (car exprs) - (begin - #,(transform-definition expanded) - #,(transform-contract ll-contract cnt expanded) - #,(loop (remove cnt cnt-list) (cdr exprs)))))] - [(define-data name c1 c2 ...) - (and (identifier? #'name) - (define-data-stx? expanded)) - (quasisyntax/loc (car exprs) - (begin - (#,ll-define-data name c1 c2 ...) - #,(loop cnt-list (cdr exprs))))] - [(begin e1 ...) - (loop cnt-list (append (syntax-e (syntax (e1 ...))) (cdr exprs)))] - [_else - (quasisyntax/loc (car exprs) - (begin - #,(car exprs) - #,(loop cnt-list (cdr exprs))))]))]))) - - ;; contract transformations! - ;; this is the macro, abstracted over which language level we are using. - ;; parse-contracts : - ;; given transformers that handle the actual contract parsing (depends on language level.. see contracts.scm and define-data.scm - ;; this returns a big wrapper macro that translates calls to - ;; (contract f (number -> number)) (define f ...) - ;; ====>>>> (lang-lvl-contract f (number -> number) ...) - ;; where ll-contract is either beginner-contract, intermediate-contract, or advanced-contract - ;; and (define-data name ....) to (lang-lvl-define-data name ...) - - (values - ;; module-begin (for a specific language:) - (lambda (stx) - (syntax-case stx () - [(_ e1 ...) - ;; module-begin-continue takes a sequence of expanded - ;; exprs and a sequence of to-expand exprs; that way, - ;; the module-expansion machinery can be used to handle - ;; requires, etc.: - #`(#%plain-module-begin - (#,module-begin-continue-id (e1 ...) () ()))])) - - ;; module-continue (for a specific language:) - (lambda (stx) - (syntax-case stx () - [(_ () (e1 ...) (defined-id ...)) - ;; Local-expanded all body elements, lifted out requires, etc. - ;; Now process the result. - (begin - ;; The expansion for contracts breaks the way that beginner-define, etc., - ;; check for duplicate definitions, so we have to re-check here. - ;; A better strategy might be to turn every define into a define-syntax - ;; to redirect the binding, and then the identifier-binding check in - ;; beginner-define, etc. will work. - (let ([defined-ids (make-bound-identifier-mapping)]) - (for-each (lambda (id) - (when (bound-identifier-mapping-get defined-ids id (lambda () #f)) - (raise-syntax-error - #f - "this name was defined previously and cannot be re-defined" - id)) - (bound-identifier-mapping-put! defined-ids id #t)) - (reverse (syntax->list #'(defined-id ...))))) - ;; Now handle contracts: - (let* ([top-level (reverse (syntax->list (syntax (e1 ...))))] - [cnt-list (extract-contracts top-level)] - [expr-list (extract-not-contracts top-level)]) - (parse-contract-expressions language-level-contract - language-level-define-data - cnt-list - expr-list)))] - [(frm e3s e1s def-ids) - (let loop ([e3s #'e3s] - [e1s #'e1s] - [def-ids #'def-ids]) - (syntax-case e3s () - [() - #`(frm () #,e1s #,def-ids)] - [(e2 . e3s) - (let ([e2 (local-expand #'e2 'module local-expand-stop-list)]) - ;; Lift out certain forms to make them visible to the module - ;; expander: - (syntax-case e2 (#%require #%provide define-syntaxes define-values-for-syntax define-values begin) - [(#%require . __) - #`(begin #,e2 (frm e3s #,e1s #,def-ids))] - [(#%provide . __) - #`(begin #,e2 (frm e3s #,e1s #,def-ids))] - [(define-syntaxes (id ...) . _) - #`(begin #,e2 (frm e3s #,e1s (id ... . #,def-ids)))] - [(define-values-for-syntax . _) - #`(begin #,e2 (frm e3s #,e1s #,def-ids))] - [(begin b1 ...) - (syntax-track-origin - (loop (append (syntax->list #'(b1 ...)) #'e3s) e1s def-ids) - e2 - (car (syntax-e e2)))] - [(define-values (id ...) . _) - (loop #'e3s (cons e2 e1s) (append (syntax->list #'(id ...)) def-ids))] - [_ - (loop #'e3s (cons #`(print-results #,e2) e1s) def-ids)]))]))])))) - - (define-values (parse-beginner-contract/func continue-beginner-contract/func) - (parse-contracts #'beginner-contract #'beginner-define-data #'beginner-continue)) - (define-values (parse-intermediate-contract/func continue-intermediate-contract/func) - (parse-contracts #'intermediate-contract #'intermediate-define-data #'intermediate-continue)) - (define-values (parse-advanced-contract/func continue-advanced-contract/func) - (parse-contracts #'advanced-contract #'advanced-define-data #'advanced-continue)) - - (values parse-beginner-contract/func - parse-intermediate-contract/func - parse-advanced-contract/func - continue-beginner-contract/func - continue-intermediate-contract/func - continue-advanced-contract/func)))) + ;; module-continue + (lambda (stx) + (syntax-case stx () + ((_ () (e1 ...) (defined-id ...)) + ;; Local-expanded all body elements, lifted out requires, etc. + ;; Now process the result. + (begin + ;; The expansion for contracts breaks the way that beginner-define, etc., + ;; check for duplicate definitions, so we have to re-check here. + ;; A better strategy might be to turn every define into a define-syntax + ;; to redirect the binding, and then the identifier-binding check in + ;; beginner-define, etc. will work. + (let ((defined-ids (make-bound-identifier-mapping))) + (for-each (lambda (id) + (when (bound-identifier-mapping-get defined-ids id (lambda () #f)) + (raise-syntax-error + #f + "There is already a definition for this name." + id)) + (bound-identifier-mapping-put! defined-ids id #t)) + (reverse (syntax->list #'(defined-id ...))))) + ;; Now handle contracts: + (let ((top-level (reverse (syntax->list (syntax (e1 ...)))))) + (let-values (((cnt-table expr-list) + (extract-contracts top-level))) + (expand-contract-expressions cnt-table expr-list))))) + ((frm e3s e1s def-ids) + (let loop ((e3s #'e3s) + (e1s #'e1s) + (def-ids #'def-ids)) + (syntax-case e3s () + (() + #`(frm () #,e1s #,def-ids)) + ((e2 . e3s) + (let ((e2 (local-expand #'e2 'module local-expand-stop-list))) + ;; Lift out certain forms to make them visible to the module + ;; expander: + (syntax-case e2 (#%require #%provide + define-syntaxes define-values-for-syntax define-values begin + define-contract :) + ((#%require . __) + #`(begin #,e2 (frm e3s #,e1s #,def-ids))) + ((#%provide . __) + #`(begin #,e2 (frm e3s #,e1s #,def-ids))) + ((define-syntaxes (id ...) . _) + #`(begin #,e2 (frm e3s #,e1s (id ... . #,def-ids)))) + ((define-values-for-syntax . _) + #`(begin #,e2 (frm e3s #,e1s #,def-ids))) + ((begin b1 ...) + (syntax-track-origin + (loop (append (syntax->list #'(b1 ...)) #'e3s) e1s def-ids) + e2 + (car (syntax-e e2)))) + ((define-values (id ...) . _) + (loop #'e3s (cons e2 e1s) (append (syntax->list #'(id ...)) def-ids))) + ((define-contract id ctr) + (loop #'e3s (cons e2 e1s) def-ids)) + ((: stuff ...) + (loop #'e3s (cons e2 e1s) def-ids)) + (_ + (loop #'e3s (cons #`(print-results #,e2) e1s) def-ids))))))))))))) diff --git a/collects/lang/private/contracts/define-data.rkt b/collects/lang/private/contracts/define-data.rkt deleted file mode 100644 index 09837f8f62..0000000000 --- a/collects/lang/private/contracts/define-data.rkt +++ /dev/null @@ -1,94 +0,0 @@ -(module define-data mzscheme - - (require-for-syntax "advanced-contracts.ss" - "hilighters.ss" - "contract-transformers.ss") - (require "contracts-helpers.ss" - "hilighters.ss") - - (provide beginner-define-data - intermediate-define-data - advanced-define-data - - beginner-dd-builder - intermediate-dd-builder - advanced-dd-builder) - - ;;;;;;;;;;;;;;;;;; define-data - #| - -execution is broken into two parts to support recursive definitions: first we bind all the names we need, and then define them. - -*-define-data binds the name if the definition as syntax as a list that has three items: the name of the data definition, the -symbol 'define-data (just to distinguish what it is), and a syntax object that represents the name of the contract structure -that enforces this definition (called -contract). also expands into the definition of this contract-struct. - -the second stage actually runs the transformations on the given contracts. since all other names from define-datas have been bound by now, -it allows for recursion. the contract enforcer is defined in contracts-helpers.scm - -|# - - (define-syntaxes (beginner-dd-builder intermediate-dd-builder advanced-dd-builder) - (let () - - (define dd-builder-template - (lambda (translator) - (lambda (stx) - - (syntax-case stx () - [(_ name src e1 e2 ...) - - (with-syntax ([(translated-cnts ...) (map translator (syntax-e (syntax (e1 e2 ...))))]) - - (syntax - (letrec ([me (make-flat-contract - - ;enforcer - (lambda (value) - (define-data-enforcer me value (list translated-cnts ...))) - - ;hilighter - (lambda (path) - (let ([hilighter (mk-define-data-hilighter 'name (map contract-hilighter (list translated-cnts ...)))]) - (hilighter path))) - - ;stx locations - (syntax-source src) - (syntax-line src) - (syntax-column src) - (syntax-position src) - (syntax-span src) - - ;predicate - (lambda (x) - (ormap (lambda (c) ((flat-contract-predicate c) x)) (list translated-cnts ...))))]) - me)))])))) - - - (values (dd-builder-template beginner-translate-contract) - (dd-builder-template intermediate-translate-contract) - (dd-builder-template advanced-translate-contract)))) - - - (define-syntaxes (beginner-define-data intermediate-define-data advanced-define-data) - (let () - - (define define-data-template - (lambda (builder) - (lambda (stx) - (syntax-case stx () - [(_ name cnt1 cnt2 ...) - (with-syntax - ([cnt-builder builder] - [contract-name - (datum->syntax-object (syntax name) (string->symbol (string-append (symbol->string (syntax-object->datum (syntax name))) "-contract")))] - [ret stx]) - (syntax - (begin - (define-syntax name (list #'name 'define-data #'contract-name)) - (define contract-name (cnt-builder name #'ret cnt1 cnt2 ...))) - ))])))) - - (values (define-data-template #'beginner-dd-builder) - (define-data-template #'intermediate-dd-builder) - (define-data-template #'advanced-dd-builder))))) diff --git a/collects/lang/private/contracts/intermediate-contracts.rkt b/collects/lang/private/contracts/intermediate-contracts.rkt deleted file mode 100644 index 1dab4ed242..0000000000 --- a/collects/lang/private/contracts/intermediate-contracts.rkt +++ /dev/null @@ -1,76 +0,0 @@ -(module intermediate-contracts mzscheme - - (require "hilighters.ss" - "contracts-helpers.ss" - mzlib/etc) - - (require mzlib/list) - - (provide vector-contract - listof-contract - vectorof-contract - boxof-contract) - - (define vector-contract (lambda (stx) (build-flat-contract vector? 'vector stx))) - - (define (somethingof-contract thing enforcer predicate cnt stx) - (if (not (flat-contract? cnt)) - (error 'contracts "~a contracts can only be created with flat values!" thing) - (make-flat-contract - enforcer - (mk-listof-hilighter (contract-hilighter cnt)) - (syntax-source stx) - (syntax-line stx) - (syntax-column stx) - (syntax-position stx) - (syntax-span stx) - predicate))) - - (define (listof-contract cnt stx) - (rec me - (somethingof-contract - 'listof - (lambda (l) - (if (null? l) l - (if (pair? l) - (let loop ([list l]) - (catch-contract-error 'car me ((contract-enforcer cnt) (car list))) - (if (null? (cdr list)) - l - (loop (cdr list)))) - (contract-error l me '())))) - - (lambda (x) (or (null? x) (and (pair? x) (andmap (flat-contract-predicate cnt) x)))) - cnt - stx))) - - (define (vectorof-contract cnt stx) - (rec me - (somethingof-contract - 'vectorof - (lambda (v) - (if (vector? v) - (let loop ([i 0]) - (catch-contract-error 'car me ((contract-enforcer cnt) (vector-ref v i))) - (if (< (+ 1 i) (vector-length v)) - (loop (+ i 1)) - v)) - (contract-error v me '()))) - - (lambda (x) (and (vector? x) (andmap (flat-contract-predicate cnt) (vector->list x)))) - cnt - stx))) - - (define (boxof-contract cnt stx) - (rec me - (somethingof-contract - 'boxof - (lambda (v) - (if (box? v) - (begin - (catch-contract-error 'car me ((contract-enforcer cnt) (unbox v))) - v) - (contract-error v me '()))) - (lambda (v) (and (box? v) ((flat-contract-predicate cnt) (unbox v)))) - cnt - stx)))) diff --git a/collects/lang/private/teach.rkt b/collects/lang/private/teach.rkt index 2b18ed4c6e..6460305f2f 100644 --- a/collects/lang/private/teach.rkt +++ b/collects/lang/private/teach.rkt @@ -39,7 +39,11 @@ mzlib/math scheme/match "set-result.ss" - (only racket/base define-struct)) + (only racket/base define-struct) + (all-except deinprogramm/contract/contract contract-violation) + (all-except lang/private/contracts/contract-syntax property) + (all-except deinprogramm/quickcheck/quickcheck property) + (rename deinprogramm/quickcheck/quickcheck quickcheck:property property)) (require-for-syntax "teachhelp.ss" "teach-shared.ss" syntax/kerncase @@ -537,13 +541,17 @@ (lambda (fn) (with-syntax ([fn fn] [args (cdr (syntax-e #'name-seq))]) - (quasisyntax/loc stx (define fn #,(stepper-syntax-property - (stepper-syntax-property - #`(lambda args expr ...) - 'stepper-define-type - 'shortened-proc-define) - 'stepper-proc-define-name - #`fn))))))]) + (quasisyntax/loc stx + (define fn + #,(stepper-syntax-property + (stepper-syntax-property + ;; this is so contract blame can report a + ;; position for the procedure + (syntax/loc stx (lambda args expr ...)) + 'stepper-define-type + 'shortened-proc-define) + 'stepper-proc-define-name + #`fn))))))]) (check-definition-new 'define stx @@ -2453,4 +2461,41 @@ ;; For expressions (cdr check via `the-cons'): (lambda (stx) (syntax-case stx () - [(_ a b) (syntax/loc stx (the-cons a b))])))) + [(_ a b) (syntax/loc stx (the-cons a b))]))) + +(provide contract define-contract : + -> mixed one-of predicate combined) + +(provide Integer Number Rational Real Natural + Boolean True False + String Char Symbol Empty-list + Unspecific) + +(define Integer (contract/arbitrary arbitrary-integer (predicate integer?))) +(define Number (contract/arbitrary arbitrary-real (predicate number?))) +(define Rational (contract/arbitrary arbitrary-rational (predicate rational?))) +(define Real (contract/arbitrary arbitrary-real (predicate real?))) + +(define (natural? x) + (and (integer? x) + (not (negative? x)))) + +(define Natural (contract/arbitrary arbitrary-natural (predicate natural?))) + +(define Boolean (contract/arbitrary arbitrary-boolean (predicate boolean?))) + +(define True (contract (one-of #f))) +(define False (contract (one-of #f))) + +(define String (contract/arbitrary arbitrary-printable-ascii-string (predicate string?))) +(define Char (contract/arbitrary arbitrary-printable-ascii-string (predicate char?))) +(define Symbol (contract/arbitrary arbitrary-symbol (predicate symbol?))) +(define Empty-list (contract (one-of empty))) + +(define Unspecific (contract (predicate (lambda (_) #t)))) + +;; Dummy definition, to be filled in later. +(provide property) +(define property "TBD") + +) diff --git a/collects/string-constants/english-string-constants.rkt b/collects/string-constants/english-string-constants.rkt index 444de3f707..b3a3ebaa13 100644 --- a/collects/string-constants/english-string-constants.rkt +++ b/collects/string-constants/english-string-constants.rkt @@ -1429,6 +1429,13 @@ please adhere to these guidelines: "check-error encountered the following error instead of the expected ~a~n :: ~a") (test-engine-expected-error-error "check-error expected the following error, but instead received the value ~F.~n ~a") + ;; members are appended to the message + (test-engine-not-mem-error "Actual value ~F differs from all given members in ") + (test-engine-not-range-error "Actual value ~F is not between ~F and ~F, inclusive.") + + ;; followed by list of variable bindings + (test-engine-property-fail-error "Property falsifiable with") + (test-engine-property-error-error "check-property encountered the following error~n:: ~a") ; section header (test-engine-check-failures "Check failures:") diff --git a/collects/string-constants/german-string-constants.rkt b/collects/string-constants/german-string-constants.rkt index 49d78f1804..f9fa39f0eb 100644 --- a/collects/string-constants/german-string-constants.rkt +++ b/collects/string-constants/german-string-constants.rkt @@ -1331,6 +1331,10 @@ "check-error bekam den folgenden Fehler anstatt des erwarteten ~a~n :: ~a") (test-engine-expected-error-error "check-error erwartete den folgenden Fehler, bekam aber den Wert ~F.~n ~a") + (test-engine-not-mem-error "Tatsächlicher Wert ~F ist keins der Elemente ") + (test-engine-not-range-error "Tatsächlicher Wert ~F liegt nicht zwischen ~F und ~F (inklusive).") + (test-engine-property-fail-error "Eigenschaft falsifizierbar mit") + (test-engine-property-error-error "`check-property' bekam den folgenden Fehler~n:: ~a") ; section header (test-engine-check-failures "Check-Fehler:") diff --git a/collects/test-engine/scheme-tests.rkt b/collects/test-engine/scheme-tests.rkt index 319350bd98..9d2832ac51 100644 --- a/collects/test-engine/scheme-tests.rkt +++ b/collects/test-engine/scheme-tests.rkt @@ -3,7 +3,8 @@ (require lang/private/teachprims scheme/class scheme/match - (only scheme/base for memf) + lang/private/continuation-mark-key + (only scheme/base for memf findf) "test-engine.scm" "test-info.scm" ) @@ -340,6 +341,48 @@ (define scheme-test-data (make-parameter (list #f #f #f))) +(define contract-test-info% + (class* test-info-base% () + + (define contract-violations '()) + + (define/pubment (contract-failed obj contract message blame) + + (let* ((cms + (continuation-mark-set->list (current-continuation-marks) + teaching-languages-continuation-mark-key)) + (srcloc + (cond + ((findf (lambda (mark) + (and mark + (or (path? (car mark)) + (symbol? (car mark))))) + cms) + => (lambda (mark) + (apply (lambda (source line col pos span) + (make-srcloc source line col pos span)) + mark))) + (else #f))) + (message + (or message + (make-contract-got obj (test-format))))) + + (set! contract-violations + (cons (make-contract-violation obj contract message srcloc blame) + contract-violations))) + (inner (void) contract-failed obj contract message)) + + (define/public (failed-contracts) (reverse contract-violations)) + + (inherit add-check-failure) + (define/pubment (property-failed result src-info) + (add-check-failure (make-property-fail src-info (test-format) result) #f)) + + (define/pubment (property-error exn src-info) + (add-check-failure (make-property-error src-info (test-format) (exn-message exn) exn) exn)) + + (super-instantiate ()))) + (define scheme-test% (class* test-engine% () (super-instantiate ()) @@ -349,6 +392,8 @@ (field [tests null] [test-objs null]) + (define/override (info-class) contract-test-info%) + (define/public (add-test tst) (set! tests (cons tst tests))) (define/public (get-info) @@ -366,4 +411,5 @@ (test) (inner (void) run-test test)))) -(provide scheme-test-data test-format test-execute test-silence error-handler) +(provide scheme-test-data test-format test-execute test-silence error-handler + contract-test-info% build-test-engine) diff --git a/collects/test-engine/test-display.scm b/collects/test-engine/test-display.scm index ae1c077078..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)) @@ -258,21 +281,34 @@ [(message-error? fail) (for-each print-formatted (message-error-strings fail))] [(not-mem? fail) - (print "Actual value ~F differs from all given members in " + (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 "Actual value ~F is not between ~F and ~F, inclusive." + (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 " ") @@ -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 ()))) diff --git a/collects/test-engine/test-engine.scm b/collects/test-engine/test-engine.scm index f4ac8088c3..a998ef3c22 100644 --- a/collects/test-engine/test-engine.scm +++ b/collects/test-engine/test-engine.scm @@ -147,29 +147,48 @@ (when (test-execute) (unless test-info (setup-info 'check-base)) (inner (void) run))) + + (define/private (clear-results event-space) + (when event-space + (parameterize ([(dynamic-require 'scheme/gui 'current-eventspace) event-space]) + ((dynamic-require 'scheme/gui 'queue-callback) + (lambda () (send test-display report-success)))))) + (define/public (summarize-results port) (cond - [(test-execute) - (unless test-display (setup-display #f #f)) - (let ([result (send test-info summarize-results)]) - (send test-display install-info test-info) - (case result - [(no-tests) (display-untested port)] - [(all-passed) (display-success port display-event-space - (+ (send test-info tests-run) - (send test-info checks-run)))] - [(mixed-results) - (display-results display-rep display-event-space)]))] - [else - (display-disabled port)])) + ((test-execute) + (unless test-display (setup-display #f #f)) + (send test-display install-info test-info) + (if (pair? (send test-info failed-contracts)) + (send this display-results display-rep display-event-space) + (let ((result (send test-info summarize-results))) + (case result + [(no-tests) + (clear-results display-event-space) + (display-untested port)] + [(all-passed) (display-success port display-event-space + (+ (send test-info tests-run) + (send test-info checks-run)))] + [(mixed-results) + (display-results display-rep display-event-space)])))) + (else + (display-disabled port)))) - (define/private (display-success port event count) - (when event - (parameterize ([(dynamic-require 'scheme/gui 'current-eventspace) event]) - ((dynamic-require 'scheme/gui 'queue-callback) - (lambda () (send test-display report-success))))) + (define/private (display-success port event-space count) + (clear-results event-space) (send test-display display-success-summary port count)) + (define/public (display-results rep event-space) + (cond + [(and rep event-space) + (parameterize ([(dynamic-require 'scheme/gui 'current-eventspace) event-space]) + ((dynamic-require 'scheme/gui 'queue-callback) + (lambda () (send rep display-test-results test-display))))] + [event-space + (parameterize ([(dynamic-require 'scheme/gui 'current-eventspace) event-space]) + ((dynamic-require 'scheme/gui 'queue-callback) (lambda () (send test-display display-results))))] + [else (send test-display display-results)])) + (define/public (display-untested port) (unless silent-mode (send test-display display-untested-summary port))) @@ -177,17 +196,6 @@ (define/public (display-disabled port) (send test-display display-disabled-summary port)) - (define/public (display-results rep event-space) - (cond - [(and rep event-space) - (parameterize ([(dynamic-require 'scheme/gui 'current-eventspace) event-space]) - ((dynamic-require 'scheme/gui 'queue-callback) - (lambda () (send rep display-test-results test-display))))] - [event-space - (parameterize ([(dynamic-require 'scheme/gui 'current-eventspace) event-space]) - ((dynamic-require 'scheme/gui 'queue-callback) (lambda () (send test-display display-results))))] - [else (send test-display display-results)])) - (define/pubment (initialize-test test) (inner (void) initialize-test test)) diff --git a/collects/test-engine/test-info.scm b/collects/test-engine/test-info.scm index ab48376833..38f112b38a 100644 --- a/collects/test-engine/test-info.scm +++ b/collects/test-engine/test-info.scm @@ -1,6 +1,7 @@ #lang scheme/base (require scheme/class + deinprogramm/quickcheck/quickcheck "print.ss") (provide (all-defined-out)) @@ -25,6 +26,13 @@ ;; (make-not-range src format scheme-val scheme-val scheme-val) (define-struct (not-range check-fail) (test min max)) +(define-struct contract-got (value format)) + +(define-struct contract-violation (obj contract message srcloc blame)) + +(define-struct (property-fail check-fail) (result)) +(define-struct (property-error check-fail) (message exn)) + ;; (make-message-error src format (listof string)) (define-struct (message-error check-fail) (strings)) @@ -129,6 +137,18 @@ (formatter (not-range-test fail)) (formatter (not-range-min fail)) (formatter (not-range-max fail)))] - ) + [(property-fail? fail) + (print-string "Property falsifiable with") + (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 "check-property encountered the the following error~n:: ~a" + (property-error-message fail))]) (print-string "\n"))) +