(module model2rml mzscheme
(require (lib "class.ss")
(lib "list.ss")
(lib "mred.ss" "mred")
(lib "plt-match.ss")
(lib "file.ss")
(prefix drlink: "drscheme-ui.ss")
"interfaces.ss"
"config.ss")
(provide model-renderer%)
(define model-renderer%
(class object%
(init-field controller)
(init-field editor)
(super-new)
(define/public (render-model/short model)
(cond [(is-a? model model-suite<%>) (render-suite-short-form model)]
[(is-a? model model-case<%>) (render-case-short-form model)]))
(define/public (render-model/long model)
(cond [(is-a? model model-suite<%>) (render-suite-long-form model)]
[(is-a? model model-case<%>) (render-case-long-form model)]))
(define/private (put styles . texts)
(send/apply editor insert/styles styles texts))
(define/private (put+click styles clickback . texts)
(send/apply editor insert/styles+click styles clickback texts))
(define/private (blank)
(send editor newline))
(define/private (render-suite-long-form model)
(let [(suite (send model get-test))
(children (send model get-children))
(parent (send model get-parent))]
(let* [(children (send model get-children))
(successes (filter (lambda (c) (send c success?)) children))
(failures (filter (lambda (c) (send c failure?)) children))
(errors (filter (lambda (c) (send c error?)) children))
(unexecuted (filter (lambda (c) (not (send c executed?))) children))
(num-tests (length children))]
(put '(large italic bold) (send model get-name) "\n")
(when parent
(put '() " (in ")
(put+click '(clickback bold)
(lambda _ (send controller select-model parent))
(send parent get-name))
(put '() ")\n"))
(blank)
(if (send model executed?)
(begin (put '(large)
(format "Failures (~a/~a)\n"
(length failures)
num-tests))
(for-each (lambda (m) (render-model/short m)) failures)
(blank)
(put '(large)
(format "Errors (~a/~a)\n"
(length errors)
num-tests))
(for-each (lambda (m) (render-model/short m)) errors)
(blank)
(when (pair? unexecuted)
(put '(large)
(format "Unexecuted (~a/~a)\n")
(length unexecuted)
num-tests)
(for-each (lambda (m) (render-model/short m)) unexecuted)
(blank))
(put '(large)
(format "Successes (~a/~a)\n"
(length successes)
num-tests))
(for-each (lambda (m) (render-model/short m)) successes)
(blank))
(put '(test-unexecuted)
"This test suite has not been executed.")))))
(define/private (render-model-link model suite?)
(let ([styles (if suite? '(clickback bold) '(clickback))])
(put+click styles
(lambda _ (send controller select-model model))
(send model get-name))))
(define/private (render-suite-short-form model)
(let [(suite (send model get-test))]
(let* [(children (send model get-children))
(successes (filter (lambda (c) (send c success?)) children))
(failures (filter (lambda (c) (send c failure?)) children))
(errors (filter (lambda (c) (send c error?)) children))
(unexecuted (filter (lambda (c) (not (send c executed?))) children))
(num-tests (length children))]
(let [(style (if (and (null? failures) (null? errors)) 'normal 'red))]
(render-model-link model #t)
(if (send model executed?)
(put `(,style)
(format " subtests: ~a/~a/~a~a"
(length successes)
(length failures)
(length errors)
(if (pair? unexecuted)
(format "/~a" (length unexecuted))
"")))
(put '(test-unexecuted) " not yet executed"))
(blank)))))
(define/private (render-case-short-form model)
(cond [(send model success?)
(render-success-short-form model)]
[(send model failure?)
(render-failure-short-form model)]
[(send model error?)
(render-error-short-form model)]
[(not (send model executed?))
(render-not-executed-short-form model)]))
(define/private (render-success-short-form model)
(render-model-link model #f)
(put '() " succeeded\n"))
(define/private (render-failure-short-form model)
(let* [(exn (send model get-result))
(exnmsg (send model get-property prop:failure-message))
(exnname (send model get-property prop:failure-assertion))]
(render-model-link model #f)
(put '() " failed")
(when exnname
(put '() " on ")
(put '(fail-type) (format "~a" exnname)))
(when exnmsg
(put '() " with message: ")
(put '(exn-message) exnmsg))
(blank)))
(define/private (render-error-short-form model)
(let [(exn (send model get-result))]
(render-model-link model #f)
(cond [(exn? exn)
(put '() " threw an exception of type ")
(put '(exn-type) (format "~a" (object-name exn)))
(put '() " with message: ")
(put '(exn-message) (exn-message exn))]
[else
(put '() (format " raised the value ~e" exn))])
(blank)))
(define/private (render-not-executed-short-form model)
(render-model-link model #f)
(put '(test-unexecuted) "has not been executed"))
(define/private (render-case-long-form model)
(cond [(send model success?)
(render-success-long-form model)]
[(send model failure?)
(render-failure-long-form model)]
[(send model error?)
(render-error-long-form model)]
[(not (send model executed?))
(render-not-executed-long-form model)])
(when (send model executed?)
(render-timing model)
(render-trash model)
(render-output model)))
(define/private (render-model-link* model suite?)
(let [(parent (send model get-parent))]
(let ([styles (if suite? '(bold) '())])
(put `(large italic ,@styles)
(send model get-name))
(blank)
(when parent
(put '() " in ")
(put+click `(clickback bold)
(lambda _ (send controller select-model parent))
(send parent get-name))
(blank))
(blank))))
(define/private (render-success-long-form model)
(render-model-link* model #f)
(put '() "The test case succeeded.\n\n"))
(define/private (render-failure-long-form model)
(render-model-link* model #f)
(let* [(exn (send model get-result))
(failure-msgs (send model get-property-set prop:failure-message))
(messages
(if (string? (exn-message exn))
(cons (exn-message exn) failure-msgs)
failure-msgs))
(exnname (send model get-property prop:failure-assertion))
(exnlocs
(send model get-property-set prop:failure-location))
(exnparams (send model get-property prop:failure-parameters))
(exn2 (send model get-property 'exception))]
(put '() "The test case failed on ")
(put '(fail-type) (format "~a" exnname))
(put '() ".\n\n")
(render-source-location "Location" test-case-loc)
(render-source-location "Check location" exnlocs)
(render-backtrace-link "Backtrace of check failure: " exn)
(render-messages messages)
(render-parameters exnparams)
(render-embedded-exception exn2)))
(define/private (render-error-long-form model)
(render-model-link* model #f)
(let [(exn (send model get-result))]
(cond [(exn? exn)
(put '() "The test case threw and exception of type ")
(put '(exn-type) (format "~a" (object-name exn)))
(put '() ".\n\n")
(render-backtrace-link "Exception backtrace: " exn)
(render-messages (list (exn-message exn)))
(render-value "Exception value:\n" exn)]
[else
(put '() "The test raised a value that was not "
"an instance of an exception struct.\n\n")
(render-value "Raised value:\n" exn)])))
(define/private (render-not-executed-long-form model)
(render-model-link* model #f)
(put '(test-unexecuted)
"The test case has not been executed."))
(define/private (render-value text value)
(put '() text)
(render-value-box value)
(blank))
(define/private (render-value-box value)
(send editor insert-wide-box
(lambda (editor)
(send editor insert/styles '(value) (format "~v" value)))))
(define/private (render-messages messages)
(when (pair? messages)
(put '() "Message:\n")
(for-each
(lambda (message)
(send editor insert-wide-box
(lambda (editor)
(send editor insert/styles '(exn-message) message))))
messages)
(blank)))
(define/private (render-parameters parameters)
(when (and parameters (pair? parameters))
(put '() "Parameters:\n")
(for-each (lambda (parameter) (render-value-box parameter))
parameters)
(blank)))
(define/private (render-embedded-exception exn)
(when (exn? exn)
(put '() "Received exception")
(inline-backtrace-link " " exn)
(put '() ":\n")
(render-value-box exn)
(blank)))
(define/private (render-source-location label location-reps)
(when (pair? location-reps)
(let* ([location-reps (reverse location-reps)]
[rep0 (car location-reps)]
[reps (cdr location-reps)])
(put '() label ": ")
(inline-source-location/1 rep0)
(blank)
(when (pair? reps)
(put '() "Inner locations: ")
(for-each (lambda (r) (inline-source-location/1 r)) reps)
(blank))
(blank)))
(unless (pair? location-reps)
(put '() label " is not available.")))
(define/private (inline-source-location/1 location)
(match location
[(list src line col pos span)
(let* ([file-name (resolve-source-file src)]
[short-file-name
(if (or (path? file-name) (string? file-name))
(path->string (file-name-from-path file-name))
file-name)]
[source-location (format "~a:~a:~a" short-file-name line col)])
(inline-source-location/h source-location src pos span))]
[_ (put '() "not usable")]))
(define/private (inline-source-location/h source-location src pos span)
(if (and src drlink:can-show-source?)
(put+click '(clickback)
(lambda _ (drlink:show-source src pos span))
source-location)
(put '() source-location)))
(define/private (render-backtrace-link text exn)
(when (drlink:has-backtrace? exn)
(inline-backtrace-link text exn)
(blank)
(blank)))
(define/private (inline-backtrace-link text exn)
(when (drlink:has-backtrace? exn)
(put '() text)
(put+click '(clickback)
(lambda _ (drlink:show-backtrace exn))
"[backtrace]")))
(define/private (render-output model)
(let [(output (send model get-output))]
(when (pair? output)
(put '() "Output:\n")
(send editor insert-wide-box
(lambda (editor)
(for-each
(lambda (mode+text)
(let ([styles
(if (eq? (car mode+text) 'error)
'(red italic)
'(darkblue))])
(send editor insert/styles styles (cadr mode+text))))
output)))
(blank))))
(define/private (render-timing model)
(let [(timing (send model get-timing))]
(when timing
(let ([cpu (car timing)]
[real (cadr timing)]
[gc (caddr timing)])
(put '() "Timing:\n")
(put '() (format "cpu: ~a; real: ~a; gc: ~a\n\n"
cpu real gc))))))
(define/private (render-trash model)
(let ([trash (send model get-trash)])
(when (pair? trash)
(put '() "Test did not clean up resources:\n")
(for-each (lambda (t) (render-value-box t)) trash)
(blank))))
(define/private (resolve-source-file src)
(or (and (is-a? src editor<%>)
(let* [(tmp?-box (box #t))
(filename (send src get-filename tmp?-box))]
(if (and filename (not (unbox tmp?-box)))
filename
#f)))
(cond [(string? src) src]
[else 'unknown])))
))
)