(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<%>)
(public model->rml/short
model->rml/long)
(init-field controller)
(super-instantiate ())
(define (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 (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 (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)
"Successes"
,(format " (~a/~a)" (length successes) num-tests))
,@(map (lambda (s) (model->rml/short s)) successes))
(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))
,(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 (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 (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 (render-success-short-form model)
(render-case/h
model
" succeeded"))
(define (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 (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 (render-not-executed-short-form model)
(render-case/h
model
`(span (test-unexecuted) " has not been executed")))
(define (render-case/h model . afterdivs)
`(div ()
(link ,(lambda _ (send controller select-model model))
(italic clickback)
,(send model get-name))
,@afterdivs))
(define (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 (render-success-long-form model)
(render-case/lh
model
`(div ()
(div () "The test case succeeded.")
(div ())
,(render-timing model)
,(render-output model))))
(define (render-failure-long-form model)
(let* [(exn (send model get-result))
(msg (exn-message exn))
(exnname (send model get-property prop:failure-assertion))
(exnloc (send model get-property prop:failure-location))
(exnparams (send model get-property prop:failure-parameters))]
(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 exnloc)
,(render-parameters exnparams)
,(render-message msg)
,(render-timing model)
,(render-output model)))))
(define (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-message (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 (render-not-executed-long-form model)
(render-case/lh
model
`(div (test-unexecuted)
"The test case has not been executed.")))
(define (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 (render-value text value)
`(div () ,text
(div (value) (wide-box ,(format "~v" value)))))
(define (render-message message)
(if (and (string? message) (positive? (string-length message)))
`(div ()
(div () "Message:")
(wide-box
(span (exn-message) ,(format "~v" message)))
(div ()))
'(span ())))
(define (render-parameters parameters)
(if (and parameters (pair? parameters))
`(div ()
(div () "Parameters:")
,@(map (lambda (parameter)
`(div (value)
(wide-box ,(format "~v" parameter))))
parameters))
'(span ())))
(define (render-source-location location)
(cond [(list? location)
(let-values [((src line col pos span src-module)
(apply values location))]
(let* [(file-name (resolve-source-file location))
(source-location (format "~a, ~a:~a" file-name line col))
(src (cond [(symbol? src) src]
[(string? src) (string->symbol src)]
[else src]))]
`(div () "Location: "
,(render-source-location/h source-location src pos span)
(div ()))))]
[else
'(span ())]))
(define (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 (render-backtrace-link text exn)
(if (drlink:has-backtrace? exn)
`(div () ,text
(link ,(lambda _ (drlink:show-backtrace exn))
(clickback)
"[backtrace]")
(div ()))
`(span ())))
(define (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 (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 (resolve-source-file loc)
(let-values [((src line col pos span src-module)
(apply values loc))]
(or (and (is-a? src editor<%>)
(let* [(temp?-box (box #t))
(filename (send src get-filename temp?-box))]
(if (and filename (not (unbox temp?-box)))
filename
#f)))
(cond [(symbol? src-module) (symbol->string src-module)]
[(eq? #f src-module) 'top-level]
[(string? src) src]
[else 'unknown]))))
))
)