plt/gui/model2rml.ss
(module model2rml mzscheme
  (require (lib "class.ss")
           (lib "list.ss")
           (lib "mred.ss" "mred")
           (lib "plt-match.ss")
           (lib "file.ss")
           (lib "include-bitmap.ss" "mrlib")
           (prefix drlink: "drscheme-ui.ss")
           "interfaces.ss"
           "config.ss")
  (provide model-renderer%
           output-icon)

  (define (output-icon)
    (make-object image-snip% (include-bitmap "output-icon.png")))

  (define top-align (make-object style-delta% 'change-alignment 'top))

  (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<%>) ;; (test-suite? test)
               (render-suite-short-form model)]
              [(is-a? model model-case<%>) ;; (test-case? test)
               (render-case-short-form model)]))

      (define/public (render-model/long model)
        (cond [(is-a? model model-suite<%>) ;; (test-suite? test)
               (render-suite-long-form model)]
              [(is-a? model model-case<%>) ;; (test-case? test)
               (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 (n-things number singular plural)
        (if (= 1 number)
            (format "~a ~a" number singular)
            (format "~a ~a" number plural)))
      
      (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))
                 (count-successes (length successes))
                 (count-failures (length failures))
                 (count-errors (length errors))
                 (count-unexecuted (length unexecuted))
                 (total-successes (send model get-total-successes))
                 (total-failures (send model get-total-failures))
                 (total-cases (send model get-total-cases))
                 (output? (send model has-output?))
                 (trash? (send model has-trash?))]
            (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 (positive? (+ total-successes total-failures))
                (begin (put '() (format "Total: ~a"
                                        (n-things total-successes "success" "successes")))
                       (when (positive? total-failures)
                         (put '() (format ", ~a"
                                          (n-things total-failures "failure" "failures"))))
                       (blank)
                       (blank)
                       (when trash?
                         (put (list top-align) (output-icon))
                         (put '() "Tests did not clean up resources.\n"))
                       (when output?
                         (put (list top-align) (output-icon))
                         (put '() "Tests produced output.\n"))
                       (when (or trash? output?)
                         (blank))
                       (when (positive? count-failures)
                         (put '(large)
                              (format "Failures (~a/~a)\n"
                                      count-failures
                                      num-tests))
                         (for-each (lambda (m) (render-model/short m)) failures)
                         (blank))
                       (when (positive? count-errors)
                         (put '(large)
                              (format "Errors (~a/~a)\n"
                                      count-errors
                                      num-tests))
                         (for-each (lambda (m) (render-model/short m)) errors)
                         (blank))
                       (when (positive? count-unexecuted)
                         (put '(large)
                              (format "Unexecuted (~a/~a)\n"
                                      (length unexecuted)
                                      num-tests))
                         (for-each (lambda (m) (render-model/short m)) unexecuted)
                         (blank))
                       (when (positive? count-successes)
                         (put '(large)
                              (format "Successes (~a/~a)\n"
                                      count-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))
          (when (or (send model has-output?) (send model has-trash?))
            (put styles (output-icon)))))

      (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))
                 (total-failures (send model get-total-failures))]
            (let [(style (if (and (null? failures) (null? errors)) 'normal 'red))]
              (render-model-link model #t)
              (if (send model executed?)
                  (when (positive? total-failures)
                    (put `(,style)
                         (format " (~a)"
                                 (n-things total-failures "failure" "failures"))))
                  (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\n"))

      (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))
               (expecteds (send model get-property-set 'expected))
               (actuals (send model get-property-set 'actual))
               (params (send model get-property prop:failure-parameters))
               (other-properties
                (filter (lambda (p) (not (known-property? (car p))))
                        (send model get-all-properties)))
               (exn2 (send model get-property 'exception))]
          (put '() "The test case failed on ")
          (put '(fail-type) (format "~a" exnname))
          (put '() ".\n\n")
          (render-source-location "Check location" exnlocs)
          (render-backtrace-link "Backtrace of check failure:" exn)
          (render-messages messages)
          (if (and (pair? expecteds) (pair? actuals))
              (render-expected+actual (car expecteds) (car actuals))
              (render-parameters params))
          (render-embedded-exception exn2)
          (render-other-properties other-properties)
          ))
      
      (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 an 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-value-box/display value)
        (send editor insert-wide-box
              (lambda (editor)
                (send editor insert/styles '(value) (format "~a" 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-expected+actual expected actual)
        (put '() "Actual:\n")
        (render-value-box actual)
        (put '() "Expected:\n")
        (render-value-box expected)
        (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-other-properties properties)
        (when (pair? properties)
          (put '() "Additional information:\n")
          (for-each (lambda (p) (render-other-property (car p) (cdr p)))
                    properties)
          (blank)))

      (define/private (render-other-property key value)
        (put '() (format "key ~s:" key))
        (when (exn? value)
          (inline-backtrace-link "" value))
        (put '() "\n")
        (render-value-box value))

      (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.")
          (blank)
          (blank)))

      (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 (exn? exn)
          (if (drlink:has-backtrace? exn)
              (inline-backtrace-link text exn)
              (begin (put '() text)
                     (put '() " not available")))
          (blank)
          (blank)))

      (define/private (inline-backtrace-link text exn)
        (when (drlink:has-backtrace? exn)
          (put '() text))
        (when (drlink:has-errortrace-backtrace? exn)
          (put '() " ")
          (put+click '(clickback)
                     (lambda _ (drlink:show-errortrace-backtrace exn))
                     "[from DrScheme]"))
        (when (drlink:has-primitive-backtrace? exn)
          (put '() " ")
          (put+click '(clickback)
                     (lambda _ (drlink:show-primitive-backtrace exn))
                     "[from mzscheme]")))

      (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/display 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 [(path? src) (path->string src)]
                  [(string? src) src]
                  [else 'unknown])))
      ))
  )