(in-package "KPML-I")

;;; 2.0.61 (interface)
;;; Make a suitable window to show the progress during example
;;; running when we run the example runner from an interface window.
;;; Particularly useful in, e.g., Lispworks, where the progress
;;; messages don't make it out at all.

(defvar *EX-RUNNING-FRAME* nil)

;;; ----------------------------------------------------------------------
;;; The progress noting frame for the example runner when running
;;; with the interface otherwise disabled...
;;;
;;; This is (at present) just a simple frame with a single scrollable
;;; pane where the trace messages are put during example running. Nothing
;;; is selectable or doable anything with.
;;;
;;; This should not be quit before the example runner is finished.
;;; Should disable the command until then...
;;; ----------------------------------------------------------------------

(clim:define-application-frame EXAMPLE-RUNNING-PROGRESS-FRAME ()
  (
   (example-runner-done :initform nil)  ;; this gets set when we are done...
   )
  (:menu-bar T)
  (:command-table EXAMPLE-RUNNING-PROGRESS-FRAME)
  (:top-level (clim:default-frame-top-level))
  (:panes (info-pane  :application
                      :scroll-bars T
		      :end-of-line-action :allow
		      :initial-cursor-visibility :inactive
		      :foreground spl-fg
		      :background spl-bg
		      :text-style *sans-serif--roman--9*))
 (:layouts (first info-pane)))

(defun STARTUP-EXAMPLE-RUNNING-PROGRESS-FRAME (label &optional (reset T))
  #-acl3.0(when (and reset *ex-running-frame*)
	    (close-a-window *ex-running-frame*)
	    (setf *ex-running-frame* nil))
  (let* ((frame (setf *ex-running-frame*
		  (clim:make-application-frame
		   'example-running-progress-frame
		   :pretty-name label
		   :left 100 :top 20
		   :width 500 :height 400)))
	  (process
	   (process-run-function "KPML-EXRUN-PROGRESS" 
				 #'run-packaged-frame
				 frame (find-package "KPML"))))
    #-acl3.0(push (cons frame process) *frame-process-alist*)
    T))

(defun INFO-PANE-READY-P ()
  (and *ex-running-frame*
       #+lispworks
       (:version-case (":LISPWORKS")
        ((+ "4.0")
         (slot-boundp  *ex-running-frame* 'clim-internals::panes)))
       (clim:get-frame-pane *ex-running-frame* 'info-pane :errorp nil)))

#-acl3.0
(define-example-running-progress-frame-command 
    (com-quit-example-runner-progress :name "Quit" :menu T)
    ()
  (if (slot-value clim:*application-frame* 'example-runner-done) 
      (progn
	(setf *ex-running-frame* nil)
	(close-a-window clim:*application-frame*)
	)
    (clim:notify-user 
     clim:*application-frame*
     "The example runner is not yet finished. 

Quitting this window before the example runner 
has run to completion is not advisable.")))

;;; ----------------------------------------------------------------------
;;; This supports the following wrapper around the example runner...
   ;; ----------------------------------------------------------------------
   ;; part of 3.2.17
   ;; 3.2.50 folded in.
   ;; 3.2.64 folded in.
   ;; ----------------------------------------------------------------------

(defun EXAMPLE-RUNNER-NOTING-PROGRESS (example-list label) 
  (let ((stream 
	 ;; make a frame for which the following provides the output, sent
	 ;; to the active stream stream. 
	 (progn
	   (startup-example-running-progress-frame label)
	   (loop until (info-pane-ready-p) do (sleep 3))
	   (clim:get-frame-pane *ex-running-frame* 'info-pane)))
	(kpml::complexity-maximum                 ;;
	 (if *exrun-complexity-maximum*           ;;
	     *exrun-complexity-maximum*           ;; 3.2.17
	   kpml::complexity-maximum)))            ;;
    (declare (special kpml::complexity-maximum    ;;
		      kpml::*serious-failures*            ;; 3.2.50
		      kpml::*serious-failure-count*       ;; 
		      ))
    ;; 2.1 thanks to Stancho for the following...
    (clim:with-output-recording-options (stream :record T)
      (clim:with-text-style (stream *sans-serif--bold--12*)
        (format stream "The example runner will now run. Interaction")
        (format stream "~%with KPML is restricted during this process.~%"))
      (setf kpml::*serious-failures*      nil
	    kpml::*serious-failure-count* 0)
      (kpml::example-runner-to-file-only
       example-list
       (namestring
        (merge-pathnames
         kpml::*example-runner-results*
         (pathname (kpml::make-example-results-filename))))
       :say-p t
       :message-stream stream)

      (clim:with-text-style (stream *sans-serif--bold--12*)
       ;; 3.2.50
       (when kpml::*serious-failures*
	 (format stream "~2%There were also ~A serious breakages." 
		kpml::*serious-failure-count*)
	 (format stream "~%  caused by: ~S" kpml::*serious-failures*))

      ;; 3.2.17
       (format stream "~2%Maximum complexity hit during run was: ~A."
	       kpml::*max-complexity-reached*))
      (setf (slot-value *ex-running-frame* 'example-runner-done) T))))
      

