(module model2rml mzscheme
(require (lib "class.ss")
(lib "list.ss")
(lib "mred.ss" "mred")
(prefix drlink: "drscheme-ui.ss")
"interfaces.ss"
"config.ss")
(provide model->rml%)
(define model->rml%
(class* object% (model->rml<%>)
(init-field controller)
(super-instantiate ())
(define/public (model->rml/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 (model->rml/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 (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))]
`(div ()
(div (blue large)
,(send model get-name))
,(if parent
`(div ()
" (in "
(link ,(lambda _ (send controller select-model parent))
(clickback bold)
,(send parent get-name))
")")
"")
(div ())
,(if (send model executed?)
`(div ()
(div ()
(div (large)
"Failures"
,(format " (~a/~a)" (length failures) num-tests))
,@(map (lambda (f) (model->rml/short f)) failures))
(div ()
(div (large)
"Errors"
,(format " (~a/~a)" (length errors) num-tests))
,@(map (lambda (e) (model->rml/short e)) errors))
(div ()
(div (large)
"Successes"
,(format " (~a/~a)" (length successes) num-tests))
,@(map (lambda (s) (model->rml/short s)) successes))
,(if (null? unexecuted)
""
`(div ()
(div (large)
"Unexecuted"
,(format " (~a/~a)" (length unexecuted) num-tests))
,@(map (lambda (f) (model->rml/short f)) unexecuted))))
`(div (test-unexecuted)
(div ())
"This test suite has not been executed."))))))
(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))]
`(div ()
(link ,(lambda _ (send controller select-model model))
(clickback bold)
,(send model get-name))
,(if (send model executed?)
`(span (,style)
" subtests: "
,(length successes)
"/"
,(length failures)
"/"
,(length errors)
,(if (null? unexecuted)
""
`(span ()
" and "
,(length unexecuted)
" unexecuted")))
`(span (test-unexecuted)
" not yet executed")))))))
(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-case/h
model
" succeeded"))
(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-case/h
model
" failed"
(if exnname
`(span ()
" on "
(span (fail-type) ,(format "~a" exnname)))
"")
(if exnmsg
`(span ()
" with message: "
(span (exn-message) ,(format "~a" exnmsg)))
""))))
(define/private (render-error-short-form model)
(let [(exn (send model get-result))]
(render-case/h
model
(cond [(exn? exn)
`(span ()
" threw an exception of type "
(span (exn-type) ,(format "~a" (object-name exn)))
" with message: "
(span (exn-message) ,(format "~s" (exn-message exn))))]
[else
`(span ()
,(format " raised the value ~e" exn))]))))
(define/private (render-not-executed-short-form model)
(render-case/h
model
`(span (test-unexecuted) " has not been executed")))
(define/private (render-case/h model . afterdivs)
`(div ()
(link ,(lambda _ (send controller select-model model))
(italic clickback)
,(send model get-name))
,@afterdivs))
(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)]))
(define/private (render-success-long-form model)
(render-case/lh
model
`(div ()
(div () "The test case succeeded.")
(div ())
,(render-timing model)
,(render-output model))))
(define/private (render-failure-long-form model)
(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))
(exnloc-reps
(send model get-property-set prop:failure-location-representative))
(exnparams (send model get-property prop:failure-parameters))
(exn2 (send model get-property 'exception))]
(render-case/lh
model
`(div ()
(div ()
"The test case failed on "
(span (fail-type) ,exnname))
(div ())
,(render-backtrace-link "Backtrace of assertion failure: " exn)
,(render-source-location "Assertion location" exnloc-reps)
,(render-messages messages)
,(render-parameters exnparams)
,(render-embedded-exception exn2)
,(render-timing model)
,(render-output model)))))
(define/private (render-error-long-form model)
(render-case/lh
model
(let [(exn (send model get-result))]
`(div ()
,(cond [(exn? exn)
`(div ()
(div ()
"The test case threw an exception of type "
(span (exn-type) ,(object-name exn)))
(div ())
,(render-backtrace-link "Backtrace of exception: " exn)
,(render-messages (list (exn-message exn)))
,(render-value "Exception value: " exn))]
[else
`(div ()
(div ()
"The test case raised a value which was not an instance of struct exn.")
(div ())
,(render-value "Raised value: " exn))])
,(render-timing model)
,(render-output model)))))
(define/private (render-not-executed-long-form model)
(render-case/lh
model
`(div (test-unexecuted)
"The test case has not been executed.")))
(define/private (render-case/lh model . afterdivs)
(let [(parent (send model get-parent))]
`(div ()
(div (large italic) ,(send model get-name))
,(if parent
`(div ()
" (in "
(link ,(lambda _ (send controller select-model parent))
(clickback bold)
,(send parent get-name))
")")
"")
(div ())
,@afterdivs)))
(define/private (render-value text value)
`(div () ,text
(div (value) (wide-box ,(format "~v" value)))))
(define/private (render-messages messages)
(if (pair? messages)
`(div ()
(div () "Message:")
,@(map (lambda (message)
`(div () (wide-box (span (exn-message) ,message))))
messages)
(div ()))
'(span ())))
(define/private (render-parameters parameters)
(if (and parameters (pair? parameters))
`(div ()
(div () "Parameters:")
,@(map (lambda (parameter)
`(div (value)
(wide-box ,(format "~v" parameter))))
parameters))
'(span ())))
(define/private (render-embedded-exception exn)
(if (exn? exn)
`(div ()
"Received exception:"
(div ()
(wide-box
(span (value) ,(format "~v" exn)))))
'(span ())))
(define/private (render-source-location label location-reps)
(cond [(pair? location-reps)
(let* ([location-reps (reverse location-reps)]
[rep0 (car location-reps)]
[reps (cdr location-reps)])
`(div ()
(div () ,label ": "
,(render-source-location/1 rep0))
,(if (pair? reps)
`(div () "Inner failure locations: "
,@(map (lambda (rep) (render-source-location/1 rep))
reps))
`(div ()))))]
[(null? location-reps)
'(div () "No location information available.")]))
(define/private (render-source-location/1 location-rep)
(cond [(syntax? location-rep)
(let* ([src (syntax-source location-rep)]
[pos (syntax-position location-rep)]
[span (syntax-span location-rep)]
[line (syntax-line location-rep)]
[col (syntax-column location-rep)]
[file-name (resolve-source-file location-rep)]
[source-location (format "~a, ~a:~a" file-name line col)]
[src (cond [(symbol? src) src]
[(string? src) (string->symbol src)]
[else src])])
`(div () ,(render-source-location/h source-location src pos span)))]
[(eq? location-rep #f)
'(span ())]
[else
(printf "render-source-location/1: unexpected: ~s~n" location-rep)]))
(define/private (render-source-location/h source-location src pos span)
(if (and src drlink:can-show-source?)
`(link ,(lambda _ (drlink:show-source src pos span))
(clickback)
,source-location)
`(span () ,source-location)))
(define/private (render-backtrace-link text exn)
(if (drlink:has-backtrace? exn)
`(div () ,text
(link ,(lambda _ (drlink:show-backtrace exn))
(clickback)
"[backtrace]")
(div ()))
`(span ())))
(define/private (render-output model)
(let [(output (send model get-output))]
(if (null? output)
'(span ())
`(div ()
(div () "Output")
(wide-box
(span ()
,@(map (lambda (p)
(let [(styles
(cond [(eq? (car p) 'output) '(darkblue)]
[(eq? (car p) 'error) '(red italic)]))]
`(span ,styles ,(cadr p))))
output)))))))
(define/private (render-timing model)
(let [(timing (send model get-timing))]
(if timing
(let ([cpu (car timing)]
[real (cadr timing)]
[gc (caddr timing)])
`(div ()
(div () "Timing")
(span ()
"cpu: " ,cpu
"; real: " ,real
"; gc: " ,gc)
(div ())))
'(span ()))))
(define/private (resolve-source-file stx)
(let ([src (syntax-source stx)]
[src-module (syntax-source-module stx)])
(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 [(symbol? src-module) src-module]
[(eq? #f src-module) 'top-level]
[(string? src) src]
[else 'unknown]))))
))
)