Merge remote branch 'origin/master'
This commit is contained in:
Mike Sperber
commit
b0e6e6b55d
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)))))
|
||||
|
||||
|
|
@ -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 ())))
|
||||
|
|
@ -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)
|
||||
|
|
@ -1157,14 +1157,6 @@
|
|||
;
|
||||
;
|
||||
|
||||
|
||||
|
||||
|
||||
;; 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)))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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"))
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -24,14 +24,18 @@
|
|||
;; 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%
|
||||
|
|
@ -986,21 +1000,20 @@
|
|||
[(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
|
||||
|
|
@ -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)))
|
||||
|
|
|
|||
9
collects/lang/private/continuation-mark-key.rkt
Normal file
9
collects/lang/private/continuation-mark-key.rkt
Normal file
|
|
@ -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))
|
||||
|
|
@ -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))
|
||||
|
|
@ -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))))
|
||||
|
|
@ -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))))
|
||||
|
|
@ -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)))))
|
||||
|
||||
)
|
||||
|
|
@ -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 <a> <b>) 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 <cnt>) 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-<blah> 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))]))))
|
||||
|
|
@ -1,286 +1,194 @@
|
|||
(module contracts-module-begin mzscheme
|
||||
#lang scheme/base
|
||||
|
||||
(require "contracts.ss")
|
||||
; 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-for-syntax mzlib/list
|
||||
syntax/boundmap
|
||||
syntax/kerncase)
|
||||
(require lang/private/contracts/contract-syntax)
|
||||
|
||||
(provide beginner-module-begin intermediate-module-begin advanced-module-begin)
|
||||
(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-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))
|
||||
(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)))
|
||||
(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))))
|
||||
|
||||
;; negate previous
|
||||
(define extract-not-contracts
|
||||
(lambda (stx-list)
|
||||
(filter (lambda (x) (not (contract-stx? x))) stx-list)))
|
||||
(define local-expand-stop-list
|
||||
(append (list #': #'define-contract
|
||||
#'#%require #'#%provide)
|
||||
(kernel-form-identifier-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])))
|
||||
(define (expand-contract-expressions contract-table expressions)
|
||||
|
||||
;; 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])))
|
||||
(let loop ((exprs expressions))
|
||||
|
||||
;; 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)])))
|
||||
(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)))
|
||||
|
||||
;; 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))))
|
||||
(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)))))
|
||||
|
||||
;; 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))))
|
||||
(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 ...) () ())))))
|
||||
|
||||
;; 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")])))
|
||||
|
||||
|
||||
;; 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)))
|
||||
|
||||
;; 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)
|
||||
|
||||
(let loop ([cnt-list contract-list]
|
||||
[exprs expressions])
|
||||
|
||||
(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)))))))))))))
|
||||
|
|
|
|||
|
|
@ -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 <name>-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)))))
|
||||
|
|
@ -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))))
|
||||
|
|
@ -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")
|
||||
|
||||
)
|
||||
|
|
|
|||
|
|
@ -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:")
|
||||
|
|
|
|||
|
|
@ -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:")
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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 ())))
|
||||
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
||||
|
|
|
|||
|
|
@ -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")))
|
||||
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user