#lang scheme/base

; DeinProgramm version of collects/test-engine/test-display.ss
; synched with SVN rev 16065

(provide contract-test-display%)

(require scheme/class
         scheme/file
         mred
         framework
         string-constants
         (lib "test-engine/test-info.scm")
         (lib "test-engine/test-engine.scm")
	 (lib "test-engine/print.ss")
	 deinprogramm/contract/contract
	 deinprogramm/contract/contract-test-engine
	 deinprogramm/quickcheck/quickcheck)

(define contract-test-display%
  (class* object% ()

    (init-field (current-rep #f))

    (define test-info #f)
    (define/pubment (install-info t) 
      (set! test-info t)
      (inner (void) install-info t))

    (define current-tab #f)
    (define drscheme-frame #f)
    (define src-editor #f)
    (define/public (display-settings df ct ed)
      (set! current-tab ct)
      (set! drscheme-frame df)
      (set! src-editor ed))

    (define (docked?)
      (and drscheme-frame
           (get-preference 'test:test-window:docked? 
                           (lambda () (put-preferences '(test:test-window:docked?) '(#f)) #f))))
    
    (define/public (report-success)
      (when current-rep
        (unless current-tab
          (set! current-tab (send (send current-rep get-definitions-text) get-tab)))
        (unless drscheme-frame
          (set! drscheme-frame (send current-rep get-top-level-window)))
        (let ([curr-win (and current-tab (send current-tab get-test-window))])
	  (when curr-win
	    (let ([content (make-object (editor:standard-style-list-mixin text%))])
	      (send content lock #t)
	      (when curr-win (send curr-win update-editor content))
	      (when current-tab (send current-tab current-test-editor content))
	      (when (docked?)
		(send drscheme-frame display-test-panel content)
		(send curr-win show #f)))))))

    (define/public (display-success-summary port count)
      (unless (test-silence)
	(display (case count
		   [(0) (string-constant test-engine-0-tests-passed)]
		   [(1) (string-constant test-engine-1-test-passed)]
		   [(2) (string-constant test-engine-both-tests-passed)]
		   [else (format (string-constant test-engine-all-n-tests-passed)
				 count)]) 
		 port)))

    (define/public (display-untested-summary port)
      (unless (test-silence)
        (fprintf port (string-constant test-engine-should-be-tested))
	(display "\n" port)))

    (define/public (display-disabled-summary port)
      (display (string-constant test-engine-tests-disabled) port)
      (display "\n" port))

    (define/public (display-results)
      (let* ([curr-win (and current-tab (send current-tab get-test-window))]
             [window (or curr-win (make-object test-window%))]
             [content (make-object (editor:standard-style-list-mixin text%))])

        (send this insert-test-results content test-info src-editor)
        (send content lock #t)
        (send window update-editor content)
        (when current-tab
          (send current-tab current-test-editor content)
          (unless curr-win
            (send current-tab current-test-window window)
            (send drscheme-frame register-test-window window)
            (send window update-switch
                  (lambda () (send drscheme-frame dock-tests)))
            (send window update-disable
                  (lambda () (send current-tab update-test-preference #f)))
            (send window update-closer
                  (lambda()
                    (send drscheme-frame deregister-test-window window)
                    (send current-tab current-test-window #f)
                    (send current-tab current-test-editor #f)))))
        (if (docked?)
	    (send drscheme-frame display-test-panel content)
	    (send window show #t))))

    (define/pubment (insert-test-results editor test-info src-editor)
      (let* ([style (send test-info test-style)]
             [total-checks (send test-info checks-run)]
             [failed-checks (send test-info checks-failed)]
	     [violated-contracts (send test-info failed-contracts)]
             [check-outcomes
              (lambda (zero-message)
                (send editor insert
                      (cond
                        [(zero? total-checks) zero-message]
                        [(= 1 total-checks) 
			 (string-append (string-constant test-engine-ran-1-check) "\n")]
                        [else (format (string-append (string-constant test-engine-ran-n-checks) "\n")
				      total-checks)]))
                (when (> total-checks 0)
                  (send editor insert
                        (cond
                          [(and (zero? failed-checks) (= 1 total-checks))
			   (string-append (string-constant test-engine-1-check-passed) "\n\n")]
                          [(zero? failed-checks) 
			   (string-append (string-constant test-engine-all-checks-passed) "\n\n")]
                          [(= failed-checks total-checks)
			   (string-append (string-constant test-engine-0-checks-passed) "\n")]
                          [else (format (string-append (string-constant test-engine-m-of-n-checks-failed) "\n\n")
                                        failed-checks total-checks)])))
		(send editor insert
		      (cond
		       ((null? violated-contracts)
			(string-append (string-constant test-engine-no-contract-violations) "\n\n"))
		       ((null? (cdr violated-contracts))
			(string-append (string-constant test-engine-1-contract-violation) "\n\n"))
		       (else
			(format (string-append (string-constant test-engine-n-contract-violations) "\n\n")
				(length violated-contracts)))))
		)])
        (case style
          [(check-require)
           (check-outcomes (string-append (string-constant test-engine-is-unchecked) "\n"))]
          [else (check-outcomes "")])

        (unless (and (zero? total-checks)
		     (null? violated-contracts))
          (inner (begin
		   (display-check-failures (send test-info failed-checks) 
					   editor test-info src-editor)
		   (send editor insert "\n")
		   (display-contract-violations violated-contracts
						editor test-info src-editor))
                 insert-test-results editor test-info src-editor))))

    (define/public (display-check-failures checks editor test-info src-editor)
      (when (pair? checks)
	(send editor insert (string-append (string-constant test-engine-check-failures) "\n")))
      (for ([failed-check (reverse checks)])
        (send editor insert "\t")
        (if (failed-check-exn? failed-check)
            (make-error-link editor
                             (failed-check-reason failed-check)
                             (failed-check-exn? failed-check)
                             (check-fail-src (failed-check-reason failed-check))
                             src-editor)
            (make-link editor
                       (failed-check-reason failed-check)
                       (check-fail-src (failed-check-reason failed-check))
                       src-editor))
        (send editor insert "\n")))

    (define/public (display-contract-violations violations editor test-info src-editor)
      (when (pair? violations)
	(send editor insert (string-append (string-constant test-engine-contract-violations) "\n")))
      (for-each (lambda (violation)
		  (send editor insert "\t")
		  (make-contract-link editor violation src-editor)
		  (send editor insert "\n"))
		violations))

    ;next-line: editor% -> void
    ;Inserts a newline and a tab into editor
    (define/public (next-line editor) (send editor insert "\n\t"))

    ;; make-link: text% check-fail src editor -> void
    (define (make-link text reason dest src-editor)
      (display-reason text reason)
      (let ((start (send text get-end-position)))
        (send text insert (format-src dest))
        (when (and src-editor current-rep)
          (send text set-clickback
                start (send text get-end-position)
                (lambda (t s e) (highlight-check-error dest src-editor))
                #f #f)
	  (set-clickback-style text start "royalblue"))))

    (define (display-reason text fail)
      (let* ((print-string
	      (lambda (m)
		(send text insert m)))
	     (print-formatted
	      (lambda (m)
		(when (is-a? m snip%)
		  (send m set-style (send (send text get-style-list)
					  find-named-style "Standard")))
		(send text insert m)))
	     (print
	      (lambda (fstring . vals)
		(apply print-with-values fstring print-string print-formatted vals)))
	     (formatter (check-fail-format fail)))
	(cond
	 [(unexpected-error? fail)
	  (print (string-constant test-engine-check-encountered-error)
		 (formatter (unexpected-error-expected fail))
		 (unexpected-error-message fail))]
	 [(unequal? fail)
	  (print (string-constant test-engine-actual-value-differs-error)
		 (formatter (unequal-test fail))
		 (formatter (unequal-actual fail)))]
	 [(outofrange? fail)
	  (print (string-constant test-engine-actual-value-not-within-error)
		 (formatter (outofrange-test fail))
		 (outofrange-range fail)
		 (formatter (outofrange-actual fail)))]
	 [(incorrect-error? fail)
	  (print (string-constant test-engine-encountered-error-error)
		 (incorrect-error-expected fail)
		 (incorrect-error-message fail))]
	 [(expected-error? fail)
	  (print (string-constant test-engine-expected-error-error)
		 (formatter (expected-error-value fail))
		 (expected-error-message fail))]
	 [(message-error? fail)
	  (for-each print-formatted (message-error-strings fail))]
         [(not-mem? fail)
          (print "Tatsächlicher Wert ~F ist keins der Elemente "
                 (formatter (not-mem-test fail)))
          (for-each (lambda (a) (print " ~F" (formatter a))) (not-mem-set fail))
          (print ".")]
         [(not-range? fail)
          (print "Tatsächlicher Wert ~F liegt nicht zwischen ~F und ~F (inklusive)."
                 (formatter (not-range-test fail))
                 (formatter (not-range-min fail))
                 (formatter (not-range-max fail)))]
	 [(property-fail? fail)
	  (print-string "Eigenschaft falsifizierbar mit")
	  (for-each (lambda (arguments)
		      (for-each (lambda (p)
				  (if (car p)
				      (print " ~a = ~F" (car p) (formatter (cdr p)))
				      (print "~F" (formatter (cdr p)))))
				arguments))
		    (result-arguments-list (property-fail-result fail)))]
	 [(property-error? fail)
	  (print "`check-property' bekam den folgenden Fehler~n:: ~a"
		 (property-error-message fail))])
	(print-string "\n")))

    ;; make-error-link: text% check-fail exn src editor -> void
    (define (make-error-link text reason exn dest src-editor)
      (make-link text reason dest src-editor)
      ;; the following code never worked
      #;(let ((start (send text get-end-position)))
        (send text insert (string-constant test-engine-trace-error))
	(send text insert " ")
        (when (and src-editor current-rep)
          (send text set-clickback
                start (send text get-end-position)
                (lambda (t s e) ((error-handler) exn))
                #f #f)
	  (set-clickback-style text start "red"))))

    (define (insert-messages text msgs)
      (for ([m msgs])
        (when (is-a? m snip%)
          (send m set-style (send (send text get-style-list)
                                  find-named-style "Standard")))
        (send text insert m)))

    (define (make-contract-link text violation src-editor)
      (let* ((contract (contract-violation-contract violation))
	     (stx (contract-syntax contract))
	     (srcloc (contract-violation-srcloc violation))
	     (message (contract-violation-message violation)))
	(cond
	 ((string? message)
	  (send text insert message))
	 ((contract-got? message)
	  (insert-messages text (list (string-constant test-engine-got)
				      " "
				      ((contract-got-format message)
				       (contract-got-value message))))))
	(when srcloc
	  (send text insert " ")
	  (let ((source (srcloc-source srcloc))
		(line (srcloc-line srcloc))
		(column (srcloc-column srcloc))
		(pos (srcloc-position srcloc))
		(span (srcloc-span srcloc))
		(start (send text get-end-position)))
	    (send text insert (format-position source line column))
	    (send text set-clickback
		  start (send text get-end-position)
		  (lambda (t s e)
		    (highlight-error line column pos span src-editor))
		  #f #f)
	    (set-clickback-style text start "blue")))
	(send text insert ", ")
	(send text insert (string-constant test-engine-contract))
	(send text insert " ")
	(format-clickable-syntax-src text stx src-editor)
	(cond
	 ((contract-violation-blame violation)
	  => (lambda (blame)
	       (next-line text)
	       (send text insert (string-constant test-engine-to-blame))
	       (send text insert " ")
	       (format-clickable-syntax-src text blame src-editor))))))
	
    (define (format-clickable-syntax-src text stx src-editor)
      (let ((start (send text get-end-position)))
	(send text insert (format-syntax-src stx))
	(send text set-clickback
	      start (send text get-end-position)
	      (lambda (t s e)
		(highlight-error/syntax stx src-editor))
	      #f #f)
	(set-clickback-style text start "blue")))

    (define (set-clickback-style text start color)
      (let ([end (send text get-end-position)]
	    [c (new style-delta%)])
	(send text insert " ")
	(send text change-style
	      (make-object style-delta% 'change-underline #t)
	      start end #f)
	(send c set-delta-foreground color)
	(send text change-style c start end #f)))

    (define (format-syntax-src stx)
      (format-position (syntax-source stx) 
		       (syntax-line stx) (syntax-column stx)))

    ;format-src: src -> string
    (define (format-src src)
      (format-position (car src) (cadr src) (caddr src)))

    (define (format-position file line column)
      (let ([line (cond [line => number->string]
			[else 
			 (string-constant test-engine-unknown)])]
	    [col
	     (cond [column => number->string]
		   [else (string-constant test-engine-unknown)])])  
	  
	(if (path? file)
	    (let-values (((base name must-be-dir?)
			  (split-path file)))
	      (if (path? name)
		  (format (string-constant test-engine-in-at-line-column)
			  (path->string name) line col)
		  (format (string-constant test-engine-at-line-column)
			  line col)))
	    (format (string-constant test-engine-at-line-column)
		    line col))))

    (define (highlight-error line column position span src-editor)
      (when (and current-rep src-editor)
	(cond
	 [(is-a? src-editor text:basic<%>)
	  (let ((highlight
		 (lambda ()
		   (send current-rep highlight-errors
			 (list (make-srcloc src-editor
					    line
					    column
					    position span)) #f))))
	    (queue-callback highlight))])))

    (define (highlight-check-error srcloc src-editor)
      (let* ([src-pos cadddr]
             [src-span (lambda (l) (car (cddddr l)))]
             [position (src-pos srcloc)]
             [span (src-span srcloc)])
	(highlight-error (cadr srcloc) (caddr srcloc)
			 position span
			 src-editor)))

    (define (highlight-error/syntax stx src-editor)
      (highlight-error (syntax-line stx) (syntax-column stx)
		       (syntax-position stx) (syntax-span stx)
		       src-editor))

    (super-instantiate ())))

(define test-window%
  (class* frame% ()

    (super-instantiate
     ((string-constant test-engine-window-title) #f 400 350))

    ;; (define editor #f)
    (define switch-func void)
    (define disable-func void)
    (define close-cleanup void)

    (define content
      (make-object editor-canvas% this #f '(auto-vscroll)))

    (define button-panel
      (make-object horizontal-panel% this
                   '() #t 0 0 0 0 '(right bottom) 0 0 #t #f))

    (define buttons
      (list (make-object button%
                         (string-constant close)
                         button-panel
                         (lambda (b c)
                           (when (eq? 'button (send c get-event-type))
                             (close-cleanup)
                             (send this show #f))))
            (make-object button%
                         (string-constant dock)
                         button-panel
                         (lambda (b c)
                           (when (eq? 'button (send c get-event-type))
                             (send this show #f)
                             (put-preferences '(test:test-window:docked?)
                                              '(#t))
                             (switch-func))))
            (make-object grow-box-spacer-pane% button-panel)))

    (define/public (update-editor e)
      ;;(set! editor e)
      (send content set-editor e))

    (define/public (update-switch thunk)
      (set! switch-func thunk))
    (define/public (update-closer thunk)
      (set! close-cleanup thunk))
    (define/public (update-disable thunk)
      (set! disable-func thunk))))

(define test-panel%
  (class* vertical-panel% ()

    (inherit get-parent)

    (super-instantiate ())

    (define content (make-object editor-canvas% this #f '()))
    (define button-panel (make-object horizontal-panel% this
                                      '() #t 0 0 0 0 '(right bottom) 0 0 #t #f))
    (define (hide)
      (let ([current-tab (send frame get-current-tab)])
        (send frame deregister-test-window 
              (send current-tab get-test-window))
        (send current-tab current-test-window #f)
        (send current-tab current-test-editor #f))
      (remove))

    (make-object button%
                 (string-constant hide)
                 button-panel
                 (lambda (b c)
                   (when (eq? 'button (send c get-event-type))
                     (hide))))
    #;(make-object button%
                 (string-constant profj-test-results-hide-and-disable)
                 button-panel
                 (lambda (b c)
                   (when (eq? 'button (send c get-event-type))
                     (hide)
                     (send (send frame get-current-tab)
                           update-test-preference #f))))
    (make-object button%
                 (string-constant undock)
                 button-panel
                 (lambda (b c)
                   (when (eq? 'button (send c get-event-type))
                     (put-preferences '(test:test-window:docked?) '(#f))
                     (send frame undock-tests))))

    (define/public (update-editor e)
      (send content set-editor e))

    (define frame #f)
    (define/public (update-frame f)
      (set! frame f))

    (define/public (remove)
      (let ([parent (get-parent)])
        (put-preferences '(test:test-dock-size)
                         (list (send parent get-percentages)))
        (send parent delete-child this)))))

