(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<%>) ;; (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 (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])))
      ))
  )