;;; I wondered yesterday night how hard it could be to write a CLIM
;;; frontend for RT. For those of you wondering the same thing, the answer
;;; is "not very". After 3 hours of hacking, this code was done (thanks to
;;; the clim listener for examples (-:).

;;; Requires mcclim and the RT package from <URL:http://cliki.net/rt>.

;;; Invoke with (rt-clim:rt)

;;; Bugs: some redisplay issues. I don't know if these are mcclim's or
;;; mine. Will have to ask tim moore (-:

;;; Get the Latest version from: http://boinkor.net/lisp/rt-clim.lisp

;;; Written by and Copyright 2004: Andreas Fuchs <asf@boinkor.net>
;;; License: MIT

(cl:defpackage :rt-clim
  (:use :clim :clim-lisp :rt)
  (:import-from :rt #:*entries* #:name #:pend #:vals #:do-entry
		#:*optimization-settings* #:equalp-with-case #:*compile-tests*
		#:*catch-errors*)
  (:export #:rt))

(cl:in-package :rt-clim)

(define-command-table rt-cmds)

;;; XXX: this is silly. RT should have a function that does just that
(defun run-entry (entry)
  (let (r
	(aborted nil))
    (block aborted
      (setf r
	    (flet ((%do
		       ()
		     (if *compile-tests*
			 (multiple-value-list
			  (funcall (compile
				    nil
				    `(lambda ()
				       (declare
					(optimize ,@*optimization-settings*))
				       ,(rt::form entry)))))
			 (multiple-value-list
			  (eval (rt::form entry))))))
	      (if *catch-errors*
		  (handler-bind
		      ((style-warning #'muffle-warning)
		       (error #'(lambda (c)
				  (setf aborted t)
				  (setf r (list c))
				  (return-from aborted nil))))
		    (%do))
		  (%do)))))
    (values (equalp-with-case r (vals entry))
	    r
	    (vals entry))))

(define-presentation-type entry () :inherit-from 'expression)
(define-presentation-type run-entry () :inherit-from 'entry)
(define-presentation-type successful-entry () :inherit-from 'run-entry)
(define-presentation-type failed-entry () :inherit-from 'run-entry)
(define-presentation-type descriptive-entry () :inherit-from 'run-entry)

;;; presentation methods

(define-presentation-method accept ((type entry) stream (view textual-view) &key)
  (let ((entry (accept 'expression
		       :stream stream
		       :view view
		       :history 'generic-function
		       :prompt nil)))
    (when (and entry
	       (member entry *entries*))
      (return-from accept entry))
    (let ((named-entry (find (the list (second entry)) ; XXX: (second entry) <- this is wrong.
			     (cdr *entries*)
			     :key #'name
			     :test #'equal)))
      (if named-entry
	  named-entry
	  (simple-parse-error "~S is not the name of a test entry." entry)))))

(define-presentation-method presentation-typep (object (type entry))
  (member object *entries*))

(define-presentation-method present (entry (type entry)
				     stream (view textual-view)
				     &key &allow-other-keys)
  (present (name entry) 'symbol :stream stream)
  (terpri stream))

(define-presentation-method present (entry (type run-entry)
				     stream (view textual-view)
				     &key &allow-other-keys)
  (let ((result (and entry (run-entry entry))))
    (if result
	(present entry 'successful-entry :stream stream :view view)
	(present entry 'failed-entry :stream stream :view view))
    (setf (tests-failed *application-frame*)
	  (or (tests-failed *application-frame*) result))))

(define-presentation-method present (entry (type successful-entry)
				     stream (view textual-view)
				     &key &allow-other-keys)
  (present entry 'entry :stream stream :view view))

(define-presentation-method present (entry (type failed-entry)
				     stream (view textual-view)
				     &key &allow-other-keys)
  (with-drawing-options (stream :ink +red+)
    (present entry 'entry :stream stream :view view)))

(define-presentation-method present (entry (type descriptive-entry)
					   stream (view textual-view)
					   &key &allow-other-keys)
  (multiple-value-bind (succeeded result expected) (run-entry entry)
    (if succeeded
	  (format stream "~&Test succeeded: ")
	  (format stream "~&Test failed: "))
    (present entry 'run-entry :stream stream)
    (format stream "Form: ")
    (present (rt::form entry) 'expression :stream stream)
    (format stream "~%Expected value~P: " (length expected))
    (present expected (presentation-type-of expected) :stream stream)
    (format stream "~%Actual value~P: " (length result))
    (with-drawing-options (stream :ink (if succeeded +black+ +red+))
      (present result (presentation-type-of result) :stream stream))))

;;; commands & translators

(define-command (com-show-test-result :name "Show Test Result"
				      :command-table rt-cmds
				      :provide-output-destination-keyword nil)
    ((test 'entry :prompt "Test"))
  (setf (displaying-result *application-frame*) test)
  (setf (pane-needs-redisplay (get-frame-pane *application-frame* 'test-details))
	t))

(define-presentation-to-command-translator show-test-result-translator
  (entry com-show-test-result rt-cmds :gesture :select)
    (object)
  (list object))


(define-command (com-run-tests :name "Run All Tests"
			       :command-table rt-cmds
			       :menu t)
    ()
  (setf (tests-failed *application-frame*) nil)
  (setf (pane-needs-redisplay (get-frame-pane *application-frame* 'test-results)) t)
  (setf (pane-needs-redisplay (get-frame-pane *application-frame* 'bar)) t))

(define-command (com-exit :name "Exit"
			  :command-table rt-cmds)
    ()
  (frame-exit *application-frame*))

;;; app frame

(define-application-frame rt (standard-application-frame)
    ((tests-failed :accessor tests-failed :initform nil)
     (displaying-result :accessor displaying-result :initform nil))
  (:panes (start-button :push-button :label ">" :id 'start)
	  (exit-button :push-button :label "X" :id 'exit)
	  (bar          :application
			:display-function #'display-bar
			:display-time t
			:scroll-bars nil)
	  (test-details :application
			:display-function #'show-test
			:display-time t
			:scroll-bars T)
	  (test-results :application
			:display-function #'run-all-tests
			:display-time t
			:scroll-bars T)
	  (doc :pointer-documentation))
  (:command-table (rt :inherit-from (rt-cmds)))
  (:layouts (default
 	       (vertically ()
		(horizontally ()
		   +fill+
		   start-button
		   exit-button
		   +fill+))
		(20 bar)
		(+fill+ (horizontally ()
                    test-results
		    test-details))
		doc)))

;;; app frame redisplay functions

(defun run-all-tests (frame stream)
  (declare (ignore frame))
  ;; XXX: this displays no columns the first time we expose the pane.
  ;;      subsequent redisplays work, though.
  (format-items (rest *entries*) :stream stream :presentation-type 'run-entry)
  (force-output stream))

(defun show-test (frame stream)
  (declare (ignore frame))
  (when (displaying-result *application-frame*)
    (present (displaying-result *application-frame*)
	     'descriptive-entry :stream stream))
  (force-output stream))

(defun display-bar (frame stream)
  (if (tests-failed frame)
      (setf (medium-background stream) +RED+)
      (setf (medium-background stream) +green+)))

(defmethod activate-callback ((button push-button) (client rt) (gadget-id (eql 'start)))
  (com-run-tests)
  (redisplay-frame-panes client))

(defmethod activate-callback ((button push-button) (client rt) (gadget-id (eql 'exit)))
  (com-exit))

(defun rt ()
  (run-frame-top-level (make-application-frame 'rt)))