(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<%>) ;; (test-suite? test)
               (render-suite-short-form model)]
              [(is-a? model model-case<%>) ;; (test-case? test)
               (render-case-short-form model)]))
      
      (define (model->rml/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 (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)
        ;; FIXME: source location representation changed; no longer have first case
        ;; How should we fix long term??
        (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]))))
      ))
  
  )